/[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 45 by dpavlin, Wed May 18 13:12:54 2005 UTC revision 74 by dpavlin, Wed Aug 24 17:19:16 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.7';
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 Mail::Alias;
31    use Cwd qw(abs_path);
32    
33    
34  =head1 NAME  =head1 NAME
35    
# Line 39  Nos - Notice Sender core module Line 42  Nos - Notice Sender core module
42    
43  =head1 DESCRIPTION  =head1 DESCRIPTION
44    
45  Core module for notice sender's functionality.  Notice sender is mail handler. It is not MTA, since it doesn't know how to
46    receive e-mails or send them directly to other hosts. It is not mail list
47    manager because it requires programming to add list members and send
48    messages. You can think of it as mechanisam for off-loading your e-mail
49    sending to remote server using SOAP service.
50    
51    It's concept is based around B<lists>. Each list can have zero or more
52    B<members>. Each list can have zero or more B<messages>.
53    
54    Here comes a twist: each outgoing message will have unique e-mail generated,
55    so Notice Sender will be able to link received replies (or bounces) with
56    outgoing messages.
57    
58    It doesn't do much more than that. It B<can't> create MIME encoded e-mail,
59    send attachments, handle 8-bit characters in headers (which have to be
60    encoded) or anything else.
61    
62    It will just queue your e-mail message to particular list (sending it to
63    possibly remote Notice Sender SOAP server just once), send it out at
64    reasonable rate (so that it doesn't flood your e-mail infrastructure) and
65    keep track replies.
66    
67    It is best used to send small number of messages to more-or-less fixed
68    list of recipients while allowing individual responses to be examined.
69    Tipical use include replacing php e-mail sending code with SOAP call to
70    Notice Sender. It does support additional C<ext_id> field for each member
71    which can be used to track some unique identifier from remote system for
72    particular user.
73    
74    It comes with command-line utility C<sender.pl> which can be used to perform
75    all available operation from scripts (see C<sender.pl --man>).
76    This command is also useful for debugging while writing client SOAP
77    application.
78    
79  =head1 METHODS  =head1 METHODS
80    
# Line 74  sub new { Line 109  sub new {
109                  user            => $self->{'user'},                  user            => $self->{'user'},
110                  password        => $self->{'passwd'},                  password        => $self->{'passwd'},
111                  namespace       => "Nos",                  namespace       => "Nos",
112  #               additional_classes      => qw/Class::DBI::AbstractSearch/,                  additional_classes      => qw/Class::DBI::AbstractSearch/,
113  #               additional_base_classes => qw/My::Stuff/,  #               additional_base_classes => qw/My::Stuff/,
114                  relationships   => 1,                  relationships   => 1,
115          ) || croak "can't init Class::DBI::Loader";          ) || croak "can't init Class::DBI::Loader";
# Line 85  sub new { Line 120  sub new {
120  }  }
121    
122    
123  =head2 new_list  =head2 create_list
124    
125  Create new list. Required arguments are name of C<list> and  Create new list. Required arguments are name of C<list>, C<email> address
126  C<email> address.  and path to C<aliases> file.
127    
128   $nos->new_list(   $nos->create_list(
129          list => 'My list',          list => 'My list',
130            from => 'Outgoing from comment',
131          email => 'my-list@example.com',          email => 'my-list@example.com',
132            aliases => '/etc/mail/mylist',
133            archive => '/path/to/mbox/archive',
134   );   );
135    
136  Returns ID of newly created list.  Returns ID of newly created list.
137    
138  Calls internally L<_add_list>, see details there.  Calls internally C<_add_list>, see details there.
139    
140  =cut  =cut
141    
142  sub new_list {  sub create_list {
143          my $self = shift;          my $self = shift;
144    
145          my $arg = {@_};          my $arg = {@_};
146    
147          confess "need list name" unless ($arg->{'list'});          confess "need list name" unless ($arg->{'list'});
148          confess "need list email" unless ($arg->{'list'});          confess "need list email" unless ($arg->{'email'});
149    
150            $arg->{'list'} = lc($arg->{'list'});
151            $arg->{'email'} = lc($arg->{'email'});
152    
153          my $l = $self->_get_list($arg->{'list'}) ||          my $l = $self->_get_list($arg->{'list'}) ||
154                  $self->_add_list( @_ ) ||                  $self->_add_list( @_ ) ||
# Line 117  sub new_list { Line 158  sub new_list {
158  }  }
159    
160    
161    =head2 drop_list
162    
163    Delete list from database.
164    
165     my $ok = drop_list(
166            list => 'My list'
167            aliases => '/etc/mail/mylist',
168     );
169    
170    Returns false if list doesn't exist.
171    
172    =cut
173    
174    sub drop_list {
175            my $self = shift;
176    
177            my $args = {@_};
178    
179            croak "need list to delete" unless ($args->{'list'});
180    
181            $args->{'list'} = lc($args->{'list'});
182    
183            my $aliases = $args->{'aliases'} || croak "need path to aliases file";
184    
185            my $lists = $self->{'loader'}->find_class('lists');
186    
187            my $this_list = $lists->search( name => $args->{'list'} )->first || return;
188    
189            $self->_remove_alias( email => $this_list->email, aliases => $aliases);
190    
191            $this_list->delete || croak "can't delete list\n";
192    
193            return $lists->dbi_commit || croak "can't commit";
194    }
195    
196    
197  =head2 add_member_to_list  =head2 add_member_to_list
198    
199  Add new member to list  Add new member to list
# Line 125  Add new member to list Line 202  Add new member to list
202          list => "My list",          list => "My list",
203          email => "john.doe@example.com",          email => "john.doe@example.com",
204          name => "John A. Doe",          name => "John A. Doe",
205            ext_id => 42,
206   );   );
207    
208  C<name> parametar is optional.  C<name> and C<ext_id> parametars are optional.
209    
210  Return member ID if user is added.  Return member ID if user is added.
211    
# Line 138  sub add_member_to_list { Line 216  sub add_member_to_list {
216    
217          my $arg = {@_};          my $arg = {@_};
218    
219          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";
220          my $name = $arg->{'name'} || '';          my $name = $arg->{'name'} || '';
221          my $list_name = $arg->{'list'} || croak "need list name";          my $list_name = lc($arg->{'list'}) || croak "need list name";
222            my $ext_id = $arg->{'ext_id'};
223    
224          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";
225    
# Line 163  sub add_member_to_list { Line 242  sub add_member_to_list {
242                  $this_user->update;                  $this_user->update;
243          }          }
244    
245            if (defined($ext_id) && ($this_user->ext_id || '') ne $ext_id) {
246                    $this_user->ext_id($ext_id);
247                    $this_user->update;
248            }
249    
250          my $user_on_list = $user_list->find_or_create({          my $user_on_list = $user_list->find_or_create({
251                  user_id => $this_user->id,                  user_id => $this_user->id,
252                  list_id => $list->id,                  list_id => $list->id,
# Line 183  List all members of some list. Line 267  List all members of some list.
267          list => 'My list',          list => 'My list',
268   );   );
269    
270  Returns array of hashes with user informations like this:  Returns array of hashes with user information like this:
271    
272   $member = {   $member = {
273          name => 'Dobrica Pavlinusic',          name => 'Dobrica Pavlinusic',
274          email => 'dpavlin@rot13.org          email => 'dpavlin@rot13.org
275   }   }
276    
277  If list is not found, returns false.  If list is not found, returns false. If there is C<ext_id> in user data,
278    it will also be returned.
279    
280  =cut  =cut
281    
# Line 199  sub list_members { Line 284  sub list_members {
284    
285          my $args = {@_};          my $args = {@_};
286    
287          my $list_name = $args->{'list'} || confess "need list name";          my $list_name = lc($args->{'list'}) || confess "need list name";
288    
289          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
290          my $user_list = $self->{'loader'}->find_class('user_list');          my $user_list = $self->{'loader'}->find_class('user_list');
# Line 214  sub list_members { Line 299  sub list_members {
299                          email => $user_on_list->user_id->email,                          email => $user_on_list->user_id->email,
300                  };                  };
301    
302                    my $ext_id = $user_on_list->user_id->ext_id;
303                    $row->{'ext_id'} = $ext_id if (defined($ext_id));
304    
305                  push @results, $row;                  push @results, $row;
306          }          }
307    
# Line 236  Delete member from database. Line 324  Delete member from database.
324    
325  Returns false if user doesn't exist.  Returns false if user doesn't exist.
326    
327    This function will delete member from all lists (by cascading delete), so it
328    shouldn't be used lightly.
329    
330  =cut  =cut
331    
332  sub delete_member {  sub delete_member {
# Line 245  sub delete_member { Line 336  sub delete_member {
336    
337          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'});
338    
339            $args->{'email'} = lc($args->{'email'}) if ($args->{'email'});
340    
341          my $key = 'name';          my $key = 'name';
342          $key = 'email' if ($args->{'email'});          $key = 'email' if ($args->{'email'});
343    
# Line 252  sub delete_member { Line 345  sub delete_member {
345    
346          my $this_user = $users->search( $key => $args->{$key} )->first || return;          my $this_user = $users->search( $key => $args->{$key} )->first || return;
347    
 print Dumper($this_user);  
   
348          $this_user->delete || croak "can't delete user\n";          $this_user->delete || croak "can't delete user\n";
349    
350          return $users->dbi_commit || croak "can't commit";          return $users->dbi_commit || croak "can't commit";
351  }  }
352    
353    =head2 delete_member_from_list
354    
355    Delete member from particular list.
356    
357     my $ok = delete_member_from_list(
358            list => 'My list',
359            email => 'dpavlin@rot13.org',
360     );
361    
362    Returns false if user doesn't exist on that particular list.
363    
364    It will die if list or user doesn't exist. You have been warned (you might
365    want to eval this functon to prevent it from croaking).
366    
367    =cut
368    
369    sub delete_member_from_list {
370            my $self = shift;
371    
372            my $args = {@_};
373    
374            croak "need list name and email of user to delete" unless ($args->{'list'} && $args->{'email'});
375    
376            $args->{'list'} = lc($args->{'list'});
377            $args->{'email'} = lc($args->{'email'});
378    
379            my $user = $self->{'loader'}->find_class('users');
380            my $list = $self->{'loader'}->find_class('lists');
381            my $user_list = $self->{'loader'}->find_class('user_list');
382    
383            my $this_user = $user->search( email => $args->{'email'} )->first || croak "can't find user: ".$args->{'email'};
384            my $this_list = $list->search( name => $args->{'list'} )->first || croak "can't find list: ".$args->{'list'};
385    
386            my $this_user_list = $user_list->search_where( list_id => $this_list->id, user_id => $this_user->id )->first || return;
387    
388            $this_user_list->delete || croak "can't delete user from list\n";
389    
390            return $user_list->dbi_commit || croak "can't commit";
391    }
392    
393  =head2 add_message_to_list  =head2 add_message_to_list
394    
395  Adds message to one list's queue for later sending.  Adds message to one list's queue for later sending.
# Line 284  sub add_message_to_list { Line 415  sub add_message_to_list {
415    
416          my $args = {@_};          my $args = {@_};
417    
418          my $list_name = $args->{'list'} || confess "need list name";          my $list_name = lc($args->{'list'}) || confess "need list name";
419          my $message_text = $args->{'message'} || croak "need message";          my $message_text = $args->{'message'} || croak "need message";
420    
421          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 325  sub add_message_to_list { Line 456  sub add_message_to_list {
456    
457  Send queued messages or just ones for selected list  Send queued messages or just ones for selected list
458    
459   $nos->send_queued_messages("My list");   $nos->send_queued_messages(
460            list => 'My list',
461            driver => 'smtp',
462            sleep => 3,
463     );
464    
465    Second option is driver which will be used for e-mail delivery. If not
466    specified, C<IO> driver will be used which will dump e-mail to C<STDERR>.
467    
468    Other valid drivers are:
469    
470    =over 10
471    
472    =item smtp
473    
474    Send e-mail using SMTP server at 127.0.0.1
475    
476    =back
477    
478    Default sleep wait between two messages is 3 seconds.
479    
480  =cut  =cut
481    
482  sub send_queued_messages {  sub send_queued_messages {
483          my $self = shift;          my $self = shift;
484    
485          my $list_name = shift;          my $arg = {@_};
486    
487            my $list_name = lc($arg->{'list'}) || '';
488            my $driver = $arg->{'driver'} || '';
489            my $sleep = $arg->{'sleep'};
490            $sleep ||= 3 unless defined($sleep);
491    
492            my $email_send_driver = 'Email::Send::IO';
493            my @email_send_options;
494    
495            if (lc($driver) eq 'smtp') {
496                    $email_send_driver = 'Email::Send::SMTP';
497                    @email_send_options = ['127.0.0.1'];
498            } else {
499                    warn "dumping all messages to STDERR\n";
500            }
501    
502          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
503          my $queue = $self->{'loader'}->find_class('queue');          my $queue = $self->{'loader'}->find_class('queue');
# Line 364  sub send_queued_messages { Line 529  sub send_queued_messages {
529                          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 )) {
530                                  print "SKIP $to_email message allready sent\n";                                  print "SKIP $to_email message allready sent\n";
531                          } else {                          } else {
532                                  print "=> $to_email\n";                                  print "=> $to_email ";
533    
534                                  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;
535                                  my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );                                  my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
536    
537                                  my $hash = $auth->generate_hash( $to_email );                                  my $hash = $auth->generate_hash( $to_email );
538    
539                                  my $from = $u->list_id->name . " <" . $from . "+" . $hash . ( $domain ? "@" . $domain : '' ). ">";                                  my $from_addr;
540                                  my $to = $u->user_id->name . " <$to_email>";                                  my $from_email_only = $from . "+" . $hash . ( $domain ? '@' . $domain : '');
541    
542                                    $from_addr .= '"' . $u->list_id->from_addr . '" ' if ($u->list_id->from_addr);
543                                    $from_addr .= '<' . $from_email_only . '>';
544                                    my $to = '"' . $u->user_id->name . '" <' . $to_email . '>';
545    
546                                  my $m_obj = Email::Simple->new($msg) || croak "can't parse message";                                  my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
547    
548                                  $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";
549                                    $m_obj->header_set('Sender', $from_email_only) || croak "can't set Sender: header";
550                                    $m_obj->header_set('Errors-To', $from_email_only) || croak "can't set Errors-To: header";
551                                    $m_obj->header_set('From', $from_addr) || croak "can't set From: header";
552                                  $m_obj->header_set('To', $to) || croak "can't set To: header";                                  $m_obj->header_set('To', $to) || croak "can't set To: header";
553    
554                                  $m_obj->header_set('X-Nos-Version', $VERSION);                                  $m_obj->header_set('X-Nos-Version', $VERSION);
555                                  $m_obj->header_set('X-Nos-Hash', $hash);                                  $m_obj->header_set('X-Nos-Hash', $hash);
556    
557                                  # FIXME do real sending :-)                                  # really send e-mail
558                                  send IO => $m_obj->as_string;                                  my $sent_status;
559    
560                                  $sent->create({                                  if (@email_send_options) {
561                                          message_id => $m->message_id,                                          $sent_status = send $email_send_driver => $m_obj->as_string, @email_send_options;
562                                          user_id => $u->user_id,                                  } else {
563                                          hash => $hash,                                          $sent_status = send $email_send_driver => $m_obj->as_string;
564                                  });                                  }
565                                  $sent->dbi_commit;  
566                                    croak "can't send e-mail: $sent_status\n\nOriginal e-mail follows:\n".$m_obj->as_string unless ($sent_status);
567                                    my @bad = @{ $sent_status->prop('bad') };
568                                    croak "failed sending to ",join(",",@bad) if (@bad);
569    
570                                    if ($sent_status) {
571    
572                                            $sent->create({
573                                                    message_id => $m->message_id,
574                                                    user_id => $u->user_id,
575                                                    hash => $hash,
576                                            });
577                                            $sent->dbi_commit;
578    
579                                            print " - $sent_status\n";
580    
581                                    } else {
582                                            warn "ERROR: $sent_status\n";
583                                    }
584    
585                                    if ($sleep) {
586                                            warn "sleeping $sleep seconds\n";
587                                            sleep($sleep);
588                                    }
589                          }                          }
590                  }                  }
591                  $m->all_sent(1);                  $m->all_sent(1);
# Line 409  Receive single message for list's inbox. Line 604  Receive single message for list's inbox.
604          message => $message,          message => $message,
605   );   );
606    
607    This method is used by C<sender.pl> when receiving e-mail messages.
608    
609  =cut  =cut
610    
611  sub inbox_message {  sub inbox_message {
# Line 419  sub inbox_message { Line 616  sub inbox_message {
616          return unless ($arg->{'message'});          return unless ($arg->{'message'});
617          croak "need list name" unless ($arg->{'list'});          croak "need list name" unless ($arg->{'list'});
618    
619            $arg->{'list'} = lc($arg->{'list'});
620    
621          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";
622    
623          my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message";          my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message";
624    
625          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";
626    
627            my $return_path = $m->header('Return-Path') || '';
628    
629          my @addrs = Email::Address->parse( $to );          my @addrs = Email::Address->parse( $to );
630    
631          die "can't parse To: $to address\n" unless (@addrs);          die "can't parse To: $to address\n" unless (@addrs);
# Line 434  sub inbox_message { Line 635  sub inbox_message {
635          my $hash;          my $hash;
636    
637          foreach my $a (@addrs) {          foreach my $a (@addrs) {
638                  if ($a->address =~ m/\+([a-f0-9]{$hl})@/) {                  if ($a->address =~ m/\+([a-f0-9]{$hl})@/i) {
639                          $hash = $1;                          $hash = $1;
640                          last;                          last;
641                  }                  }
642          }          }
643    
644          croak "can't find hash in e-mail $to\n" unless ($hash);          #warn "can't find hash in e-mail $to\n" unless ($hash);
645    
646          my $sent = $self->{'loader'}->find_class('sent');          my $sent = $self->{'loader'}->find_class('sent');
647    
648          # will use null if no matching message_id is found          # will use null if no matching message_id is found
649          my $sent_msg = $sent->search( hash => $hash )->first;          my $sent_msg;
650            $sent_msg = $sent->search( hash => $hash )->first if ($hash);
651    
652          my ($message_id, $user_id) = (undef, undef);    # init with NULL          my ($message_id, $user_id) = (undef, undef);    # init with NULL
653    
654          if ($sent_msg) {          if ($sent_msg) {
655                  $message_id = $sent_msg->message_id || carp "no message_id";                  $message_id = $sent_msg->message_id || carp "no message_id";
656                  $user_id = $sent_msg->user_id || carp "no user_id";                  $user_id = $sent_msg->user_id || carp "no user_id";
657            } else {
658                    #warn "can't find sender with hash $hash\n";
659                    my $users = $self->{'loader'}->find_class('users');
660                    my $from = $m->header('From');
661                    $from = $1 if ($from =~ m/<(.*)>/);
662                    my $this_user = $users->search( email => lc($from) )->first;
663                    $user_id = $this_user->id if ($this_user);
664          }          }
665    
666    
667          my $is_bounce = 0;          my $is_bounce = 0;
668    
669          my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(          if ($return_path eq '<>' || $return_path eq '') {
670                  $arg->{'message'}, { report_non_bounces=>1 },                  no warnings;
671          ) };                  my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
672          carp "can't check if this message is bounce!" if ($@);                          $arg->{'message'}, { report_non_bounces=>1 },
673                    ) };
674          $is_bounce++ if ($bounce && $bounce->is_bounce);                  #warn "can't check if this message is bounce!" if ($@);
675            
676                    $is_bounce++ if ($bounce && $bounce->is_bounce);
677            }
678    
679          my $received = $self->{'loader'}->find_class('received');          my $received = $self->{'loader'}->find_class('received');
680    
# Line 476  sub inbox_message { Line 688  sub inbox_message {
688    
689          $this_received->dbi_commit;          $this_received->dbi_commit;
690    
691          print "message_id: ",($message_id || "not found")," -- $is_bounce\n";  #       print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
   
   
         warn "inbox is not yet implemented";  
692  }  }
693    
694    
# Line 487  sub inbox_message { Line 696  sub inbox_message {
696    
697  Beware of dragons! You shouldn't need to call those methods directly.  Beware of dragons! You shouldn't need to call those methods directly.
698    
699    
700    =head2 _add_aliases
701    
702    Add or update alias in C</etc/aliases> (or equivalent) file for selected list
703    
704     my $ok = $nos->add_aliases(
705            list => 'My list',
706            email => 'my-list@example.com',
707            aliases => '/etc/mail/mylist',
708            archive => '/path/to/mbox/archive',
709    
710     );
711    
712    C<archive> parametar is optional.
713    
714    Return false on failure.
715    
716    =cut
717    
718    sub _add_aliases {
719            my $self = shift;
720    
721            my $arg = {@_};
722    
723            foreach my $o (qw/list email aliases/) {
724                    croak "need $o option" unless ($arg->{$o});
725            }
726    
727            my $aliases = $arg->{'aliases'};
728            my $email = $arg->{'email'};
729            my $list = $arg->{'list'};
730    
731            unless (-e $aliases) {
732                    warn "aliases file $aliases doesn't exist, creating empty\n";
733                    open(my $fh, '>', $aliases) || croak "can't create $aliases: $!";
734                    close($fh);
735                    chmod 0777, $aliases || warn "can't change permission to 0777";
736            }
737    
738            die "FATAL: aliases file $aliases is not writable\n" unless (-w $aliases);
739    
740            my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
741    
742            my $target = '';
743    
744            if (my $archive = $arg->{'archive'}) {
745                    $target .= "$archive, ";
746    
747                    if (! -e $archive) {
748                            warn "please make sure that file $archive is writable for your e-mail user (defaulting to bad 777 permission for now)";
749    
750                            open(my $fh, '>', $archive) || croak "can't create archive file $archive: $!";
751                            close($fh);
752                            chmod 0777, $archive || croak "can't chmod archive file $archive to 0777: $!";
753                    }
754            }
755    
756            # resolve my path to absolute one
757            my $self_path = abs_path($0);
758            $self_path =~ s#/[^/]+$##;
759            $self_path =~ s#/t/*$#/#;
760    
761            $target .= qq#| cd $self_path && ./sender.pl --inbox="$list"#;
762    
763            if ($a->exists($email)) {
764                    $a->update($email, $target) or croak "can't update alias ".$a->error_check;
765            } else {
766                    $a->append($email, $target) or croak "can't add alias ".$a->error_check;
767            }
768    
769            #$a->write($aliases) or croak "can't save aliases $aliases ".$a->error_check;
770    
771            return 1;
772    }
773    
774  =head2 _add_list  =head2 _add_list
775    
776  Create new list  Create new list
777    
778   my $list_obj = $nos->_add_list(   my $list_obj = $nos->_add_list(
779          list => 'My list',          list => 'My list',
780            from => 'Outgoing from comment',
781          email => 'my-list@example.com',          email => 'my-list@example.com',
782            aliases => '/etc/mail/mylist',
783   );   );
784    
785  Returns C<Class::DBI> object for created list.  Returns C<Class::DBI> object for created list.
# Line 510  sub _add_list { Line 796  sub _add_list {
796    
797          my $arg = {@_};          my $arg = {@_};
798    
799          my $name = $arg->{'list'} || confess "can't add list without name";          my $name = lc($arg->{'list'}) || confess "can't add list without name";
800          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";
801            my $aliases = lc($arg->{'aliases'}) || confess "can't add list without path to aliases file";
802    
803            my $from_addr = $arg->{'from'};
804    
805          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
806    
807            $self->_add_aliases(
808                    list => $name,
809                    email => $email,
810                    aliases => $aliases,
811            ) || warn "can't add alias $email for list $name";
812    
813          my $l = $lists->find_or_create({          my $l = $lists->find_or_create({
814                  name => $name,                  name => $name,
815                  email => $email,                  email => $email,
816          });          });
817            
818          croak "can't add list $name\n" unless ($l);          croak "can't add list $name\n" unless ($l);
819    
820            if ($from_addr && $l->from_addr ne $from_addr) {
821                    $l->from_addr($from_addr);
822                    $l->update;
823            }
824    
825          $l->dbi_commit;          $l->dbi_commit;
826    
827          return $l;          return $l;
# Line 529  sub _add_list { Line 829  sub _add_list {
829  }  }
830    
831    
832    
833  =head2 _get_list  =head2 _get_list
834    
835  Get list C<Class::DBI> object.  Get list C<Class::DBI> object.
# Line 546  sub _get_list { Line 847  sub _get_list {
847    
848          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";
849    
850          return $lists->search({ name => $name })->first;          return $lists->search({ name => lc($name) })->first;
851    }
852    
853    
854    =head2 _remove_alias
855    
856    Remove list alias
857    
858     my $ok = $nos->_remove_alias(
859            email => 'mylist@example.com',
860            aliases => '/etc/mail/mylist',
861     );
862    
863    Returns true if list is removed or false if list doesn't exist. Dies in case of error.
864    
865    =cut
866    
867    sub _remove_alias {
868            my $self = shift;
869    
870            my $arg = {@_};
871    
872            my $email = lc($arg->{'email'}) || confess "can't remove alias without email";
873            my $aliases = lc($arg->{'aliases'}) || confess "can't remove alias without list";
874    
875            my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
876    
877            if ($a->exists($email)) {
878                    $a->delete($email) || croak "can't remove alias $email";
879            } else {
880                    return 0;
881            }
882    
883            return 1;
884    
885  }  }
886    
887  ###  ###
# Line 573  methods below). Line 908  methods below).
908    
909  my $nos;  my $nos;
910    
911    
912    =head2 new
913    
914    Create new SOAP object
915    
916     my $soap = new Nos::SOAP(
917            dsn => 'dbi:Pg:dbname=notices',
918            user => 'dpavlin',
919            passwd => '',
920            debug => 1,
921            verbose => 1,
922            hash_len => 8,
923            aliases => '/etc/aliases',
924     );
925    
926    =cut
927    
928  sub new {  sub new {
929          my $class = shift;          my $class = shift;
930          my $self = {@_};          my $self = {@_};
931    
932            croak "need aliases parametar" unless ($self->{'aliases'});
933    
934          bless($self, $class);          bless($self, $class);
935    
936          $nos = new Nos( @_ ) || die "can't create Nos object";          $nos = new Nos( @_ ) || die "can't create Nos object";
# Line 584  sub new { Line 939  sub new {
939  }  }
940    
941    
942  =head2 NewList  =head2 CreateList
943    
944   $message_id = NewList(   $message_id = CreateList(
945          list => 'My list',          list => 'My list',
946            from => 'Name of my list',
947          email => 'my-list@example.com'          email => 'my-list@example.com'
948   );   );
949    
950  =cut  =cut
951    
952  sub NewList {  sub CreateList {
953          my $self = shift;          my $self = shift;
954    
955            my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
956    
957          if ($_[0] !~ m/^HASH/) {          if ($_[0] !~ m/^HASH/) {
958                  return $nos->new_list(                  return $nos->create_list(
959                          list => $_[0], email => $_[1],                          list => $_[0], from => $_[1], email => $_[2],
960                            aliases => $aliases,
961                  );                  );
962          } else {          } else {
963                  return $nos->new_list( %{ shift @_ } );                  return $nos->create_list( %{ shift @_ }, aliases => $aliases );
964          }          }
965  }  }
966    
967    
968    =head2 DropList
969    
970     $ok = DropList(
971            list => 'My list',
972     );
973    
974    =cut
975    
976    sub DropList {
977            my $self = shift;
978    
979            my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
980    
981            if ($_[0] !~ m/^HASH/) {
982                    return $nos->drop_list(
983                            list => $_[0],
984                            aliases => $aliases,
985                    );
986            } else {
987                    return $nos->drop_list( %{ shift @_ }, aliases => $aliases );
988            }
989    }
990    
991  =head2 AddMemberToList  =head2 AddMemberToList
992    
993   $member_id = AddMemberToList(   $member_id = AddMemberToList(
994          list => 'My list',          list => 'My list',
995          email => 'e-mail@example.com',          email => 'e-mail@example.com',
996          name => 'Full Name'          name => 'Full Name',
997            ext_id => 42,
998   );   );
999    
1000  =cut  =cut
# Line 621  sub AddMemberToList { Line 1004  sub AddMemberToList {
1004    
1005          if ($_[0] !~ m/^HASH/) {          if ($_[0] !~ m/^HASH/) {
1006                  return $nos->add_member_to_list(                  return $nos->add_member_to_list(
1007                          list => $_[0], email => $_[1], name => $_[2],                          list => $_[0], email => $_[1], name => $_[2], ext_id => $_[4],
1008                  );                  );
1009          } else {          } else {
1010                  return $nos->add_member_to_list( %{ shift @_ } );                  return $nos->add_member_to_list( %{ shift @_ } );
# Line 650  sub ListMembers { Line 1033  sub ListMembers {
1033                  $list_name = $_[0]->{'list'};                  $list_name = $_[0]->{'list'};
1034          }          }
1035    
1036          return $nos->list_members( list => $list_name );          return [ $nos->list_members( list => $list_name ) ];
1037  }  }
1038    
1039    
1040    =head2 DeleteMemberFromList
1041    
1042     $member_id = DeleteMemberFromList(
1043            list => 'My list',
1044            email => 'e-mail@example.com',
1045     );
1046    
1047    =cut
1048    
1049    sub DeleteMemberFromList {
1050            my $self = shift;
1051    
1052            if ($_[0] !~ m/^HASH/) {
1053                    return $nos->delete_member_from_list(
1054                            list => $_[0], email => $_[1],
1055                    );
1056            } else {
1057                    return $nos->delete_member_from_list( %{ shift @_ } );
1058            }
1059    }
1060    
1061    
1062  =head2 AddMessageToList  =head2 AddMessageToList
1063    
1064   $message_id = AddMessageToList(   $message_id = AddMessageToList(
# Line 674  sub AddMessageToList { Line 1080  sub AddMessageToList {
1080          }          }
1081  }  }
1082    
1083    =head1 UNIMPLEMENTED FUNCTIONS
1084    
1085    This is a stub for documentation of unimplemented functions.
1086    
1087    =head2 MessagesReceived
1088    
1089     my @result = MessagesReceived(
1090            list => 'My list',
1091            email => 'jdoe@example.com',
1092     );
1093    
1094    You can specify just C<list> or C<email> or any combination of those.
1095    
1096    It will return array of hashes with following structure:
1097    
1098     {
1099            id => 42,                       # unique ID of received message
1100            list => 'My list',              # useful only of filtering by email
1101            ext_id => 9999,                 # ext_id from message user
1102            email => 'jdoe@example.com',    # e-mail of user
1103            bounced => 0,                   # true value if message is bounce
1104            date => '2005-08-24 18:57:24',  # date of recival in ISO format
1105     }
1106    
1107    =head2 MessagesReceivedByDate
1108    
1109    =head2 MessagesReceivedByDateWithContent
1110    
1111    =head2 ReceivedMessasgeContent
1112    
1113    Return content of received message.
1114    
1115     my $mail_body = ReceivedMessageContent( id => 42 );
1116    
1117    =cut
1118    
1119    
1120    
1121    
1122  ###  ###
1123    
1124    =head1 NOTE ON ARRAYS IN SOAP
1125    
1126    Returning arrays from SOAP calls is somewhat fuzzy (at least to me). It
1127    seems that SOAP::Lite client thinks that it has array with one element which
1128    is array of hashes with data.
1129    
1130  =head1 EXPORT  =head1 EXPORT
1131    
1132  Nothing.  Nothing.
Legend:
Removed from v.45  
changed lines
  Added in v.74
  ViewVC Help
Powered by ViewVC 1.1.26