/[notice-sender]/trunk/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 /trunk/Nos.pm

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

revision 47 by dpavlin, Tue May 24 14:02:05 2005 UTC revision 80 by dpavlin, Fri Aug 26 05:38:00 2005 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.4';  our $VERSION = '0.8';
20    
21  use Class::DBI::Loader;  use Class::DBI::Loader;
22  use Email::Valid;  use Email::Valid;
# Line 26  use Email::Auth::AddressHash; Line 26  use Email::Auth::AddressHash;
26  use Email::Simple;  use Email::Simple;
27  use Email::Address;  use Email::Address;
28  use Mail::DeliveryStatus::BounceParser;  use Mail::DeliveryStatus::BounceParser;
29  use Data::Dumper;  use Class::DBI::AbstractSearch;
30    use SQL::Abstract;
31  my $email_send_driver = 'Email::Send::IO';  use Mail::Alias;
32  my @email_send_options;  use Cwd qw(abs_path);
   
 #$email_send_driver = 'Sendmail';  
33    
34    
35  =head1 NAME  =head1 NAME
# Line 45  Nos - Notice Sender core module Line 43  Nos - Notice Sender core module
43    
44  =head1 DESCRIPTION  =head1 DESCRIPTION
45    
46  Core module for notice sender's functionality.  Notice sender is mail handler. It is not MTA, since it doesn't know how to
47    receive e-mails or send them directly to other hosts. It is not mail list
48    manager because it requires programming to add list members and send
49    messages. You can think of it as mechanisam for off-loading your e-mail
50    sending to remote server using SOAP service.
51    
52    It's concept is based around B<lists>. Each list can have zero or more
53    B<members>. Each list can have zero or more B<messages>.
54    
55    Here comes a twist: each outgoing message will have unique e-mail generated,
56    so Notice Sender will be able to link received replies (or bounces) with
57    outgoing messages.
58    
59    It doesn't do much more than that. It B<can't> create MIME encoded e-mail,
60    send attachments, handle 8-bit characters in headers (which have to be
61    encoded) or anything else.
62    
63    It will just queue your e-mail message to particular list (sending it to
64    possibly remote Notice Sender SOAP server just once), send it out at
65    reasonable rate (so that it doesn't flood your e-mail infrastructure) and
66    keep track replies.
67    
68    It is best used to send small number of messages to more-or-less fixed
69    list of recipients while allowing individual responses to be examined.
70    Tipical use include replacing php e-mail sending code with SOAP call to
71    Notice Sender. It does support additional C<ext_id> field for each member
72    which can be used to track some unique identifier from remote system for
73    particular user.
74    
75    It comes with command-line utility C<sender.pl> which can be used to perform
76    all available operation from scripts (see C<sender.pl --man>).
77    This command is also useful for debugging while writing client SOAP
78    application.
79    
80  =head1 METHODS  =head1 METHODS
81    
# Line 80  sub new { Line 110  sub new {
110                  user            => $self->{'user'},                  user            => $self->{'user'},
111                  password        => $self->{'passwd'},                  password        => $self->{'passwd'},
112                  namespace       => "Nos",                  namespace       => "Nos",
113  #               additional_classes      => qw/Class::DBI::AbstractSearch/,                  additional_classes      => qw/Class::DBI::AbstractSearch/,
114  #               additional_base_classes => qw/My::Stuff/,  #               additional_base_classes => qw/My::Stuff/,
115                  relationships   => 1,                  relationships   => 1,
116          ) || croak "can't init Class::DBI::Loader";          ) || croak "can't init Class::DBI::Loader";
# Line 91  sub new { Line 121  sub new {
121  }  }
122    
123    
124  =head2 new_list  =head2 create_list
125    
126  Create new list. Required arguments are name of C<list> and  Create new list. Required arguments are name of C<list>, C<email> address
127  C<email> address.  and path to C<aliases> file.
128    
129   $nos->new_list(   $nos->create_list(
130          list => 'My list',          list => 'My list',
131          from => 'Outgoing from comment',          from => 'Outgoing from comment',
132          email => 'my-list@example.com',          email => 'my-list@example.com',
133            aliases => '/etc/mail/mylist',
134            archive => '/path/to/mbox/archive',
135   );   );
136    
137  Returns ID of newly created list.  Returns ID of newly created list.
138    
139  Calls internally L<_add_list>, see details there.  Calls internally C<_add_list>, see details there.
140    
141  =cut  =cut
142    
143  sub new_list {  sub create_list {
144          my $self = shift;          my $self = shift;
145    
146          my $arg = {@_};          my $arg = {@_};
147    
148          confess "need list name" unless ($arg->{'list'});          confess "need list name" unless ($arg->{'list'});
149          confess "need list email" unless ($arg->{'list'});          confess "need list email" unless ($arg->{'email'});
150    
151            $arg->{'list'} = lc($arg->{'list'});
152            $arg->{'email'} = lc($arg->{'email'});
153    
154          my $l = $self->_get_list($arg->{'list'}) ||          my $l = $self->_get_list($arg->{'list'}) ||
155                  $self->_add_list( @_ ) ||                  $self->_add_list( @_ ) ||
# Line 124  sub new_list { Line 159  sub new_list {
159  }  }
160    
161    
162    =head2 drop_list
163    
164    Delete list from database.
165    
166     my $ok = drop_list(
167            list => 'My list'
168            aliases => '/etc/mail/mylist',
169     );
170    
171    Returns false if list doesn't exist.
172    
173    =cut
174    
175    sub drop_list {
176            my $self = shift;
177    
178            my $args = {@_};
179    
180            croak "need list to delete" unless ($args->{'list'});
181    
182            $args->{'list'} = lc($args->{'list'});
183    
184            my $aliases = $args->{'aliases'} || croak "need path to aliases file";
185    
186            my $lists = $self->{'loader'}->find_class('lists');
187    
188            my $this_list = $lists->search( name => $args->{'list'} )->first || return;
189    
190            $self->_remove_alias( email => $this_list->email, aliases => $aliases);
191    
192            $this_list->delete || croak "can't delete list\n";
193    
194            return $lists->dbi_commit || croak "can't commit";
195    }
196    
197    
198  =head2 add_member_to_list  =head2 add_member_to_list
199    
200  Add new member to list  Add new member to list
# Line 132  Add new member to list Line 203  Add new member to list
203          list => "My list",          list => "My list",
204          email => "john.doe@example.com",          email => "john.doe@example.com",
205          name => "John A. Doe",          name => "John A. Doe",
206            ext_id => 42,
207   );   );
208    
209  C<name> parametar is optional.  C<name> and C<ext_id> parametars are optional.
210    
211  Return member ID if user is added.  Return member ID if user is added.
212    
# Line 145  sub add_member_to_list { Line 217  sub add_member_to_list {
217    
218          my $arg = {@_};          my $arg = {@_};
219    
220          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";
221          my $name = $arg->{'name'} || '';          my $name = $arg->{'name'} || '';
222          my $list_name = $arg->{'list'} || croak "need list name";          my $list_name = lc($arg->{'list'}) || croak "need list name";
223            my $ext_id = $arg->{'ext_id'};
224    
225          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";
226    
# Line 170  sub add_member_to_list { Line 243  sub add_member_to_list {
243                  $this_user->update;                  $this_user->update;
244          }          }
245    
246            if (defined($ext_id) && ($this_user->ext_id || '') ne $ext_id) {
247                    $this_user->ext_id($ext_id);
248                    $this_user->update;
249            }
250    
251          my $user_on_list = $user_list->find_or_create({          my $user_on_list = $user_list->find_or_create({
252                  user_id => $this_user->id,                  user_id => $this_user->id,
253                  list_id => $list->id,                  list_id => $list->id,
# Line 190  List all members of some list. Line 268  List all members of some list.
268          list => 'My list',          list => 'My list',
269   );   );
270    
271  Returns array of hashes with user informations like this:  Returns array of hashes with user information like this:
272    
273   $member = {   $member = {
274          name => 'Dobrica Pavlinusic',          name => 'Dobrica Pavlinusic',
275          email => 'dpavlin@rot13.org          email => 'dpavlin@rot13.org
276   }   }
277    
278  If list is not found, returns false.  If list is not found, returns false. If there is C<ext_id> in user data,
279    it will also be returned.
280    
281  =cut  =cut
282    
# Line 206  sub list_members { Line 285  sub list_members {
285    
286          my $args = {@_};          my $args = {@_};
287    
288          my $list_name = $args->{'list'} || confess "need list name";          my $list_name = lc($args->{'list'}) || confess "need list name";
289    
290          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
291          my $user_list = $self->{'loader'}->find_class('user_list');          my $user_list = $self->{'loader'}->find_class('user_list');
# Line 221  sub list_members { Line 300  sub list_members {
300                          email => $user_on_list->user_id->email,                          email => $user_on_list->user_id->email,
301                  };                  };
302    
303                    my $ext_id = $user_on_list->user_id->ext_id;
304                    $row->{'ext_id'} = $ext_id if (defined($ext_id));
305    
306                  push @results, $row;                  push @results, $row;
307          }          }
308    
# Line 243  Delete member from database. Line 325  Delete member from database.
325    
326  Returns false if user doesn't exist.  Returns false if user doesn't exist.
327    
328    This function will delete member from all lists (by cascading delete), so it
329    shouldn't be used lightly.
330    
331  =cut  =cut
332    
333  sub delete_member {  sub delete_member {
# Line 252  sub delete_member { Line 337  sub delete_member {
337    
338          croak "need name or email of user to delete" unless ($args->{'name'} || $args->{'email'});          croak "need name or email of user to delete" unless ($args->{'name'} || $args->{'email'});
339    
340            $args->{'email'} = lc($args->{'email'}) if ($args->{'email'});
341    
342          my $key = 'name';          my $key = 'name';
343          $key = 'email' if ($args->{'email'});          $key = 'email' if ($args->{'email'});
344    
# Line 259  sub delete_member { Line 346  sub delete_member {
346    
347          my $this_user = $users->search( $key => $args->{$key} )->first || return;          my $this_user = $users->search( $key => $args->{$key} )->first || return;
348    
 print Dumper($this_user);  
   
349          $this_user->delete || croak "can't delete user\n";          $this_user->delete || croak "can't delete user\n";
350    
351          return $users->dbi_commit || croak "can't commit";          return $users->dbi_commit || croak "can't commit";
352  }  }
353    
354    =head2 delete_member_from_list
355    
356    Delete member from particular list.
357    
358     my $ok = delete_member_from_list(
359            list => 'My list',
360            email => 'dpavlin@rot13.org',
361     );
362    
363    Returns false if user doesn't exist on that particular list.
364    
365    It will die if list or user doesn't exist. You have been warned (you might
366    want to eval this functon to prevent it from croaking).
367    
368    =cut
369    
370    sub delete_member_from_list {
371            my $self = shift;
372    
373            my $args = {@_};
374    
375            croak "need list name and email of user to delete" unless ($args->{'list'} && $args->{'email'});
376    
377            $args->{'list'} = lc($args->{'list'});
378            $args->{'email'} = lc($args->{'email'});
379    
380            my $user = $self->{'loader'}->find_class('users');
381            my $list = $self->{'loader'}->find_class('lists');
382            my $user_list = $self->{'loader'}->find_class('user_list');
383    
384            my $this_user = $user->search( email => $args->{'email'} )->first || croak "can't find user: ".$args->{'email'};
385            my $this_list = $list->search( name => $args->{'list'} )->first || croak "can't find list: ".$args->{'list'};
386    
387            my $this_user_list = $user_list->search_where( list_id => $this_list->id, user_id => $this_user->id )->first || return;
388    
389            $this_user_list->delete || croak "can't delete user from list\n";
390    
391            return $user_list->dbi_commit || croak "can't commit";
392    }
393    
394  =head2 add_message_to_list  =head2 add_message_to_list
395    
396  Adds message to one list's queue for later sending.  Adds message to one list's queue for later sending.
# Line 291  sub add_message_to_list { Line 416  sub add_message_to_list {
416    
417          my $args = {@_};          my $args = {@_};
418    
419          my $list_name = $args->{'list'} || confess "need list name";          my $list_name = lc($args->{'list'}) || confess "need list name";
420          my $message_text = $args->{'message'} || croak "need message";          my $message_text = $args->{'message'} || croak "need message";
421    
422          my $m = Email::Simple->new($message_text) || croak "can't parse message";          my $m = Email::Simple->new($message_text) || croak "can't parse message";
# Line 332  sub add_message_to_list { Line 457  sub add_message_to_list {
457    
458  Send queued messages or just ones for selected list  Send queued messages or just ones for selected list
459    
460   $nos->send_queued_messages("My list",'smtp');   $nos->send_queued_messages(
461            list => 'My list',
462            driver => 'smtp',
463            sleep => 3,
464     );
465    
466  Second option is driver which will be used for e-mail delivery. If not  Second option is driver which will be used for e-mail delivery. If not
467  specified, C<IO> driver will be used which will dump e-mail to C<STDERR>.  specified, C<IO> driver will be used which will dump e-mail to C<STDERR>.
# Line 347  Send e-mail using SMTP server at 127.0.0 Line 476  Send e-mail using SMTP server at 127.0.0
476    
477  =back  =back
478    
479    Any other driver name will try to use C<Email::Send::that_driver> module.
480    
481    Default sleep wait between two messages is 3 seconds.
482    
483    This method will return number of succesfully sent messages.
484    
485  =cut  =cut
486    
487  sub send_queued_messages {  sub send_queued_messages {
488          my $self = shift;          my $self = shift;
489    
490          my $list_name = shift;          my $arg = {@_};
491    
492            my $list_name = lc($arg->{'list'}) || '';
493            my $driver = $arg->{'driver'} || '';
494            my $sleep = $arg->{'sleep'};
495            $sleep ||= 3 unless defined($sleep);
496    
497            # number of messages sent o.k.
498            my $ok = 0;
499    
500          my $driver = shift || '';          my $email_send_driver = 'Email::Send::IO';
501            my @email_send_options;
502    
503          if (lc($driver) eq 'smtp') {          if (lc($driver) eq 'smtp') {
504                  $email_send_driver = 'Email::Send::SMTP';                  $email_send_driver = 'Email::Send::SMTP';
505                  @email_send_options = ['127.0.0.1'];                  @email_send_options = ['127.0.0.1'];
506            } elsif ($driver && $driver ne '') {
507                    $email_send_driver = 'Email::Send::' . $driver;
508            } else {
509                    warn "dumping all messages to STDERR\n";
510          }          }
         warn "using $driver [$email_send_driver]\n";  
511    
512          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
513          my $queue = $self->{'loader'}->find_class('queue');          my $queue = $self->{'loader'}->find_class('queue');
# Line 392  sub send_queued_messages { Line 539  sub send_queued_messages {
539                          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 )) {
540                                  print "SKIP $to_email message allready sent\n";                                  print "SKIP $to_email message allready sent\n";
541                          } else {                          } else {
542                                  print "=> $to_email\n";                                  print "=> $to_email ";
543    
544                                  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;
545                                  my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );                                  my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
# Line 401  sub send_queued_messages { Line 548  sub send_queued_messages {
548    
549                                  my $from_addr;                                  my $from_addr;
550                                  my $from_email_only = $from . "+" . $hash . ( $domain ? '@' . $domain : '');                                  my $from_email_only = $from . "+" . $hash . ( $domain ? '@' . $domain : '');
551    
552                                  $from_addr .= '"' . $u->list_id->from_addr . '" ' if ($u->list_id->from_addr);                                  $from_addr .= '"' . $u->list_id->from_addr . '" ' if ($u->list_id->from_addr);
553                                  $from_addr .= '<' . $from_email_only . '>';                                  $from_addr .= '<' . $from_email_only . '>';
554                                  my $to = '"' . $u->user_id->name . '" <' . $to_email . '>';                                  my $to = '"' . $u->user_id->name . '" <' . $to_email . '>';
# Line 408  sub send_queued_messages { Line 556  sub send_queued_messages {
556                                  my $m_obj = Email::Simple->new($msg) || croak "can't parse message";                                  my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
557    
558                                  $m_obj->header_set('Return-Path', $from_email_only) || croak "can't set Return-Path: header";                                  $m_obj->header_set('Return-Path', $from_email_only) || croak "can't set Return-Path: header";
559                                  $m_obj->header_set('Sender', $from_email_only) || croak "can't set Return-Path: header";                                  $m_obj->header_set('Sender', $from_email_only) || croak "can't set Sender: header";
560                                  $m_obj->header_set('Errors-To', $from_email_only) || croak "can't set Return-Path: header";                                  $m_obj->header_set('Errors-To', $from_email_only) || croak "can't set Errors-To: header";
561                                  $m_obj->header_set('From', $from_addr) || croak "can't set From: header";                                  $m_obj->header_set('From', $from_addr) || croak "can't set From: header";
562                                  $m_obj->header_set('To', $to) || croak "can't set To: header";                                  $m_obj->header_set('To', $to) || croak "can't set To: header";
563    
# Line 417  sub send_queued_messages { Line 565  sub send_queued_messages {
565                                  $m_obj->header_set('X-Nos-Hash', $hash);                                  $m_obj->header_set('X-Nos-Hash', $hash);
566    
567                                  # really send e-mail                                  # really send e-mail
568                                    my $sent_status;
569    
570                                  if (@email_send_options) {                                  if (@email_send_options) {
571                                          send $email_send_driver => $m_obj->as_string, @email_send_options;                                          $sent_status = send $email_send_driver => $m_obj->as_string, @email_send_options;
572                                    } else {
573                                            $sent_status = send $email_send_driver => $m_obj->as_string;
574                                    }
575    
576                                    croak "can't send e-mail: $sent_status\n\nOriginal e-mail follows:\n".$m_obj->as_string unless ($sent_status);
577                                    my @bad;
578                                    @bad = @{ $sent_status->prop('bad') } if (eval { $sent_status->can('prop') });
579                                    croak "failed sending to ",join(",",@bad) if (@bad);
580    
581                                    if ($sent_status) {
582    
583                                            $sent->create({
584                                                    message_id => $m->message_id,
585                                                    user_id => $u->user_id,
586                                                    hash => $hash,
587                                            });
588                                            $sent->dbi_commit;
589    
590                                            print " - $sent_status\n";
591    
592                                            $ok++;
593                                  } else {                                  } else {
594                                          send $email_send_driver => $m_obj->as_string;                                          warn "ERROR: $sent_status\n";
595                                  }                                  }
596    
597                                  $sent->create({                                  if ($sleep) {
598                                          message_id => $m->message_id,                                          warn "sleeping $sleep seconds\n";
599                                          user_id => $u->user_id,                                          sleep($sleep);
600                                          hash => $hash,                                  }
                                 });  
                                 $sent->dbi_commit;  
601                          }                          }
602                  }                  }
603                  $m->all_sent(1);                  $m->all_sent(1);
# Line 436  sub send_queued_messages { Line 605  sub send_queued_messages {
605                  $m->dbi_commit;                  $m->dbi_commit;
606          }          }
607    
608            return $ok;
609    
610  }  }
611    
612  =head2 inbox_message  =head2 inbox_message
# Line 447  Receive single message for list's inbox. Line 618  Receive single message for list's inbox.
618          message => $message,          message => $message,
619   );   );
620    
621    This method is used by C<sender.pl> when receiving e-mail messages.
622    
623  =cut  =cut
624    
625  sub inbox_message {  sub inbox_message {
# Line 457  sub inbox_message { Line 630  sub inbox_message {
630          return unless ($arg->{'message'});          return unless ($arg->{'message'});
631          croak "need list name" unless ($arg->{'list'});          croak "need list name" unless ($arg->{'list'});
632    
633            $arg->{'list'} = lc($arg->{'list'});
634    
635          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";
636    
637          my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message";          my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message";
638    
639          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";
640    
641            my $return_path = $m->header('Return-Path') || '';
642    
643          my @addrs = Email::Address->parse( $to );          my @addrs = Email::Address->parse( $to );
644    
645          die "can't parse To: $to address\n" unless (@addrs);          die "can't parse To: $to address\n" unless (@addrs);
# Line 472  sub inbox_message { Line 649  sub inbox_message {
649          my $hash;          my $hash;
650    
651          foreach my $a (@addrs) {          foreach my $a (@addrs) {
652                  if ($a->address =~ m/\+([a-f0-9]{$hl})@/) {                  if ($a->address =~ m/\+([a-f0-9]{$hl})@/i) {
653                          $hash = $1;                          $hash = $1;
654                          last;                          last;
655                  }                  }
656          }          }
657    
658          croak "can't find hash in e-mail $to\n" unless ($hash);          #warn "can't find hash in e-mail $to\n" unless ($hash);
659    
660          my $sent = $self->{'loader'}->find_class('sent');          my $sent = $self->{'loader'}->find_class('sent');
661    
662          # will use null if no matching message_id is found          # will use null if no matching message_id is found
663          my $sent_msg = $sent->search( hash => $hash )->first;          my $sent_msg;
664            $sent_msg = $sent->search( hash => $hash )->first if ($hash);
665    
666          my ($message_id, $user_id) = (undef, undef);    # init with NULL          my ($message_id, $user_id) = (undef, undef);    # init with NULL
667    
# Line 491  sub inbox_message { Line 669  sub inbox_message {
669                  $message_id = $sent_msg->message_id || carp "no message_id";                  $message_id = $sent_msg->message_id || carp "no message_id";
670                  $user_id = $sent_msg->user_id || carp "no user_id";                  $user_id = $sent_msg->user_id || carp "no user_id";
671          } else {          } else {
672                  warn "can't find sender with hash $hash\n";                  #warn "can't find sender with hash $hash\n";
673                    my $users = $self->{'loader'}->find_class('users');
674                    my $from = $m->header('From');
675                    $from = $1 if ($from =~ m/<(.*)>/);
676                    my $this_user = $users->search( email => lc($from) )->first;
677                    $user_id = $this_user->id if ($this_user);
678          }          }
679    
680    
681          my $is_bounce = 0;          my $is_bounce = 0;
682    
683          {          if ($return_path eq '<>' || $return_path eq '') {
684                  no warnings;                  no warnings;
685                  my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(                  my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
686                          $arg->{'message'}, { report_non_bounces=>1 },                          $arg->{'message'}, { report_non_bounces=>1 },
687                  ) };                  ) };
688                  carp "can't check if this message is bounce!" if ($@);                  #warn "can't check if this message is bounce!" if ($@);
689                    
690                  $is_bounce++ if ($bounce && $bounce->is_bounce);                  $is_bounce++ if ($bounce && $bounce->is_bounce);
691          }          }
# Line 519  sub inbox_message { Line 702  sub inbox_message {
702    
703          $this_received->dbi_commit;          $this_received->dbi_commit;
704    
705          print "message_id: ",($message_id || "not found")," -- $is_bounce\n";  #       print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
706    }
707    
708    =head2 received_messages
709    
710    Returns all received messages for given list or user.
711    
712     my @received = $nos->received_messages(
713            list => 'My list',
714            email => "john.doe@example.com",
715            from_date => '2005-01-01 10:15:00',
716            to_date => '2005-01-01 12:00:00',
717            message => 0,
718     );
719    
720    If don't specify C<list> or C<email> it will return all received messages.
721    Results will be sorted by received date, oldest first.
722    
723    Other optional parametars include:
724    
725    =over 10
726    
727    =item from_date
728    
729    Date (in ISO format) for lower limit of dates received
730    
731    =item to_date
732    
733    Return just messages older than this date
734    
735    =item message
736    
737    Include whole received message in result. This will probably make result
738    array very large. Use with care.
739    
740    =back
741    
742          warn "inbox is not yet implemented";  Each element in returned array will have following structure:
743    
744     my $row = {
745            id => 42,                       # unique ID of received message
746            list => 'My list',              # useful if filtering by email
747            ext_id => 9999,                 # ext_id from message sender
748            email => 'jdoe@example.com',    # e-mail of message sender
749            bounced => 0,                   # true if message is bounce
750            date => '2005-08-24 18:57:24',  # date of receival in ISO format
751     }
752    
753    If you specified C<message> option, this hash will also have C<message> key
754    which will contain whole received message.
755    
756    =cut
757    
758    sub received_messages {
759            my $self = shift;
760    
761            my $arg = {@_} if (@_);
762    
763    #       croak "need list name or email" unless ($arg->{'list'} || $arg->{'email'});
764    
765            my $sql = qq{
766                            select
767                                    received.id as id,
768                                    lists.name as list,
769                                    users.ext_id as ext_id,
770                                    users.email as email,
771            };
772            $sql .= qq{             message,} if ($arg->{'message'});
773            $sql .= qq{
774                                    bounced,received.date as date
775                            from received
776                            join lists on lists.id = list_id
777                            join users on users.id = user_id
778            };
779    
780            my $order = qq{ order by date desc };
781    
782            my $where;
783    
784            $where->{'lists.name'} = lc($arg->{'list'}) if ($arg->{'list'});
785            $where->{'users.email'} = lc($arg->{'email'}) if ($arg->{'email'});
786            $where->{'received.date'} = { '>=', $arg->{'date_from'} } if ($arg->{'date_from'});
787            $where->{'received.date'} = { '<=', $arg->{'date_to'} } if ($arg->{'date_to'});
788    
789            # hum, yammy one-liner
790            my($stmt, @bind)  = SQL::Abstract->new->where($where);
791    
792            my $dbh = $self->{'loader'}->find_class('received')->db_Main;
793    
794            my $sth = $dbh->prepare($sql . $stmt . $order);
795            $sth->execute(@bind);
796            return $sth->fetchall_hash;
797  }  }
798    
799    
# Line 530  sub inbox_message { Line 801  sub inbox_message {
801    
802  Beware of dragons! You shouldn't need to call those methods directly.  Beware of dragons! You shouldn't need to call those methods directly.
803    
804    
805    =head2 _add_aliases
806    
807    Add or update alias in C</etc/aliases> (or equivalent) file for selected list
808    
809     my $ok = $nos->add_aliases(
810            list => 'My list',
811            email => 'my-list@example.com',
812            aliases => '/etc/mail/mylist',
813            archive => '/path/to/mbox/archive',
814    
815     );
816    
817    C<archive> parametar is optional.
818    
819    Return false on failure.
820    
821    =cut
822    
823    sub _add_aliases {
824            my $self = shift;
825    
826            my $arg = {@_};
827    
828            foreach my $o (qw/list email aliases/) {
829                    croak "need $o option" unless ($arg->{$o});
830            }
831    
832            my $aliases = $arg->{'aliases'};
833            my $email = $arg->{'email'};
834            my $list = $arg->{'list'};
835    
836            unless (-e $aliases) {
837                    warn "aliases file $aliases doesn't exist, creating empty\n";
838                    open(my $fh, '>', $aliases) || croak "can't create $aliases: $!";
839                    close($fh);
840                    chmod 0777, $aliases || warn "can't change permission to 0777";
841            }
842    
843            die "FATAL: aliases file $aliases is not writable\n" unless (-w $aliases);
844    
845            my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
846    
847            my $target = '';
848    
849            if (my $archive = $arg->{'archive'}) {
850                    $target .= "$archive, ";
851    
852                    if (! -e $archive) {
853                            warn "please make sure that file $archive is writable for your e-mail user (defaulting to bad 777 permission for now)";
854    
855                            open(my $fh, '>', $archive) || croak "can't create archive file $archive: $!";
856                            close($fh);
857                            chmod 0777, $archive || croak "can't chmod archive file $archive to 0777: $!";
858                    }
859            }
860    
861            # resolve my path to absolute one
862            my $self_path = abs_path($0);
863            $self_path =~ s#/[^/]+$##;
864            $self_path =~ s#/t/*$#/#;
865    
866            $target .= qq#| cd $self_path && ./sender.pl --inbox="$list"#;
867    
868            if ($a->exists($email)) {
869                    $a->update($email, $target) or croak "can't update alias ".$a->error_check;
870            } else {
871                    $a->append($email, $target) or croak "can't add alias ".$a->error_check;
872            }
873    
874            #$a->write($aliases) or croak "can't save aliases $aliases ".$a->error_check;
875    
876            return 1;
877    }
878    
879  =head2 _add_list  =head2 _add_list
880    
881  Create new list  Create new list
# Line 538  Create new list Line 884  Create new list
884          list => 'My list',          list => 'My list',
885          from => 'Outgoing from comment',          from => 'Outgoing from comment',
886          email => 'my-list@example.com',          email => 'my-list@example.com',
887            aliases => '/etc/mail/mylist',
888   );   );
889    
890  Returns C<Class::DBI> object for created list.  Returns C<Class::DBI> object for created list.
# Line 554  sub _add_list { Line 901  sub _add_list {
901    
902          my $arg = {@_};          my $arg = {@_};
903    
904          my $name = $arg->{'list'} || confess "can't add list without name";          my $name = lc($arg->{'list'}) || confess "can't add list without name";
905          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";
906            my $aliases = lc($arg->{'aliases'}) || confess "can't add list without path to aliases file";
907    
908          my $from_addr = $arg->{'from'};          my $from_addr = $arg->{'from'};
909    
910          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
911    
912            $self->_add_aliases(
913                    list => $name,
914                    email => $email,
915                    aliases => $aliases,
916            ) || warn "can't add alias $email for list $name";
917    
918          my $l = $lists->find_or_create({          my $l = $lists->find_or_create({
919                  name => $name,                  name => $name,
920                  email => $email,                  email => $email,
# Line 579  sub _add_list { Line 934  sub _add_list {
934  }  }
935    
936    
937    
938  =head2 _get_list  =head2 _get_list
939    
940  Get list C<Class::DBI> object.  Get list C<Class::DBI> object.
# Line 596  sub _get_list { Line 952  sub _get_list {
952    
953          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";
954    
955          return $lists->search({ name => $name })->first;          return $lists->search({ name => lc($name) })->first;
956    }
957    
958    
959    =head2 _remove_alias
960    
961    Remove list alias
962    
963     my $ok = $nos->_remove_alias(
964            email => 'mylist@example.com',
965            aliases => '/etc/mail/mylist',
966     );
967    
968    Returns true if list is removed or false if list doesn't exist. Dies in case of error.
969    
970    =cut
971    
972    sub _remove_alias {
973            my $self = shift;
974    
975            my $arg = {@_};
976    
977            my $email = lc($arg->{'email'}) || confess "can't remove alias without email";
978            my $aliases = lc($arg->{'aliases'}) || confess "can't remove alias without list";
979    
980            my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
981    
982            if ($a->exists($email)) {
983                    $a->delete($email) || croak "can't remove alias $email";
984            } else {
985                    return 0;
986            }
987    
988            return 1;
989    
990  }  }
991    
992  ###  ###
# Line 623  methods below). Line 1013  methods below).
1013    
1014  my $nos;  my $nos;
1015    
1016    
1017    =head2 new
1018    
1019    Create new SOAP object
1020    
1021     my $soap = new Nos::SOAP(
1022            dsn => 'dbi:Pg:dbname=notices',
1023            user => 'dpavlin',
1024            passwd => '',
1025            debug => 1,
1026            verbose => 1,
1027            hash_len => 8,
1028            aliases => '/etc/aliases',
1029     );
1030    
1031    If you are writing SOAP server (like C<soap.cgi> example), you will need to
1032    call this method once to make new instance of Nos::SOAP and specify C<dsn>
1033    and options for it.
1034    
1035    =cut
1036    
1037  sub new {  sub new {
1038          my $class = shift;          my $class = shift;
1039          my $self = {@_};          my $self = {@_};
1040    
1041            croak "need aliases parametar" unless ($self->{'aliases'});
1042    
1043          bless($self, $class);          bless($self, $class);
1044    
1045          $nos = new Nos( @_ ) || die "can't create Nos object";          $nos = new Nos( @_ ) || die "can't create Nos object";
# Line 634  sub new { Line 1048  sub new {
1048  }  }
1049    
1050    
1051  =head2 NewList  =head2 CreateList
1052    
1053   $message_id = NewList(   $message_id = CreateList(
1054          list => 'My list',          list => 'My list',
1055            from => 'Name of my list',
1056          email => 'my-list@example.com'          email => 'my-list@example.com'
1057   );   );
1058    
1059  =cut  =cut
1060    
1061  sub NewList {  sub CreateList {
1062          my $self = shift;          my $self = shift;
1063    
1064            my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
1065    
1066          if ($_[0] !~ m/^HASH/) {          if ($_[0] !~ m/^HASH/) {
1067                  return $nos->new_list(                  return $nos->create_list(
1068                          list => $_[0], email => $_[1],                          list => $_[0], from => $_[1], email => $_[2],
1069                            aliases => $aliases,
1070                  );                  );
1071          } else {          } else {
1072                  return $nos->new_list( %{ shift @_ } );                  return $nos->create_list( %{ shift @_ }, aliases => $aliases );
1073          }          }
1074  }  }
1075    
1076    
1077    =head2 DropList
1078    
1079     $ok = DropList(
1080            list => 'My list',
1081     );
1082    
1083    =cut
1084    
1085    sub DropList {
1086            my $self = shift;
1087    
1088            my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
1089    
1090            if ($_[0] !~ m/^HASH/) {
1091                    return $nos->drop_list(
1092                            list => $_[0],
1093                            aliases => $aliases,
1094                    );
1095            } else {
1096                    return $nos->drop_list( %{ shift @_ }, aliases => $aliases );
1097            }
1098    }
1099    
1100  =head2 AddMemberToList  =head2 AddMemberToList
1101    
1102   $member_id = AddMemberToList(   $member_id = AddMemberToList(
1103          list => 'My list',          list => 'My list',
1104          email => 'e-mail@example.com',          email => 'e-mail@example.com',
1105          name => 'Full Name'          name => 'Full Name',
1106            ext_id => 42,
1107   );   );
1108    
1109  =cut  =cut
# Line 671  sub AddMemberToList { Line 1113  sub AddMemberToList {
1113    
1114          if ($_[0] !~ m/^HASH/) {          if ($_[0] !~ m/^HASH/) {
1115                  return $nos->add_member_to_list(                  return $nos->add_member_to_list(
1116                          list => $_[0], email => $_[1], name => $_[2],                          list => $_[0], email => $_[1], name => $_[2], ext_id => $_[4],
1117                  );                  );
1118          } else {          } else {
1119                  return $nos->add_member_to_list( %{ shift @_ } );                  return $nos->add_member_to_list( %{ shift @_ } );
# Line 700  sub ListMembers { Line 1142  sub ListMembers {
1142                  $list_name = $_[0]->{'list'};                  $list_name = $_[0]->{'list'};
1143          }          }
1144    
1145          return $nos->list_members( list => $list_name );          return [ $nos->list_members( list => $list_name ) ];
1146    }
1147    
1148    
1149    =head2 DeleteMemberFromList
1150    
1151     $member_id = DeleteMemberFromList(
1152            list => 'My list',
1153            email => 'e-mail@example.com',
1154     );
1155    
1156    =cut
1157    
1158    sub DeleteMemberFromList {
1159            my $self = shift;
1160    
1161            if ($_[0] !~ m/^HASH/) {
1162                    return $nos->delete_member_from_list(
1163                            list => $_[0], email => $_[1],
1164                    );
1165            } else {
1166                    return $nos->delete_member_from_list( %{ shift @_ } );
1167            }
1168  }  }
1169    
1170    
1171  =head2 AddMessageToList  =head2 AddMessageToList
1172    
1173   $message_id = AddMessageToList(   $message_id = AddMessageToList(
# Line 724  sub AddMessageToList { Line 1189  sub AddMessageToList {
1189          }          }
1190  }  }
1191    
1192    =head2 MessagesReceived
1193    
1194    Return statistics about received messages.
1195    
1196     my @result = MessagesReceived(
1197            list => 'My list',
1198            email => 'jdoe@example.com',
1199            from_date => '2005-01-01 10:15:00',
1200            to_date => '2005-01-01 12:00:00',
1201            message => 0,
1202     );
1203    
1204    You must specify C<list> or C<email> or any combination of those two. Other
1205    parametars are optional.
1206    
1207    For format of returned array element see C<received_messages>.
1208    
1209    =cut
1210    
1211    sub MessagesReceived {
1212            my $self = shift;
1213    
1214            if ($_[0] !~ m/^HASH/) {
1215                    die "need at least list or email" unless (scalar @_ < 2);
1216                    return $nos->received_messages(
1217                            list => $_[0], email => $_[1],
1218                            from_date => $_[2], to_date => $_[3],
1219                            message => $_[4]
1220                    );
1221            } else {
1222                    my $arg = shift;
1223                    die "need list or email argument" unless ($arg->{'list'} || $arg->{'email'});
1224                    return $nos->received_messages( $arg );
1225            }
1226    }
1227    
1228  ###  ###
1229    
1230    =head1 UNIMPLEMENTED SOAP FUNCTIONS
1231    
1232    This is a stub for documentation of unimplemented functions.
1233    
1234    =head2 MessagesReceivedByDate
1235    
1236    =head2 MessagesReceivedByDateWithContent
1237    
1238    =head2 ReceivedMessageContent
1239    
1240    Return content of received message.
1241    
1242     my $mail_body = ReceivedMessageContent( id => 42 );
1243    
1244    
1245    
1246    
1247    =head1 NOTE ON ARRAYS IN SOAP
1248    
1249    Returning arrays from SOAP calls is somewhat fuzzy (at least to me). It
1250    seems that SOAP::Lite client thinks that it has array with one element which
1251    is array of hashes with data.
1252    
1253  =head1 EXPORT  =head1 EXPORT
1254    
1255  Nothing.  Nothing.
Legend:
Removed from v.47  
changed lines
  Added in v.80
  ViewVC Help
Powered by ViewVC 1.1.26