/[notice-sender]/jifty-dbi/lib/Nos.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Diff of /jifty-dbi/lib/Nos.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

trunk/Nos.pm revision 38 by dpavlin, Tue May 17 21:37:06 2005 UTC jifty-dbi/lib/Nos.pm revision 92 by dpavlin, Tue Dec 19 10:32:18 2006 UTC
# Line 16  our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all' Line 16  our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'
16  our @EXPORT = qw(  our @EXPORT = qw(
17  );  );
18    
19  our $VERSION = '0.3';  our $VERSION = '0.9_00';
20    
 use Class::DBI::Loader;  
21  use Email::Valid;  use Email::Valid;
22  use Email::Send;  use Email::Send;
23  use Carp;  use Carp;
# Line 26  use Email::Auth::AddressHash; Line 25  use Email::Auth::AddressHash;
25  use Email::Simple;  use Email::Simple;
26  use Email::Address;  use Email::Address;
27  use Mail::DeliveryStatus::BounceParser;  use Mail::DeliveryStatus::BounceParser;
28  use Data::Dumper;  use Mail::Alias;
29    use Cwd qw(abs_path);
30    
31    use Jifty::DBI::Handle;
32    use lib 'lib';
33    use Nos::Lists;
34    
35    
36  =head1 NAME  =head1 NAME
37    
# Line 39  Nos - Notice Sender core module Line 44  Nos - Notice Sender core module
44    
45  =head1 DESCRIPTION  =head1 DESCRIPTION
46    
47  Core module for notice sender's functionality.  Notice sender is mail handler. It is not MTA, since it doesn't know how to
48    receive e-mails or send them directly to other hosts. It is not mail list
49    manager because it requires programming to add list members and send
50    messages. You can think of it as mechanisam for off-loading your e-mail
51    sending to remote server using SOAP service.
52    
53    It's concept is based around B<lists>. Each list can have zero or more
54    B<members>. Each list can have zero or more B<messages>.
55    
56    Here comes a twist: each outgoing message will have unique e-mail generated,
57    so Notice Sender will be able to link received replies (or bounces) with
58    outgoing messages.
59    
60    It doesn't do much more than that. It B<can't> create MIME encoded e-mail,
61    send attachments, handle 8-bit characters in headers (which have to be
62    encoded) or anything else.
63    
64    It will just queue your e-mail message to particular list (sending it to
65    possibly remote Notice Sender SOAP server just once), send it out at
66    reasonable rate (so that it doesn't flood your e-mail infrastructure) and
67    keep track replies.
68    
69    It is best used to send small number of messages to more-or-less fixed
70    list of recipients while allowing individual responses to be examined.
71    Tipical use include replacing php e-mail sending code with SOAP call to
72    Notice Sender. It does support additional C<ext_id> field for each member
73    which can be used to track some unique identifier from remote system for
74    particular user.
75    
76    It comes with command-line utility C<sender.pl> which can be used to perform
77    all available operation from scripts (see C<sender.pl --man>).
78    This command is also useful for debugging while writing client SOAP
79    application.
80    
81  =head1 METHODS  =head1 METHODS
82    
# Line 54  Create new instance specifing database, Line 91  Create new instance specifing database,
91          debug => 1,          debug => 1,
92          verbose => 1,          verbose => 1,
93          hash_len => 8,          hash_len => 8,
94            full_hostname_in_aliases => 0,
95   );   );
96    
97  Parametar C<hash_len> defines length of hash which will be added to each  Parametar C<hash_len> defines length of hash which will be added to each
98  outgoing e-mail message to ensure that replies can be linked with sent e-mails.  outgoing e-mail message to ensure that replies can be linked with sent e-mails.
99    
100    C<full_hostname_in_aliases> will turn on old behaviour (not supported by Postfix
101    postalias) to include full hostname in aliases file.
102    
103    
104  =cut  =cut
105    
106  sub new {  sub new {
107          my $class = shift;          my $class = shift;
108          my $self = {@_};          my $self = {@_};
109          bless($self, $class);          bless($self, $class);
110    
111          croak "need at least dsn" unless ($self->{'dsn'});          croak "need at least dsn" unless ($self->{dsn});
112    
113            my (undef,$driver,$dbname) = split(/:/, $self->{dsn});
114            $dbname =~ s!^dbname=!!;
115    
116            $self->{h} = Jifty::DBI::Handle->new();
117            $self->{h}->connect(
118                    driver   => $driver,
119                    database => $dbname,
120                    host     => 'localhost',
121                    user     => $self->{user},
122                    password => $self->{passwd},
123            );
124    
125          $self->{'loader'} = Class::DBI::Loader->new(          $self->{'loader'} = Class::DBI::Loader->new(
126                  debug           => $self->{'debug'},                  debug           => $self->{'debug'},
127                  dsn             => $self->{'dsn'},                  dsn                     => $self->{'dsn'},
128                  user            => $self->{'user'},                  user            => $self->{'user'},
129                  password        => $self->{'passwd'},                  password        => $self->{'passwd'},
130                  namespace       => "Nos",                  namespace       => "Nos",
131  #               additional_classes      => qw/Class::DBI::AbstractSearch/,                  additional_classes      => qw/Class::DBI::AbstractSearch/,
132  #               additional_base_classes => qw/My::Stuff/,  #               additional_base_classes => qw/My::Stuff/,
133                  relationships   => 1,                  relationships   => 1,
134          ) || croak "can't init Class::DBI::Loader";          ) || croak "can't init Class::DBI::Loader";
# Line 85  sub new { Line 139  sub new {
139  }  }
140    
141    
142  =head2 new_list  =head2 create_list
143    
144  Create new list. Required arguments are name of C<list> and  Create new list. Required arguments are name of C<list>, C<email> address
145  C<email> address.  and path to C<aliases> file.
146    
147   $nos->new_list(   $nos->create_list(
148          list => 'My list',          list => 'My list',
149            from => 'Outgoing from comment',
150          email => 'my-list@example.com',          email => 'my-list@example.com',
151            aliases => '/etc/mail/mylist',
152            archive => '/path/to/mbox/archive',
153   );   );
154    
155  Returns ID of newly created list.  Returns ID of newly created list.
156    
157  Calls internally L<_add_list>, see details there.  Calls internally C<_add_list>, see details there.
158    
159  =cut  =cut
160    
161  sub new_list {  sub create_list {
162          my $self = shift;          my $self = shift;
163    
164          my $arg = {@_};          my $arg = {@_};
165    
166          confess "need list name" unless ($arg->{'list'});          confess "need list name" unless ($arg->{'list'});
167          confess "need list email" unless ($arg->{'list'});          confess "need list email" unless ($arg->{'email'});
168    
169            $arg->{'list'} = lc($arg->{'list'});
170            $arg->{'email'} = lc($arg->{'email'});
171    
172          my $l = $self->_get_list($arg->{'list'}) ||          my $l = $self->_get_list($arg->{'list'}) ||
173                  $self->_add_list( @_ ) ||                  $self->_add_list( @_ ) ||
# Line 117  sub new_list { Line 177  sub new_list {
177  }  }
178    
179    
180    =head2 drop_list
181    
182    Delete list from database.
183    
184     my $ok = drop_list(
185            list => 'My list'
186            aliases => '/etc/mail/mylist',
187     );
188    
189    Returns false if list doesn't exist.
190    
191    =cut
192    
193    sub drop_list {
194            my $self = shift;
195    
196            my $args = {@_};
197    
198            croak "need list to delete" unless ($args->{'list'});
199    
200            $args->{'list'} = lc($args->{'list'});
201    
202            my $aliases = $args->{'aliases'} || croak "need path to aliases file";
203    
204            my $lists = $self->{'loader'}->find_class('lists');
205    
206            my $this_list = $lists->search( name => $args->{'list'} )->first || return;
207    
208            $self->_remove_alias( email => $this_list->email, aliases => $aliases);
209    
210            $this_list->delete || croak "can't delete list\n";
211    
212            return $lists->dbi_commit || croak "can't commit";
213    }
214    
215    
216  =head2 add_member_to_list  =head2 add_member_to_list
217    
218  Add new member to list  Add new member to list
# Line 125  Add new member to list Line 221  Add new member to list
221          list => "My list",          list => "My list",
222          email => "john.doe@example.com",          email => "john.doe@example.com",
223          name => "John A. Doe",          name => "John A. Doe",
224            ext_id => 42,
225   );   );
226    
227  C<name> parametar is optional.  C<name> and C<ext_id> parametars are optional.
228    
229  Return member ID if user is added.  Return member ID if user is added.
230    
# Line 138  sub add_member_to_list { Line 235  sub add_member_to_list {
235    
236          my $arg = {@_};          my $arg = {@_};
237    
238          my $email = $arg->{'email'} || croak "can't add user without e-mail";          my $email = lc($arg->{'email'}) || croak "can't add user without e-mail";
239          my $name = $arg->{'name'} || '';          my $name = $arg->{'name'} || '';
240          my $list_name = $arg->{'list'} || croak "need list name";          my $list_name = lc($arg->{'list'}) || croak "need list name";
241            my $ext_id = $arg->{'ext_id'};
242    
243          my $list = $self->_get_list($list_name) || croak "list $list_name doesn't exist";          my $list = $self->_get_list($list_name) || croak "list $list_name doesn't exist";
244    
# Line 158  sub add_member_to_list { Line 256  sub add_member_to_list {
256                  email => $email,                  email => $email,
257          }) || croak "can't find or create member\n";          }) || croak "can't find or create member\n";
258    
259          if ($name && $this_user->full_name ne $name) {          if ($name && $this_user->name ne $name) {
260                  $this_user->full_name($name || '');                  $this_user->name($name || '');
261                    $this_user->update;
262            }
263    
264            if (defined($ext_id) && ($this_user->ext_id || '') ne $ext_id) {
265                    $this_user->ext_id($ext_id);
266                  $this_user->update;                  $this_user->update;
267          }          }
268    
# Line 175  sub add_member_to_list { Line 278  sub add_member_to_list {
278          return $this_user->id;          return $this_user->id;
279  }  }
280    
281    =head2 list_members
282    
283    List all members of some list.
284    
285     my @members = list_members(
286            list => 'My list',
287     );
288    
289    Returns array of hashes with user information like this:
290    
291     $member = {
292            name => 'Dobrica Pavlinusic',
293            email => 'dpavlin@rot13.org
294     }
295    
296    If list is not found, returns false. If there is C<ext_id> in user data,
297    it will also be returned.
298    
299    =cut
300    
301    sub list_members {
302            my $self = shift;
303    
304            my $args = {@_};
305    
306            my $list_name = lc($args->{'list'}) || confess "need list name";
307    
308            my $lists = $self->{'loader'}->find_class('lists');
309            my $user_list = $self->{'loader'}->find_class('user_list');
310    
311            my $this_list = $lists->search( name => $list_name )->first || return;
312    
313            my @results;
314    
315            foreach my $user_on_list ($user_list->search(list_id => $this_list->id)) {
316                    my $row = {
317                            name => $user_on_list->user_id->name,
318                            email => $user_on_list->user_id->email,
319                    };
320    
321                    my $ext_id = $user_on_list->user_id->ext_id;
322                    $row->{'ext_id'} = $ext_id if (defined($ext_id));
323    
324                    push @results, $row;
325            }
326    
327            return @results;
328    
329    }
330    
331    
332    =head2 delete_member
333    
334    Delete member from database.
335    
336     my $ok = delete_member(
337            name => 'Dobrica Pavlinusic'
338     );
339    
340     my $ok = delete_member(
341            email => 'dpavlin@rot13.org'
342     );
343    
344    Returns false if user doesn't exist.
345    
346    This function will delete member from all lists (by cascading delete), so it
347    shouldn't be used lightly.
348    
349    =cut
350    
351    sub delete_member {
352            my $self = shift;
353    
354            my $args = {@_};
355    
356            croak "need name or email of user to delete" unless ($args->{'name'} || $args->{'email'});
357    
358            $args->{'email'} = lc($args->{'email'}) if ($args->{'email'});
359    
360            my $key = 'name';
361            $key = 'email' if ($args->{'email'});
362    
363            my $users = $self->{'loader'}->find_class('users');
364    
365            my $this_user = $users->search( $key => $args->{$key} )->first || return;
366    
367            $this_user->delete || croak "can't delete user\n";
368    
369            return $users->dbi_commit || croak "can't commit";
370    }
371    
372    =head2 delete_member_from_list
373    
374    Delete member from particular list.
375    
376     my $ok = delete_member_from_list(
377            list => 'My list',
378            email => 'dpavlin@rot13.org',
379     );
380    
381    Returns false if user doesn't exist on that particular list.
382    
383    It will die if list or user doesn't exist. You have been warned (you might
384    want to eval this functon to prevent it from croaking).
385    
386    =cut
387    
388    sub delete_member_from_list {
389            my $self = shift;
390    
391            my $args = {@_};
392    
393            croak "need list name and email of user to delete" unless ($args->{'list'} && $args->{'email'});
394    
395            $args->{'list'} = lc($args->{'list'});
396            $args->{'email'} = lc($args->{'email'});
397    
398            my $user = $self->{'loader'}->find_class('users');
399            my $list = $self->{'loader'}->find_class('lists');
400            my $user_list = $self->{'loader'}->find_class('user_list');
401    
402            my $this_user = $user->search( email => $args->{'email'} )->first || croak "can't find user: ".$args->{'email'};
403            my $this_list = $list->search( name => $args->{'list'} )->first || croak "can't find list: ".$args->{'list'};
404    
405            my $this_user_list = $user_list->search_where( list_id => $this_list->id, user_id => $this_user->id )->first || return;
406    
407            $this_user_list->delete || croak "can't delete user from list\n";
408    
409            return $user_list->dbi_commit || croak "can't commit";
410    }
411    
412  =head2 add_message_to_list  =head2 add_message_to_list
413    
414  Adds message to one list's queue for later sending.  Adds message to one list's queue for later sending.
# Line 200  sub add_message_to_list { Line 434  sub add_message_to_list {
434    
435          my $args = {@_};          my $args = {@_};
436    
437          my $list_name = $args->{'list'} || confess "need list name";          my $list_name = lc($args->{'list'}) || confess "need list name";
438          my $message_text = $args->{'message'} || croak "need message";          my $message_text = $args->{'message'} || croak "need message";
439    
440          my $m = Email::Simple->new($message_text) || croak "can't parse message";          my $m = Email::Simple->new($message_text) || croak "can't parse message";
441    
442          unless( $m->header('Subject') ) {          warn "message doesn't have Subject header\n" unless( $m->header('Subject') );
                 warn "message doesn't have Subject header\n";  
                 return;  
         }  
443    
444          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
445    
# Line 241  sub add_message_to_list { Line 472  sub add_message_to_list {
472    
473  Send queued messages or just ones for selected list  Send queued messages or just ones for selected list
474    
475   $nos->send_queued_messages("My list");   $nos->send_queued_messages(
476            list => 'My list',
477            driver => 'smtp',
478            sleep => 3,
479     );
480    
481    Second option is driver which will be used for e-mail delivery. If not
482    specified, C<IO> driver will be used which will dump e-mail to C<STDERR>.
483    
484    Other valid drivers are:
485    
486    =over 10
487    
488    =item smtp
489    
490    Send e-mail using SMTP server at 127.0.0.1
491    
492    =back
493    
494    Any other driver name will try to use C<Email::Send::that_driver> module.
495    
496    Default sleep wait between two messages is 3 seconds.
497    
498    This method will return number of succesfully sent messages.
499    
500  =cut  =cut
501    
502  sub send_queued_messages {  sub send_queued_messages {
503          my $self = shift;          my $self = shift;
504    
505          my $list_name = shift;          my $arg = {@_};
506    
507            my $list_name = lc($arg->{'list'}) || '';
508            my $driver = $arg->{'driver'} || '';
509            my $sleep = $arg->{'sleep'};
510            $sleep ||= 3 unless defined($sleep);
511    
512            # number of messages sent o.k.
513            my $ok = 0;
514    
515            my $email_send_driver = 'Email::Send::IO';
516            my @email_send_options;
517    
518            if (lc($driver) eq 'smtp') {
519                    $email_send_driver = 'Email::Send::SMTP';
520                    @email_send_options = ['127.0.0.1'];
521            } elsif ($driver && $driver ne '') {
522                    $email_send_driver = 'Email::Send::' . $driver;
523            } else {
524                    warn "dumping all messages to STDERR\n";
525            }
526    
527          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
528          my $queue = $self->{'loader'}->find_class('queue');          my $queue = $self->{'loader'}->find_class('queue');
# Line 280  sub send_queued_messages { Line 554  sub send_queued_messages {
554                          if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {                          if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {
555                                  print "SKIP $to_email message allready sent\n";                                  print "SKIP $to_email message allready sent\n";
556                          } else {                          } else {
557                                  print "=> $to_email\n";                                  print "=> $to_email ";
558    
559                                  my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;                                  my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;
560                                  my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );                                  my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
561    
562                                  my $hash = $auth->generate_hash( $to_email );                                  my $hash = $auth->generate_hash( $to_email );
563    
564                                  my $from = $u->list_id->name . " <" . $from . "+" . $hash . ( $domain ? "@" . $domain : '' ). ">";                                  my $from_addr;
565                                  my $to = $u->user_id->full_name . " <$to_email>";                                  my $from_email_only = $from . "+" . $hash . ( $domain ? '@' . $domain : '');
566    
567                                    $from_addr .= '"' . $u->list_id->from_addr . '" ' if ($u->list_id->from_addr);
568                                    $from_addr .= '<' . $from_email_only . '>';
569                                    my $to = '"' . $u->user_id->name . '" <' . $to_email . '>';
570    
571                                  my $m_obj = Email::Simple->new($msg) || croak "can't parse message";                                  my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
572    
573                                  $m_obj->header_set('From', $from) || croak "can't set From: header";                                  $m_obj->header_set('Return-Path', $from_email_only) || croak "can't set Return-Path: header";
574                                    #$m_obj->header_set('Sender', $from_email_only) || croak "can't set Sender: header";
575                                    $m_obj->header_set('Errors-To', $from_email_only) || croak "can't set Errors-To: header";
576                                    $m_obj->header_set('From', $from_addr) || croak "can't set From: header";
577                                  $m_obj->header_set('To', $to) || croak "can't set To: header";                                  $m_obj->header_set('To', $to) || croak "can't set To: header";
578    
579                                  $m_obj->header_set('X-Nos-Version', $VERSION);                                  $m_obj->header_set('X-Nos-Version', $VERSION);
580                                  $m_obj->header_set('X-Nos-Hash', $hash);                                  $m_obj->header_set('X-Nos-Hash', $hash);
581    
582                                  # FIXME do real sending :-)                                  # really send e-mail
583                                  send IO => $m_obj->as_string;                                  my $sent_status;
584    
585                                  $sent->create({                                  if (@email_send_options) {
586                                          message_id => $m->message_id,                                          $sent_status = send $email_send_driver => $m_obj->as_string, @email_send_options;
587                                          user_id => $u->user_id,                                  } else {
588                                          hash => $hash,                                          $sent_status = send $email_send_driver => $m_obj->as_string;
589                                  });                                  }
590                                  $sent->dbi_commit;  
591                                    croak "can't send e-mail: $sent_status\n\nOriginal e-mail follows:\n".$m_obj->as_string unless ($sent_status);
592                                    my @bad;
593                                    @bad = @{ $sent_status->prop('bad') } if (eval { $sent_status->can('prop') });
594                                    croak "failed sending to ",join(",",@bad) if (@bad);
595    
596                                    if ($sent_status) {
597    
598                                            $sent->create({
599                                                    message_id => $m->message_id,
600                                                    user_id => $u->user_id,
601                                                    hash => $hash,
602                                            });
603                                            $sent->dbi_commit;
604    
605                                            print " - $sent_status\n";
606    
607                                            $ok++;
608                                    } else {
609                                            warn "ERROR: $sent_status\n";
610                                    }
611    
612                                    if ($sleep) {
613                                            warn "sleeping $sleep seconds\n";
614                                            sleep($sleep);
615                                    }
616                          }                          }
617                  }                  }
618                  $m->all_sent(1);                  $m->all_sent(1);
# Line 314  sub send_queued_messages { Line 620  sub send_queued_messages {
620                  $m->dbi_commit;                  $m->dbi_commit;
621          }          }
622    
623            return $ok;
624    
625  }  }
626    
627  =head2 inbox_message  =head2 inbox_message
# Line 325  Receive single message for list's inbox. Line 633  Receive single message for list's inbox.
633          message => $message,          message => $message,
634   );   );
635    
636    This method is used by C<sender.pl> when receiving e-mail messages.
637    
638  =cut  =cut
639    
640  sub inbox_message {  sub inbox_message {
# Line 335  sub inbox_message { Line 645  sub inbox_message {
645          return unless ($arg->{'message'});          return unless ($arg->{'message'});
646          croak "need list name" unless ($arg->{'list'});          croak "need list name" unless ($arg->{'list'});
647    
648            $arg->{'list'} = lc($arg->{'list'});
649    
650          my $this_list = $self->_get_list($arg->{'list'}) || croak "can't find list ".$arg->{'list'}."\n";          my $this_list = $self->_get_list($arg->{'list'}) || croak "can't find list ".$arg->{'list'}."\n";
651    
652          my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message";          my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message";
653    
654          my $to = $m->header('To') || die "can't find To: address in incomming message\n";          my $to = $m->header('To') || die "can't find To: address in incomming message\n";
655    
656            my $return_path = $m->header('Return-Path') || '';
657    
658          my @addrs = Email::Address->parse( $to );          my @addrs = Email::Address->parse( $to );
659    
660          die "can't parse To: $to address\n" unless (@addrs);          die "can't parse To: $to address\n" unless (@addrs);
# Line 350  sub inbox_message { Line 664  sub inbox_message {
664          my $hash;          my $hash;
665    
666          foreach my $a (@addrs) {          foreach my $a (@addrs) {
667                  if ($a->address =~ m/\+([a-f0-9]{$hl})@/) {                  if ($a->address =~ m/\+([a-f0-9]{$hl})@/i) {
668                          $hash = $1;                          $hash = $1;
669                          last;                          last;
670                  }                  }
671          }          }
672    
673          croak "can't find hash in e-mail $to\n" unless ($hash);          #warn "can't find hash in e-mail $to\n" unless ($hash);
674    
675          my $sent = $self->{'loader'}->find_class('sent');          my $sent = $self->{'loader'}->find_class('sent');
676    
677          # will use null if no matching message_id is found          # will use null if no matching message_id is found
678          my $sent_msg = $sent->search( hash => $hash )->first;          my $sent_msg;
679            $sent_msg = $sent->search( hash => $hash )->first if ($hash);
680    
681          my ($message_id, $user_id) = (undef, undef);    # init with NULL          my ($message_id, $user_id) = (undef, undef);    # init with NULL
682    
683          if ($sent_msg) {          if ($sent_msg) {
684                  $message_id = $sent_msg->message_id || carp "no message_id";                  $message_id = $sent_msg->message_id || carp "no message_id";
685                  $user_id = $sent_msg->user_id || carp "no user_id";                  $user_id = $sent_msg->user_id || carp "no user_id";
686            } else {
687                    #warn "can't find sender with hash $hash\n";
688                    my $users = $self->{'loader'}->find_class('users');
689                    my $from = $m->header('From');
690                    $from = $1 if ($from =~ m/<(.*)>/);
691                    my $this_user = $users->search( email => lc($from) )->first;
692                    $user_id = $this_user->id if ($this_user);
693          }          }
694    
 print "message_id: ",($message_id || "not found"),"\n";  
695    
696          my $is_bounce = 0;          my $is_bounce = 0;
697    
698          my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(          if ($return_path eq '<>' || $return_path eq '') {
699                  $arg->{'message'}, { report_non_bounces=>1 },                  no warnings;
700          ) };                  my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
701          carp "can't check if this message is bounce!" if ($@);                          $arg->{'message'}, { report_non_bounces=>1 },
702                    ) };
703          $is_bounce++ if ($bounce && $bounce->is_bounce);                  #warn "can't check if this message is bounce!" if ($@);
704            
705                    $is_bounce++ if ($bounce && $bounce->is_bounce);
706            }
707    
708          my $received = $self->{'loader'}->find_class('received');          my $received = $self->{'loader'}->find_class('received');
709    
# Line 393  print "message_id: ",($message_id || "no Line 717  print "message_id: ",($message_id || "no
717    
718          $this_received->dbi_commit;          $this_received->dbi_commit;
719    
720          warn "inbox is not yet implemented";  #       print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
721    }
722    
723    =head2 received_messages
724    
725    Returns all received messages for given list or user.
726    
727     my @received = $nos->received_messages(
728            list => 'My list',
729            email => "john.doe@example.com",
730            from_date => '2005-01-01 10:15:00',
731            to_date => '2005-01-01 12:00:00',
732            message => 0,
733     );
734    
735    If don't specify C<list> or C<email> it will return all received messages.
736    Results will be sorted by received date, oldest first.
737    
738    Other optional parametars include:
739    
740    =over 10
741    
742    =item from_date
743    
744    Date (in ISO format) for lower limit of dates received
745    
746    =item to_date
747    
748    Return just messages older than this date
749    
750    =item message
751    
752    Include whole received message in result. This will probably make result
753    array very large. Use with care.
754    
755    =back
756    
757    Date ranges are inclusive, so results will include messages sent on
758    particular date specified with C<date_from> or C<date_to>.
759    
760    Each element in returned array will have following structure:
761    
762     my $row = {
763            id => 42,                       # unique ID of received message
764            list => 'My list',              # useful if filtering by email
765            ext_id => 9999,                 # ext_id from message sender
766            email => 'jdoe@example.com',    # e-mail of message sender
767            bounced => 0,                   # true if message is bounce
768            date => '2005-08-24 18:57:24',  # date of receival in ISO format
769     }
770    
771    If you specified C<message> option, this hash will also have C<message> key
772    which will contain whole received message.
773    
774    =cut
775    
776    sub received_messages {
777            my $self = shift;
778    
779            my $arg = {@_} if (@_);
780    
781    #       croak "need list name or email" unless ($arg->{'list'} || $arg->{'email'});
782    
783            my $sql = qq{
784                            select
785                                    received.id as id,
786                                    lists.name as list,
787                                    users.ext_id as ext_id,
788                                    users.email as email,
789            };
790            $sql .= qq{             message,} if ($arg->{'message'});
791            $sql .= qq{
792                                    bounced,received.date as date
793                            from received
794                            join lists on lists.id = list_id
795                            join users on users.id = user_id
796            };
797    
798            my $order = qq{ order by date asc };
799    
800            my $where;
801    
802            $where->{'lists.name'} = lc($arg->{'list'}) if ($arg->{'list'});
803            $where->{'users.email'} = lc($arg->{'email'}) if ($arg->{'email'});
804            $where->{'received.date'} = { '>=', $arg->{'date_from'} } if ($arg->{'date_from'});
805            $where->{'received.date'} = { '<=', $arg->{'date_to'} } if ($arg->{'date_to'});
806    
807            # hum, yammy one-liner
808            my($stmt, @bind)  = SQL::Abstract->new->where($where);
809    
810            my $dbh = $self->{'loader'}->find_class('received')->db_Main;
811    
812            my $sth = $dbh->prepare($sql . $stmt . $order);
813            $sth->execute(@bind);
814            return $sth->fetchall_hash;
815  }  }
816    
817    
# Line 401  print "message_id: ",($message_id || "no Line 819  print "message_id: ",($message_id || "no
819    
820  Beware of dragons! You shouldn't need to call those methods directly.  Beware of dragons! You shouldn't need to call those methods directly.
821    
822    
823    =head2 _add_aliases
824    
825    Add or update alias in C</etc/aliases> (or equivalent) file for selected list
826    
827     my $ok = $nos->add_aliases(
828            list => 'My list',
829            email => 'my-list@example.com',
830            aliases => '/etc/mail/mylist',
831            archive => '/path/to/mbox/archive',
832    
833     );
834    
835    C<archive> parametar is optional.
836    
837    Return false on failure.
838    
839    =cut
840    
841    sub _add_aliases {
842            my $self = shift;
843    
844            my $arg = {@_};
845    
846            foreach my $o (qw/list email aliases/) {
847                    croak "need $o option" unless ($arg->{$o});
848            }
849    
850            my $aliases = $arg->{'aliases'};
851            my $email = $arg->{'email'};
852            my $list = $arg->{'list'};
853    
854            unless (-e $aliases) {
855                    warn "aliases file $aliases doesn't exist, creating empty\n";
856                    open(my $fh, '>', $aliases) || croak "can't create $aliases: $!";
857                    close($fh);
858                    chmod 0777, $aliases || warn "can't change permission to 0777";
859            }
860    
861            die "FATAL: aliases file $aliases is not writable\n" unless (-w $aliases);
862    
863            my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
864    
865            my $target = '';
866    
867            if (my $archive = $arg->{'archive'}) {
868                    $target .= "$archive, ";
869    
870                    if (! -e $archive) {
871                            warn "please make sure that file $archive is writable for your e-mail user (defaulting to bad 777 permission for now)";
872    
873                            open(my $fh, '>', $archive) || croak "can't create archive file $archive: $!";
874                            close($fh);
875                            chmod 0777, $archive || croak "can't chmod archive file $archive to 0777: $!";
876                    }
877            }
878    
879            # resolve my path to absolute one
880            my $self_path = abs_path($0);
881            $self_path =~ s#/[^/]+$##;
882            $self_path =~ s#/t/*$#/#;
883    
884            $target .= qq#"| cd $self_path && ./sender.pl --inbox='$list'"#;
885    
886            # remove hostname from email to make Postfix's postalias happy
887            $email =~ s/@.+// if (not $self->{full_hostname_in_aliases});
888    
889            if ($a->exists($email)) {
890                    $a->update($email, $target) or croak "can't update alias ".$a->error_check;
891            } else {
892                    $a->append($email, $target) or croak "can't add alias ".$a->error_check;
893            }
894    
895    #       $a->write($aliases) or croak "can't save aliases $aliases ".$a->error_check;
896    
897            return 1;
898    }
899    
900  =head2 _add_list  =head2 _add_list
901    
902  Create new list  Create new list
903    
904   my $list_obj = $nos->_add_list(   my $list_obj = $nos->_add_list(
905          list => 'My list',          list => 'My list',
906            from => 'Outgoing from comment',
907          email => 'my-list@example.com',          email => 'my-list@example.com',
908            aliases => '/etc/mail/mylist',
909   );   );
910    
911  Returns C<Class::DBI> object for created list.  Returns C<Class::DBI> object for created list.
# Line 419  feed correct (and configured) return add Line 917  feed correct (and configured) return add
917    
918  =cut  =cut
919    
920    sub find_or_create {
921            my $self = shift;
922            my $obj = shift;
923            my %args = {@_};
924    
925            my ( $id, $msg ) = $obj->load_by_cols(%args);
926        unless ( $obj->{values}->{id} ) {
927                    warn "find_or_CREATE(",dump( \%args ), ")";
928                    return $obj->create(%args);
929            }
930    
931            warn "FIND_or_create(",dump( \%args ), ") = $id";
932            return $id;
933    }
934    
935    
936  sub _add_list {  sub _add_list {
937          my $self = shift;          my $self = shift;
938    
939          my $arg = {@_};          my $arg = {@_};
940    
941          my $name = $arg->{'list'} || confess "can't add list without name";          my $name = lc($arg->{'list'}) || confess "can't add list without name";
942          my $email = $arg->{'email'} || confess "can't add list without e-mail";          my $email = lc($arg->{'email'}) || confess "can't add list without e-mail";
943            my $aliases = lc($arg->{'aliases'}) || confess "can't add list without path to aliases file";
944    
945          my $lists = $self->{'loader'}->find_class('lists');          my $from_addr = $arg->{'from'};
946    
947            my $lists = Nos::Lists->new( handle => $self->{h} );
948    
949          my $l = $lists->find_or_create({          $self->_add_aliases(
950                    list => $name,
951                    email => $email,
952                    aliases => $aliases,
953            ) || warn "can't add alias $email for list $name";
954    
955            my $l = $self->find_or_create($lists, {
956                  name => $name,                  name => $name,
957                  email => $email,                  email => $email,
958          });          });
959            
960          croak "can't add list $name\n" unless ($l);          croak "can't add list $name\n" unless ($l);
961    
962            if ($from_addr && $l->from_addr ne $from_addr) {
963                    $l->from_addr($from_addr);
964                    $l->update;
965            }
966    
967          $l->dbi_commit;          $l->dbi_commit;
968    
969          return $l;          return $l;
# Line 443  sub _add_list { Line 971  sub _add_list {
971  }  }
972    
973    
974    
975  =head2 _get_list  =head2 _get_list
976    
977  Get list C<Class::DBI> object.  Get list C<Class::DBI> object.
# Line 460  sub _get_list { Line 989  sub _get_list {
989    
990          my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";          my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";
991    
992          return $lists->search({ name => $name })->first;          return $lists->search({ name => lc($name) })->first;
993    }
994    
995    
996    =head2 _remove_alias
997    
998    Remove list alias
999    
1000     my $ok = $nos->_remove_alias(
1001            email => 'mylist@example.com',
1002            aliases => '/etc/mail/mylist',
1003     );
1004    
1005    Returns true if list is removed or false if list doesn't exist. Dies in case of error.
1006    
1007    =cut
1008    
1009    sub _remove_alias {
1010            my $self = shift;
1011    
1012            my $arg = {@_};
1013    
1014            my $email = lc($arg->{'email'}) || confess "can't remove alias without email";
1015            my $aliases = lc($arg->{'aliases'}) || confess "can't remove alias without list";
1016    
1017            my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
1018    
1019            if ($a->exists($email)) {
1020                    $a->delete($email) || croak "can't remove alias $email";
1021            } else {
1022                    return 0;
1023            }
1024    
1025            return 1;
1026    
1027    }
1028    
1029    ###
1030    ### SOAP
1031    ###
1032    
1033    package Nos::SOAP;
1034    
1035    use Carp;
1036    
1037    =head1 SOAP methods
1038    
1039    This methods are thin wrappers to provide SOAP calls. They are grouped in
1040    C<Nos::SOAP> package which is in same F<Nos.pm> module file.
1041    
1042    Usually, you want to use named variables in your SOAP calls if at all
1043    possible.
1044    
1045    However, if you have broken SOAP library (like PHP SOAP class from PEAR)
1046    you will want to use positional arguments (in same order as documented for
1047    methods below).
1048    
1049    =cut
1050    
1051    my $nos;
1052    
1053    
1054    =head2 new
1055    
1056    Create new SOAP object
1057    
1058     my $soap = new Nos::SOAP(
1059            dsn => 'dbi:Pg:dbname=notices',
1060            user => 'dpavlin',
1061            passwd => '',
1062            debug => 1,
1063            verbose => 1,
1064            hash_len => 8,
1065            aliases => '/etc/aliases',
1066     );
1067    
1068    If you are writing SOAP server (like C<soap.cgi> example), you will need to
1069    call this method once to make new instance of Nos::SOAP and specify C<dsn>
1070    and options for it.
1071    
1072    =cut
1073    
1074    sub new {
1075            my $class = shift;
1076            my $self = {@_};
1077    
1078            croak "need aliases parametar" unless ($self->{'aliases'});
1079    
1080            bless($self, $class);
1081    
1082            $nos = new Nos( @_ ) || die "can't create Nos object";
1083    
1084            $self ? return $self : return undef;
1085  }  }
1086    
1087    
1088    =head2 CreateList
1089    
1090     $message_id = CreateList(
1091            list => 'My list',
1092            from => 'Name of my list',
1093            email => 'my-list@example.com'
1094     );
1095    
1096    =cut
1097    
1098    sub CreateList {
1099            my $self = shift;
1100    
1101            my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
1102    
1103            if ($_[0] !~ m/^HASH/) {
1104                    return $nos->create_list(
1105                            list => $_[0], from => $_[1], email => $_[2],
1106                            aliases => $aliases,
1107                    );
1108            } else {
1109                    return $nos->create_list( %{ shift @_ }, aliases => $aliases );
1110            }
1111    }
1112    
1113    
1114    =head2 DropList
1115    
1116     $ok = DropList(
1117            list => 'My list',
1118     );
1119    
1120    =cut
1121    
1122    sub DropList {
1123            my $self = shift;
1124    
1125            my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
1126    
1127            if ($_[0] !~ m/^HASH/) {
1128                    return $nos->drop_list(
1129                            list => $_[0],
1130                            aliases => $aliases,
1131                    );
1132            } else {
1133                    return $nos->drop_list( %{ shift @_ }, aliases => $aliases );
1134            }
1135    }
1136    
1137    =head2 AddMemberToList
1138    
1139     $member_id = AddMemberToList(
1140            list => 'My list',
1141            email => 'e-mail@example.com',
1142            name => 'Full Name',
1143            ext_id => 42,
1144     );
1145    
1146    =cut
1147    
1148    sub AddMemberToList {
1149            my $self = shift;
1150    
1151            if ($_[0] !~ m/^HASH/) {
1152                    return $nos->add_member_to_list(
1153                            list => $_[0], email => $_[1], name => $_[2], ext_id => $_[3],
1154                    );
1155            } else {
1156                    return $nos->add_member_to_list( %{ shift @_ } );
1157            }
1158    }
1159    
1160    
1161    =head2 ListMembers
1162    
1163     my @members = ListMembers(
1164            list => 'My list',
1165     );
1166    
1167    Returns array of hashes with user informations, see C<list_members>.
1168    
1169    =cut
1170    
1171    sub ListMembers {
1172            my $self = shift;
1173    
1174            my $list_name;
1175    
1176            if ($_[0] !~ m/^HASH/) {
1177                    $list_name = shift;
1178            } else {
1179                    $list_name = $_[0]->{'list'};
1180            }
1181    
1182            return [ $nos->list_members( list => $list_name ) ];
1183    }
1184    
1185    
1186    =head2 DeleteMemberFromList
1187    
1188     $member_id = DeleteMemberFromList(
1189            list => 'My list',
1190            email => 'e-mail@example.com',
1191     );
1192    
1193    =cut
1194    
1195    sub DeleteMemberFromList {
1196            my $self = shift;
1197    
1198            if ($_[0] !~ m/^HASH/) {
1199                    return $nos->delete_member_from_list(
1200                            list => $_[0], email => $_[1],
1201                    );
1202            } else {
1203                    return $nos->delete_member_from_list( %{ shift @_ } );
1204            }
1205    }
1206    
1207    
1208    =head2 AddMessageToList
1209    
1210     $message_id = AddMessageToList(
1211            list => 'My list',
1212            message => 'From: My list...'
1213     );
1214    
1215    =cut
1216    
1217    sub AddMessageToList {
1218            my $self = shift;
1219    
1220            if ($_[0] !~ m/^HASH/) {
1221                    return $nos->add_message_to_list(
1222                            list => $_[0], message => $_[1],
1223                    );
1224            } else {
1225                    return $nos->add_message_to_list( %{ shift @_ } );
1226            }
1227    }
1228    
1229    =head2 MessagesReceived
1230    
1231    Return statistics about received messages.
1232    
1233     my @result = MessagesReceived(
1234            list => 'My list',
1235            email => 'jdoe@example.com',
1236            from_date => '2005-01-01 10:15:00',
1237            to_date => '2005-01-01 12:00:00',
1238            message => 0,
1239     );
1240    
1241    You must specify C<list> or C<email> or any combination of those two. Other
1242    parametars are optional.
1243    
1244    For format of returned array element see C<received_messages>.
1245    
1246    =cut
1247    
1248    sub MessagesReceived {
1249            my $self = shift;
1250    
1251            if ($_[0] !~ m/^HASH/) {
1252                    die "need at least list or email" unless (scalar @_ < 2);
1253                    return \@{ $nos->received_messages(
1254                            list => $_[0], email => $_[1],
1255                            from_date => $_[2], to_date => $_[3],
1256                            message => $_[4]
1257                    ) };
1258            } else {
1259                    my $arg = shift;
1260                    die "need list or email argument" unless ($arg->{'list'} || $arg->{'email'});
1261                    return \@{ $nos->received_messages( %{ $arg } ) };
1262            }
1263    }
1264    
1265    ###
1266    
1267    =head1 NOTE ON ARRAYS IN SOAP
1268    
1269    Returning arrays from SOAP calls is somewhat fuzzy (at least to me). It
1270    seems that SOAP::Lite client thinks that it has array with one element which
1271    is array of hashes with data.
1272    
1273    =head1 PRIVATE METHODS
1274    
1275    Documented here because tests use them
1276    
1277    =head2 _nos_object
1278    
1279      my $nos = $nos->_nos_object;
1280    
1281    =cut
1282    
1283    sub _nos_object {
1284            return $nos;
1285    }
1286    
1287  =head1 EXPORT  =head1 EXPORT
1288    
1289  Nothing.  Nothing.
# Line 488  at your option, any later version of Per Line 1308  at your option, any later version of Per
1308    
1309    
1310  =cut  =cut
1311    
1312    1;
Legend:
Removed from v.38  
changed lines
  Added in v.92
  ViewVC Help
Powered by ViewVC 1.1.26