/[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 68 by dpavlin, Mon Aug 1 08:59:36 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.6';
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  my $email_send_driver = 'Email::Send::IO';  use Cwd qw(abs_path);
 my @email_send_options;  
   
 #$email_send_driver = 'Sendmail';  
32    
33    
34  =head1 NAME  =head1 NAME
# Line 45  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    track replies.
66    
67    It is best used to send smaller 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<perldoc sender.pl>).
76    This command is also useful for debugging while writing client SOAP
77    application.
78    
79  =head1 METHODS  =head1 METHODS
80    
# Line 80  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 93  sub new { Line 122  sub new {
122    
123  =head2 new_list  =head2 new_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->new_list(
129          list => 'My list',          list => 'My list',
130          from => 'Outgoing from comment',          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    
# Line 114  sub new_list { Line 145  sub new_list {
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 124  sub new_list { Line 158  sub new_list {
158  }  }
159    
160    
161    =head2 delete_list
162    
163    Delete list from database.
164    
165     my $ok = delete_list(
166            list => 'My list'
167     );
168    
169    Returns false if list doesn't exist.
170    
171    =cut
172    
173    sub delete_list {
174            my $self = shift;
175    
176            my $args = {@_};
177    
178            croak "need list to delete" unless ($args->{'list'});
179    
180            $args->{'list'} = lc($args->{'list'});
181    
182            my $lists = $self->{'loader'}->find_class('lists');
183    
184            my $this_list = $lists->search( name => $args->{'list'} )->first || return;
185    
186            $this_list->delete || croak "can't delete list\n";
187    
188            return $lists->dbi_commit || croak "can't commit";
189    }
190    
191    
192  =head2 add_member_to_list  =head2 add_member_to_list
193    
194  Add new member to list  Add new member to list
# Line 132  Add new member to list Line 197  Add new member to list
197          list => "My list",          list => "My list",
198          email => "john.doe@example.com",          email => "john.doe@example.com",
199          name => "John A. Doe",          name => "John A. Doe",
200            ext_id => 42,
201   );   );
202    
203  C<name> parametar is optional.  C<name> and C<ext_id> parametars are optional.
204    
205  Return member ID if user is added.  Return member ID if user is added.
206    
# Line 145  sub add_member_to_list { Line 211  sub add_member_to_list {
211    
212          my $arg = {@_};          my $arg = {@_};
213    
214          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";
215          my $name = $arg->{'name'} || '';          my $name = $arg->{'name'} || '';
216          my $list_name = $arg->{'list'} || croak "need list name";          my $list_name = lc($arg->{'list'}) || croak "need list name";
217            my $ext_id = $arg->{'ext_id'};
218    
219          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";
220    
# Line 170  sub add_member_to_list { Line 237  sub add_member_to_list {
237                  $this_user->update;                  $this_user->update;
238          }          }
239    
240            if (defined($ext_id) && ($this_user->ext_id || '') ne $ext_id) {
241                    $this_user->ext_id($ext_id);
242                    $this_user->update;
243            }
244    
245          my $user_on_list = $user_list->find_or_create({          my $user_on_list = $user_list->find_or_create({
246                  user_id => $this_user->id,                  user_id => $this_user->id,
247                  list_id => $list->id,                  list_id => $list->id,
# Line 197  Returns array of hashes with user inform Line 269  Returns array of hashes with user inform
269          email => 'dpavlin@rot13.org          email => 'dpavlin@rot13.org
270   }   }
271    
272  If list is not found, returns false.  If list is not found, returns false. If there is C<ext_id> in user data,
273    it will also be returned.
274    
275  =cut  =cut
276    
# Line 206  sub list_members { Line 279  sub list_members {
279    
280          my $args = {@_};          my $args = {@_};
281    
282          my $list_name = $args->{'list'} || confess "need list name";          my $list_name = lc($args->{'list'}) || confess "need list name";
283    
284          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
285          my $user_list = $self->{'loader'}->find_class('user_list');          my $user_list = $self->{'loader'}->find_class('user_list');
# Line 221  sub list_members { Line 294  sub list_members {
294                          email => $user_on_list->user_id->email,                          email => $user_on_list->user_id->email,
295                  };                  };
296    
297                    my $ext_id = $user_on_list->user_id->ext_id;
298                    $row->{'ext_id'} = $ext_id if (defined($ext_id));
299    
300                  push @results, $row;                  push @results, $row;
301          }          }
302    
# Line 243  Delete member from database. Line 319  Delete member from database.
319    
320  Returns false if user doesn't exist.  Returns false if user doesn't exist.
321    
322    This function will delete member from all lists (by cascading delete), so it
323    shouldn't be used lightly.
324    
325  =cut  =cut
326    
327  sub delete_member {  sub delete_member {
# Line 252  sub delete_member { Line 331  sub delete_member {
331    
332          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'});
333    
334            $args->{'email'} = lc($args->{'email'}) if ($args->{'email'});
335    
336          my $key = 'name';          my $key = 'name';
337          $key = 'email' if ($args->{'email'});          $key = 'email' if ($args->{'email'});
338    
# Line 259  sub delete_member { Line 340  sub delete_member {
340    
341          my $this_user = $users->search( $key => $args->{$key} )->first || return;          my $this_user = $users->search( $key => $args->{$key} )->first || return;
342    
 print Dumper($this_user);  
   
343          $this_user->delete || croak "can't delete user\n";          $this_user->delete || croak "can't delete user\n";
344    
345          return $users->dbi_commit || croak "can't commit";          return $users->dbi_commit || croak "can't commit";
346  }  }
347    
348    =head2 delete_member_from_list
349    
350    Delete member from particular list.
351    
352     my $ok = delete_member_from_list(
353            list => 'My list',
354            email => 'dpavlin@rot13.org',
355     );
356    
357    Returns false if user doesn't exist on that particular list.
358    
359    It will die if list or user doesn't exist. You have been warned (you might
360    want to eval this functon to prevent it from croaking).
361    
362    =cut
363    
364    sub delete_member_from_list {
365            my $self = shift;
366    
367            my $args = {@_};
368    
369            croak "need list name and email of user to delete" unless ($args->{'list'} && $args->{'email'});
370    
371            $args->{'list'} = lc($args->{'list'});
372            $args->{'email'} = lc($args->{'email'});
373    
374            my $user = $self->{'loader'}->find_class('users');
375            my $list = $self->{'loader'}->find_class('lists');
376            my $user_list = $self->{'loader'}->find_class('user_list');
377    
378            my $this_user = $user->search( email => $args->{'email'} )->first || croak "can't find user: ".$args->{'email'};
379            my $this_list = $list->search( name => $args->{'list'} )->first || croak "can't find list: ".$args->{'list'};
380    
381            my $this_user_list = $user_list->search_where( list_id => $this_list->id, user_id => $this_user->id )->first || return;
382    
383            $this_user_list->delete || croak "can't delete user from list\n";
384    
385            return $user_list->dbi_commit || croak "can't commit";
386    }
387    
388  =head2 add_message_to_list  =head2 add_message_to_list
389    
390  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 410  sub add_message_to_list {
410    
411          my $args = {@_};          my $args = {@_};
412    
413          my $list_name = $args->{'list'} || confess "need list name";          my $list_name = lc($args->{'list'}) || confess "need list name";
414          my $message_text = $args->{'message'} || croak "need message";          my $message_text = $args->{'message'} || croak "need message";
415    
416          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 451  sub add_message_to_list {
451    
452  Send queued messages or just ones for selected list  Send queued messages or just ones for selected list
453    
454   $nos->send_queued_messages("My list",'smtp');   $nos->send_queued_messages(
455            list => 'My list',
456            driver => 'smtp',
457            sleep => 3,
458     );
459    
460  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
461  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 470  Send e-mail using SMTP server at 127.0.0
470    
471  =back  =back
472    
473    Default sleep wait between two messages is 3 seconds.
474    
475  =cut  =cut
476    
477  sub send_queued_messages {  sub send_queued_messages {
478          my $self = shift;          my $self = shift;
479    
480          my $list_name = shift;          my $arg = {@_};
481    
482            my $list_name = lc($arg->{'list'}) || '';
483            my $driver = $arg->{'driver'} || '';
484            my $sleep = $arg->{'sleep'};
485            $sleep ||= 3 unless defined($sleep);
486    
487          my $driver = shift || '';          my $email_send_driver = 'Email::Send::IO';
488            my @email_send_options;
489    
490          if (lc($driver) eq 'smtp') {          if (lc($driver) eq 'smtp') {
491                  $email_send_driver = 'Email::Send::SMTP';                  $email_send_driver = 'Email::Send::SMTP';
492                  @email_send_options = ['127.0.0.1'];                  @email_send_options = ['127.0.0.1'];
493            } else {
494                    warn "dumping all messages to STDERR\n";
495          }          }
         warn "using $driver [$email_send_driver]\n";  
496    
497          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
498          my $queue = $self->{'loader'}->find_class('queue');          my $queue = $self->{'loader'}->find_class('queue');
# Line 392  sub send_queued_messages { Line 524  sub send_queued_messages {
524                          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 )) {
525                                  print "SKIP $to_email message allready sent\n";                                  print "SKIP $to_email message allready sent\n";
526                          } else {                          } else {
527                                  print "=> $to_email\n";                                  print "=> $to_email ";
528    
529                                  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;
530                                  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 533  sub send_queued_messages {
533    
534                                  my $from_addr;                                  my $from_addr;
535                                  my $from_email_only = $from . "+" . $hash . ( $domain ? '@' . $domain : '');                                  my $from_email_only = $from . "+" . $hash . ( $domain ? '@' . $domain : '');
536    
537                                  $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);
538                                  $from_addr .= '<' . $from_email_only . '>';                                  $from_addr .= '<' . $from_email_only . '>';
539                                  my $to = '"' . $u->user_id->name . '" <' . $to_email . '>';                                  my $to = '"' . $u->user_id->name . '" <' . $to_email . '>';
# Line 408  sub send_queued_messages { Line 541  sub send_queued_messages {
541                                  my $m_obj = Email::Simple->new($msg) || croak "can't parse message";                                  my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
542    
543                                  $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";
544                                  $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";
545                                  $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";
546                                  $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";
547                                  $m_obj->header_set('To', $to) || croak "can't set To: header";                                  $m_obj->header_set('To', $to) || croak "can't set To: header";
548    
# Line 417  sub send_queued_messages { Line 550  sub send_queued_messages {
550                                  $m_obj->header_set('X-Nos-Hash', $hash);                                  $m_obj->header_set('X-Nos-Hash', $hash);
551    
552                                  # really send e-mail                                  # really send e-mail
553                                    my $sent_status;
554    
555                                  if (@email_send_options) {                                  if (@email_send_options) {
556                                          send $email_send_driver => $m_obj->as_string, @email_send_options;                                          $sent_status = send $email_send_driver => $m_obj->as_string, @email_send_options;
557                                    } else {
558                                            $sent_status = send $email_send_driver => $m_obj->as_string;
559                                    }
560    
561                                    croak "can't send e-mail: $sent_status\n\nOriginal e-mail follows:\n".$m_obj->as_string unless ($sent_status);
562                                    my @bad = @{ $sent_status->prop('bad') };
563                                    croak "failed sending to ",join(",",@bad) if (@bad);
564    
565                                    if ($sent_status) {
566    
567                                            $sent->create({
568                                                    message_id => $m->message_id,
569                                                    user_id => $u->user_id,
570                                                    hash => $hash,
571                                            });
572                                            $sent->dbi_commit;
573    
574                                            print " - $sent_status\n";
575    
576                                  } else {                                  } else {
577                                          send $email_send_driver => $m_obj->as_string;                                          warn "ERROR: $sent_status\n";
578                                  }                                  }
579    
580                                  $sent->create({                                  if ($sleep) {
581                                          message_id => $m->message_id,                                          warn "sleeping $sleep seconds\n";
582                                          user_id => $u->user_id,                                          sleep($sleep);
583                                          hash => $hash,                                  }
                                 });  
                                 $sent->dbi_commit;  
584                          }                          }
585                  }                  }
586                  $m->all_sent(1);                  $m->all_sent(1);
# Line 447  Receive single message for list's inbox. Line 599  Receive single message for list's inbox.
599          message => $message,          message => $message,
600   );   );
601    
602    This method is used by C<sender.pl> when receiving e-mail messages.
603    
604  =cut  =cut
605    
606  sub inbox_message {  sub inbox_message {
# Line 457  sub inbox_message { Line 611  sub inbox_message {
611          return unless ($arg->{'message'});          return unless ($arg->{'message'});
612          croak "need list name" unless ($arg->{'list'});          croak "need list name" unless ($arg->{'list'});
613    
614            $arg->{'list'} = lc($arg->{'list'});
615    
616          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";
617    
618          my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message";          my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message";
619    
620          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";
621    
622            my $return_path = $m->header('Return-Path') || '';
623    
624          my @addrs = Email::Address->parse( $to );          my @addrs = Email::Address->parse( $to );
625    
626          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 630  sub inbox_message {
630          my $hash;          my $hash;
631    
632          foreach my $a (@addrs) {          foreach my $a (@addrs) {
633                  if ($a->address =~ m/\+([a-f0-9]{$hl})@/) {                  if ($a->address =~ m/\+([a-f0-9]{$hl})@/i) {
634                          $hash = $1;                          $hash = $1;
635                          last;                          last;
636                  }                  }
637          }          }
638    
639          croak "can't find hash in e-mail $to\n" unless ($hash);          #warn "can't find hash in e-mail $to\n" unless ($hash);
640    
641          my $sent = $self->{'loader'}->find_class('sent');          my $sent = $self->{'loader'}->find_class('sent');
642    
643          # will use null if no matching message_id is found          # will use null if no matching message_id is found
644          my $sent_msg = $sent->search( hash => $hash )->first;          my $sent_msg;
645            $sent_msg = $sent->search( hash => $hash )->first if ($hash);
646    
647          my ($message_id, $user_id) = (undef, undef);    # init with NULL          my ($message_id, $user_id) = (undef, undef);    # init with NULL
648    
# Line 491  sub inbox_message { Line 650  sub inbox_message {
650                  $message_id = $sent_msg->message_id || carp "no message_id";                  $message_id = $sent_msg->message_id || carp "no message_id";
651                  $user_id = $sent_msg->user_id || carp "no user_id";                  $user_id = $sent_msg->user_id || carp "no user_id";
652          } else {          } else {
653                  warn "can't find sender with hash $hash\n";                  #warn "can't find sender with hash $hash\n";
654                    my $users = $self->{'loader'}->find_class('users');
655                    my $from = $m->header('From');
656                    $from = $1 if ($from =~ m/<(.*)>/);
657                    my $this_user = $users->search( email => lc($from) )->first;
658                    $user_id = $this_user->id if ($this_user);
659          }          }
660    
661    
662          my $is_bounce = 0;          my $is_bounce = 0;
663    
664          {          if ($return_path eq '<>' || $return_path eq '') {
665                  no warnings;                  no warnings;
666                  my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(                  my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
667                          $arg->{'message'}, { report_non_bounces=>1 },                          $arg->{'message'}, { report_non_bounces=>1 },
668                  ) };                  ) };
669                  carp "can't check if this message is bounce!" if ($@);                  #warn "can't check if this message is bounce!" if ($@);
670                    
671                  $is_bounce++ if ($bounce && $bounce->is_bounce);                  $is_bounce++ if ($bounce && $bounce->is_bounce);
672          }          }
# Line 519  sub inbox_message { Line 683  sub inbox_message {
683    
684          $this_received->dbi_commit;          $this_received->dbi_commit;
685    
686          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";  
687  }  }
688    
689    
# Line 530  sub inbox_message { Line 691  sub inbox_message {
691    
692  Beware of dragons! You shouldn't need to call those methods directly.  Beware of dragons! You shouldn't need to call those methods directly.
693    
694    
695    =head2 _add_aliases
696    
697    Add or update alias in C</etc/aliases> (or equivavlent) file for selected list
698    
699     my $ok = $nos->add_aliases(
700            list => 'My list',
701            email => 'my-list@example.com',
702            aliases => '/etc/mail/mylist',
703            archive => '/path/to/mbox/archive',
704    
705     );
706    
707    C<archive> parametar is optional.
708    
709    Return false on failure.
710    
711    =cut
712    
713    sub _add_aliases {
714            my $self = shift;
715    
716            my $arg = {@_};
717    
718            foreach my $o (qw/list email aliases/) {
719                    croak "need $o option" unless ($arg->{$o});
720            }
721    
722            my $aliases = $arg->{'aliases'};
723            my $email = $arg->{'email'};
724            my $list = $arg->{'list'};
725    
726            unless (-e $aliases) {
727                    warn "aliases file $aliases doesn't exist, creating empty\n";
728                    open(my $fh, '>', $aliases) || croak "can't create $aliases: $!";
729                    close($fh);
730                    chmod 0777, $aliases || warn "can't change permission to 0777";
731            }
732    
733            my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
734    
735            my $target = '';
736    
737            if (my $archive = $arg->{'archive'}) {
738                    $target .= "$archive, ";
739    
740                    if (! -e $archive) {
741                            warn "please make sure that file $archive is writable for your e-mail user (defaulting to bad 777 permission for now)";
742    
743                            open(my $fh, '>', $archive) || croak "can't create archive file $archive: $!";
744                            close($fh);
745                            chmod 0777, $archive || croak "can't chmod archive file $archive to 0777: $!";
746                    }
747            }
748    
749            # resolve my path to absolute one
750            my $self_path = abs_path($0);
751            $self_path =~ s#/[^/]+$##;
752            $self_path =~ s#/t/*$#/#;
753    
754            $target .= qq#| cd $self_path && ./sender.pl --inbox="$list"#;
755    
756            if ($a->exists($email)) {
757                    $a->update($email, $target) or croak "can't update alias ".$a->error_check;
758            } else {
759                    $a->append($email, $target) or croak "can't add alias ".$a->error_check;
760            }
761    
762            return 1;
763    }
764    
765  =head2 _add_list  =head2 _add_list
766    
767  Create new list  Create new list
# Line 538  Create new list Line 770  Create new list
770          list => 'My list',          list => 'My list',
771          from => 'Outgoing from comment',          from => 'Outgoing from comment',
772          email => 'my-list@example.com',          email => 'my-list@example.com',
773            aliases => '/etc/mail/mylist',
774   );   );
775    
776  Returns C<Class::DBI> object for created list.  Returns C<Class::DBI> object for created list.
# Line 554  sub _add_list { Line 787  sub _add_list {
787    
788          my $arg = {@_};          my $arg = {@_};
789    
790          my $name = $arg->{'list'} || confess "can't add list without name";          my $name = lc($arg->{'list'}) || confess "can't add list without name";
791          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";
792            my $aliases = lc($arg->{'aliases'}) || confess "can't add list without path to aliases file";
793    
794          my $from_addr = $arg->{'from'};          my $from_addr = $arg->{'from'};
795    
796          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
797    
798            $self->_add_aliases(
799                    list => $name,
800                    email => $email,
801                    aliases => $aliases,
802            ) || warn "can't add alias $email for list $name";
803    
804          my $l = $lists->find_or_create({          my $l = $lists->find_or_create({
805                  name => $name,                  name => $name,
806                  email => $email,                  email => $email,
# Line 579  sub _add_list { Line 820  sub _add_list {
820  }  }
821    
822    
823    
824  =head2 _get_list  =head2 _get_list
825    
826  Get list C<Class::DBI> object.  Get list C<Class::DBI> object.
# Line 596  sub _get_list { Line 838  sub _get_list {
838    
839          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";
840    
841          return $lists->search({ name => $name })->first;          return $lists->search({ name => lc($name) })->first;
842  }  }
843    
844  ###  ###
# Line 623  methods below). Line 865  methods below).
865    
866  my $nos;  my $nos;
867    
868    
869    =head2 new
870    
871    Create new SOAP object
872    
873     my $soap = new Nos::SOAP(
874            dsn => 'dbi:Pg:dbname=notices',
875            user => 'dpavlin',
876            passwd => '',
877            debug => 1,
878            verbose => 1,
879            hash_len => 8,
880            aliases => '/etc/aliases',
881     );
882    
883    =cut
884    
885  sub new {  sub new {
886          my $class = shift;          my $class = shift;
887          my $self = {@_};          my $self = {@_};
888    
889            croak "need aliases parametar" unless ($self->{'aliases'});
890    
891          bless($self, $class);          bless($self, $class);
892    
893          $nos = new Nos( @_ ) || die "can't create Nos object";          $nos = new Nos( @_ ) || die "can't create Nos object";
# Line 638  sub new { Line 900  sub new {
900    
901   $message_id = NewList(   $message_id = NewList(
902          list => 'My list',          list => 'My list',
903            from => 'Name of my list',
904          email => 'my-list@example.com'          email => 'my-list@example.com'
905   );   );
906    
# Line 646  sub new { Line 909  sub new {
909  sub NewList {  sub NewList {
910          my $self = shift;          my $self = shift;
911    
912            my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
913    
914          if ($_[0] !~ m/^HASH/) {          if ($_[0] !~ m/^HASH/) {
915                  return $nos->new_list(                  return $nos->new_list(
916                          list => $_[0], email => $_[1],                          list => $_[0], from => $_[1], email => $_[2],
917                            aliases => $aliases,
918                  );                  );
919          } else {          } else {
920                  return $nos->new_list( %{ shift @_ } );                  return $nos->new_list( %{ shift @_ }, aliases => $aliases );
921          }          }
922  }  }
923    
924    
925    =head2 DeleteList
926    
927     $ok = DeleteList(
928            list => 'My list',
929     );
930    
931    =cut
932    
933    sub DeleteList {
934            my $self = shift;
935    
936            if ($_[0] !~ m/^HASH/) {
937                    return $nos->delete_list(
938                            list => $_[0],
939                    );
940            } else {
941                    return $nos->delete_list( %{ shift @_ } );
942            }
943    }
944    
945  =head2 AddMemberToList  =head2 AddMemberToList
946    
947   $member_id = AddMemberToList(   $member_id = AddMemberToList(
948          list => 'My list',          list => 'My list',
949          email => 'e-mail@example.com',          email => 'e-mail@example.com',
950          name => 'Full Name'          name => 'Full Name',
951            ext_id => 42,
952   );   );
953    
954  =cut  =cut
# Line 671  sub AddMemberToList { Line 958  sub AddMemberToList {
958    
959          if ($_[0] !~ m/^HASH/) {          if ($_[0] !~ m/^HASH/) {
960                  return $nos->add_member_to_list(                  return $nos->add_member_to_list(
961                          list => $_[0], email => $_[1], name => $_[2],                          list => $_[0], email => $_[1], name => $_[2], ext_id => $_[4],
962                  );                  );
963          } else {          } else {
964                  return $nos->add_member_to_list( %{ shift @_ } );                  return $nos->add_member_to_list( %{ shift @_ } );
# Line 687  sub AddMemberToList { Line 974  sub AddMemberToList {
974    
975  Returns array of hashes with user informations, see C<list_members>.  Returns array of hashes with user informations, see C<list_members>.
976    
977    Returning arrays from SOAP calls is somewhat fuzzy (at least to me). It
978    seems that SOAP::Lite client thinks that it has array with one element which
979    is array of hashes with data.
980    
981  =cut  =cut
982    
983  sub ListMembers {  sub ListMembers {
# Line 700  sub ListMembers { Line 991  sub ListMembers {
991                  $list_name = $_[0]->{'list'};                  $list_name = $_[0]->{'list'};
992          }          }
993    
994          return $nos->list_members( list => $list_name );          return [ $nos->list_members( list => $list_name ) ];
995    }
996    
997    
998    =head2 DeleteMemberFromList
999    
1000     $member_id = DeleteMemberFromList(
1001            list => 'My list',
1002            email => 'e-mail@example.com',
1003     );
1004    
1005    =cut
1006    
1007    sub DeleteMemberFromList {
1008            my $self = shift;
1009    
1010            if ($_[0] !~ m/^HASH/) {
1011                    return $nos->delete_member_from_list(
1012                            list => $_[0], email => $_[1],
1013                    );
1014            } else {
1015                    return $nos->delete_member_from_list( %{ shift @_ } );
1016            }
1017  }  }
1018    
1019    
1020  =head2 AddMessageToList  =head2 AddMessageToList
1021    
1022   $message_id = AddMessageToList(   $message_id = AddMessageToList(
Legend:
Removed from v.47  
changed lines
  Added in v.68
  ViewVC Help
Powered by ViewVC 1.1.26