/[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 32 by dpavlin, Mon May 16 22:32:58 2005 UTC revision 70 by dpavlin, Tue Aug 2 19:41:28 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.3';  our $VERSION = '0.6';
20    
21  use Class::DBI::Loader;  use Class::DBI::Loader;
22  use Email::Valid;  use Email::Valid;
# Line 24  use Email::Send; Line 24  use Email::Send;
24  use Carp;  use Carp;
25  use Email::Auth::AddressHash;  use Email::Auth::AddressHash;
26  use Email::Simple;  use Email::Simple;
27  use Data::Dumper;  use Email::Address;
28    use Mail::DeliveryStatus::BounceParser;
29    use Class::DBI::AbstractSearch;
30    use Mail::Alias;
31    use Cwd qw(abs_path);
32    
33    
34  =head1 NAME  =head1 NAME
35    
# Line 37  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 51  Create new instance specifing database, Line 88  Create new instance specifing database,
88          passwd => '',          passwd => '',
89          debug => 1,          debug => 1,
90          verbose => 1,          verbose => 1,
91            hash_len => 8,
92   );   );
93    
94    Parametar C<hash_len> defines length of hash which will be added to each
95    outgoing e-mail message to ensure that replies can be linked with sent e-mails.
96    
97  =cut  =cut
98    
99  sub new {  sub new {
# Line 68  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";
116    
117            $self->{'hash_len'} ||= 8;
118    
119          $self ? return $self : return undef;          $self ? return $self : return undef;
120  }  }
121    
122    
123    =head2 new_list
124    
125    Create new list. Required arguments are name of C<list>, C<email> address
126    and path to C<aliases> file.
127    
128     $nos->new_list(
129            list => 'My list',
130            from => 'Outgoing from comment',
131            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.
137    
138    Calls internally C<_add_list>, see details there.
139    
140    =cut
141    
142    sub new_list {
143            my $self = shift;
144    
145            my $arg = {@_};
146    
147            confess "need list name" unless ($arg->{'list'});
148            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'}) ||
154                    $self->_add_list( @_ ) ||
155                    return undef;
156    
157            return $l->id;
158    }
159    
160    
161    =head2 delete_list
162    
163    Delete list from database.
164    
165     my $ok = delete_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 delete_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 85  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 98  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    
226          if (! Email::Valid->address($email)) {          if (! Email::Valid->address($email)) {
227                  carp "SKIPPING $name <$email>\n" if ($self->{'verbose'});                  carp "SKIPPING $name <$email>\n";
228                  return 0;                  return 0;
229          }          }
230    
# Line 116  sub add_member_to_list { Line 235  sub add_member_to_list {
235    
236          my $this_user = $users->find_or_create({          my $this_user = $users->find_or_create({
237                  email => $email,                  email => $email,
                 full_name => $name,  
238          }) || croak "can't find or create member\n";          }) || croak "can't find or create member\n";
239    
240            if ($name && $this_user->name ne $name) {
241                    $this_user->name($name || '');
242                    $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 131  sub add_member_to_list { Line 259  sub add_member_to_list {
259          return $this_user->id;          return $this_user->id;
260  }  }
261    
262    =head2 list_members
263    
264    List all members of some list.
265    
266     my @members = list_members(
267            list => 'My list',
268     );
269    
270    Returns array of hashes with user informations like this:
271    
272     $member = {
273            name => 'Dobrica Pavlinusic',
274            email => 'dpavlin@rot13.org
275     }
276    
277    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
281    
282    sub list_members {
283            my $self = shift;
284    
285            my $args = {@_};
286    
287            my $list_name = lc($args->{'list'}) || confess "need list name";
288    
289            my $lists = $self->{'loader'}->find_class('lists');
290            my $user_list = $self->{'loader'}->find_class('user_list');
291    
292            my $this_list = $lists->search( name => $list_name )->first || return;
293    
294            my @results;
295    
296            foreach my $user_on_list ($user_list->search(list_id => $this_list->id)) {
297                    my $row = {
298                            name => $user_on_list->user_id->name,
299                            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;
306            }
307    
308            return @results;
309    
310    }
311    
312    
313    =head2 delete_member
314    
315    Delete member from database.
316    
317     my $ok = delete_member(
318            name => 'Dobrica Pavlinusic'
319     );
320    
321     my $ok = delete_member(
322            email => 'dpavlin@rot13.org'
323     );
324    
325    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
331    
332    sub delete_member {
333            my $self = shift;
334    
335            my $args = {@_};
336    
337            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';
342            $key = 'email' if ($args->{'email'});
343    
344            my $users = $self->{'loader'}->find_class('users');
345    
346            my $this_user = $users->search( $key => $args->{$key} )->first || return;
347    
348            $this_user->delete || croak "can't delete user\n";
349    
350            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.
396    
397   $nos->add_message_to_list(   $nos->add_message_to_list(
398          list => 'My list',          list => 'My list',
399          message => 'From: My list <mylist@example.com>          message => 'Subject: welcome to list
400   To: John A. Doe <john.doe@example.com>  
   
401   This is example message   This is example message
402   ',   ',
403   );       );    
404    
405  On success returns ID of newly created (or existing) message.  On success returns ID of newly created (or existing) message.
406    
407    Only required header in e-mail is C<Subject:>. C<From:> and C<To:> headers
408    will be automatically generated, but if you want to use own headers, just
409    include them in messages.
410    
411  =cut  =cut
412    
413  sub add_message_to_list {  sub add_message_to_list {
# Line 153  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 194  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 233  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, 10 );                                  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->full_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                                  # FIXME do real sending :-)                                  $m_obj->header_set('X-Nos-Version', $VERSION);
555                                  send IO => $m_obj->as_string;                                  $m_obj->header_set('X-Nos-Hash', $hash);
556    
557                                    # really send e-mail
558                                    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                                  });                                          $sent_status = send $email_send_driver => $m_obj->as_string;
564                                  $sent->dbi_commit;                                  }
565    
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 269  sub send_queued_messages { Line 599  sub send_queued_messages {
599    
600  Receive single message for list's inbox.  Receive single message for list's inbox.
601    
602   my $ok = $nos->inbox_message($message);   my $ok = $nos->inbox_message(
603            list => 'My list',
604            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 {
612          my $self = shift;          my $self = shift;
613    
614          my $message = shift || return;          my $arg = {@_};
615    
616            return unless ($arg->{'message'});
617            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";
622    
623            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";
626    
627          my $m = new Email::Simple->new($message);          my $return_path = $m->header('Return-Path') || '';
628    
629            my @addrs = Email::Address->parse( $to );
630    
631            die "can't parse To: $to address\n" unless (@addrs);
632    
633            my $hl = $self->{'hash_len'} || confess "no hash_len?";
634    
635            my $hash;
636    
637            foreach my $a (@addrs) {
638                    if ($a->address =~ m/\+([a-f0-9]{$hl})@/i) {
639                            $hash = $1;
640                            last;
641                    }
642            }
643    
644            #warn "can't find hash in e-mail $to\n" unless ($hash);
645    
646            my $sent = $self->{'loader'}->find_class('sent');
647    
648            # will use null if no matching message_id is found
649            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
653    
654            if ($sent_msg) {
655                    $message_id = $sent_msg->message_id || carp "no message_id";
656                    $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;
668    
669            if ($return_path eq '<>' || $return_path eq '') {
670                    no warnings;
671                    my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
672                            $arg->{'message'}, { report_non_bounces=>1 },
673                    ) };
674                    #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');
680    
681            my $this_received = $received->find_or_create({
682                    user_id => $user_id,
683                    list_id => $this_list->id,
684                    message_id => $message_id,
685                    message => $arg->{'message'},
686                    bounced => $is_bounce,
687            }) || croak "can't insert received message";
688    
689            $this_received->dbi_commit;
690    
691    #       print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
692  }  }
693    
694    
# Line 287  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 equivavlent) 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            my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
739    
740            my $target = '';
741    
742            if (my $archive = $arg->{'archive'}) {
743                    $target .= "$archive, ";
744    
745                    if (! -e $archive) {
746                            warn "please make sure that file $archive is writable for your e-mail user (defaulting to bad 777 permission for now)";
747    
748                            open(my $fh, '>', $archive) || croak "can't create archive file $archive: $!";
749                            close($fh);
750                            chmod 0777, $archive || croak "can't chmod archive file $archive to 0777: $!";
751                    }
752            }
753    
754            # resolve my path to absolute one
755            my $self_path = abs_path($0);
756            $self_path =~ s#/[^/]+$##;
757            $self_path =~ s#/t/*$#/#;
758    
759            $target .= qq#| cd $self_path && ./sender.pl --inbox="$list"#;
760    
761            if ($a->exists($email)) {
762                    $a->update($email, $target) or croak "can't update alias ".$a->error_check;
763            } else {
764                    $a->append($email, $target) or croak "can't add alias ".$a->error_check;
765            }
766    
767            #$a->write($aliases) or croak "can't save aliases $aliases ".$a->error_check;
768    
769            return 1;
770    }
771    
772  =head2 _add_list  =head2 _add_list
773    
774  Create new list  Create new list
775    
776   my $list_obj = $nos->_add_list(   my $list_obj = $nos->_add_list(
777          list => 'My list',          list => 'My list',
778            from => 'Outgoing from comment',
779          email => 'my-list@example.com',          email => 'my-list@example.com',
780            aliases => '/etc/mail/mylist',
781   );   );
782    
783  Returns C<Class::DBI> object for created list.  Returns C<Class::DBI> object for created list.
784    
785    C<email> address can be with domain or without it if your
786    MTA appends it. There is no checking for validity of your
787    list e-mail. Flexibility comes with resposibility, so please
788    feed correct (and configured) return addresses.
789    
790  =cut  =cut
791    
792  sub _add_list {  sub _add_list {
# Line 305  sub _add_list { Line 794  sub _add_list {
794    
795          my $arg = {@_};          my $arg = {@_};
796    
797          my $name = $arg->{'list'} || confess "can't add list without name";          my $name = lc($arg->{'list'}) || confess "can't add list without name";
798          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";
799            my $aliases = lc($arg->{'aliases'}) || confess "can't add list without path to aliases file";
800    
801            my $from_addr = $arg->{'from'};
802    
803          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
804    
805            $self->_add_aliases(
806                    list => $name,
807                    email => $email,
808                    aliases => $aliases,
809            ) || warn "can't add alias $email for list $name";
810    
811          my $l = $lists->find_or_create({          my $l = $lists->find_or_create({
812                  name => $name,                  name => $name,
813                  email => $email,                  email => $email,
814          });          });
815            
816          croak "can't add list $name\n" unless ($l);          croak "can't add list $name\n" unless ($l);
817    
818            if ($from_addr && $l->from_addr ne $from_addr) {
819                    $l->from_addr($from_addr);
820                    $l->update;
821            }
822    
823          $l->dbi_commit;          $l->dbi_commit;
824    
825          return $l;          return $l;
# Line 324  sub _add_list { Line 827  sub _add_list {
827  }  }
828    
829    
830    
831  =head2 _get_list  =head2 _get_list
832    
833  Get list C<Class::DBI> object.  Get list C<Class::DBI> object.
# Line 341  sub _get_list { Line 845  sub _get_list {
845    
846          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";
847    
848          return $lists->search({ name => $name })->first;          return $lists->search({ name => lc($name) })->first;
849  }  }
850    
851    
852    =head2 _remove_alias
853    
854    Remove list alias
855    
856     my $ok = $nos->_remove_alias(
857            email => 'mylist@example.com',
858            aliases => '/etc/mail/mylist',
859     );
860    
861    Returns true if list is removed or false if list doesn't exist. Dies in case of error.
862    
863    =cut
864    
865    sub _remove_alias {
866            my $self = shift;
867    
868            my $arg = {@_};
869    
870            my $email = lc($arg->{'email'}) || confess "can't remove alias without email";
871            my $aliases = lc($arg->{'aliases'}) || confess "can't remove alias without list";
872    
873            my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
874    
875            if ($a->exists($email)) {
876                    $a->delete($email) || croak "can't remove alias $email";
877            } else {
878                    return 0;
879            }
880    
881            return 1;
882    
883    }
884    
885    ###
886    ### SOAP
887    ###
888    
889    package Nos::SOAP;
890    
891    use Carp;
892    
893    =head1 SOAP methods
894    
895    This methods are thin wrappers to provide SOAP calls. They are grouped in
896    C<Nos::SOAP> package which is in same F<Nos.pm> module file.
897    
898    Usually, you want to use named variables in your SOAP calls if at all
899    possible.
900    
901    However, if you have broken SOAP library (like PHP SOAP class from PEAR)
902    you will want to use positional arguments (in same order as documented for
903    methods below).
904    
905    =cut
906    
907    my $nos;
908    
909    
910    =head2 new
911    
912    Create new SOAP object
913    
914     my $soap = new Nos::SOAP(
915            dsn => 'dbi:Pg:dbname=notices',
916            user => 'dpavlin',
917            passwd => '',
918            debug => 1,
919            verbose => 1,
920            hash_len => 8,
921            aliases => '/etc/aliases',
922     );
923    
924    =cut
925    
926    sub new {
927            my $class = shift;
928            my $self = {@_};
929    
930            croak "need aliases parametar" unless ($self->{'aliases'});
931    
932            bless($self, $class);
933    
934            $nos = new Nos( @_ ) || die "can't create Nos object";
935    
936            $self ? return $self : return undef;
937    }
938    
939    
940    =head2 NewList
941    
942     $message_id = NewList(
943            list => 'My list',
944            from => 'Name of my list',
945            email => 'my-list@example.com'
946     );
947    
948    =cut
949    
950    sub NewList {
951            my $self = shift;
952    
953            my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
954    
955            if ($_[0] !~ m/^HASH/) {
956                    return $nos->new_list(
957                            list => $_[0], from => $_[1], email => $_[2],
958                            aliases => $aliases,
959                    );
960            } else {
961                    return $nos->new_list( %{ shift @_ }, aliases => $aliases );
962            }
963    }
964    
965    
966    =head2 DeleteList
967    
968     $ok = DeleteList(
969            list => 'My list',
970     );
971    
972    =cut
973    
974    sub DeleteList {
975            my $self = shift;
976    
977            my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
978    
979            if ($_[0] !~ m/^HASH/) {
980                    return $nos->delete_list(
981                            list => $_[0],
982                            aliases => $aliases,
983                    );
984            } else {
985                    return $nos->delete_list( %{ shift @_ }, aliases => $aliases );
986            }
987    }
988    
989    =head2 AddMemberToList
990    
991     $member_id = AddMemberToList(
992            list => 'My list',
993            email => 'e-mail@example.com',
994            name => 'Full Name',
995            ext_id => 42,
996     );
997    
998    =cut
999    
1000    sub AddMemberToList {
1001            my $self = shift;
1002    
1003            if ($_[0] !~ m/^HASH/) {
1004                    return $nos->add_member_to_list(
1005                            list => $_[0], email => $_[1], name => $_[2], ext_id => $_[4],
1006                    );
1007            } else {
1008                    return $nos->add_member_to_list( %{ shift @_ } );
1009            }
1010    }
1011    
1012    
1013    =head2 ListMembers
1014    
1015     my @members = ListMembers(
1016            list => 'My list',
1017     );
1018    
1019    Returns array of hashes with user informations, see C<list_members>.
1020    
1021    Returning arrays from SOAP calls is somewhat fuzzy (at least to me). It
1022    seems that SOAP::Lite client thinks that it has array with one element which
1023    is array of hashes with data.
1024    
1025    =cut
1026    
1027    sub ListMembers {
1028            my $self = shift;
1029    
1030            my $list_name;
1031    
1032            if ($_[0] !~ m/^HASH/) {
1033                    $list_name = shift;
1034            } else {
1035                    $list_name = $_[0]->{'list'};
1036            }
1037    
1038            return [ $nos->list_members( list => $list_name ) ];
1039    }
1040    
1041    
1042    =head2 DeleteMemberFromList
1043    
1044     $member_id = DeleteMemberFromList(
1045            list => 'My list',
1046            email => 'e-mail@example.com',
1047     );
1048    
1049    =cut
1050    
1051    sub DeleteMemberFromList {
1052            my $self = shift;
1053    
1054            if ($_[0] !~ m/^HASH/) {
1055                    return $nos->delete_member_from_list(
1056                            list => $_[0], email => $_[1],
1057                    );
1058            } else {
1059                    return $nos->delete_member_from_list( %{ shift @_ } );
1060            }
1061    }
1062    
1063    
1064    =head2 AddMessageToList
1065    
1066     $message_id = AddMessageToList(
1067            list => 'My list',
1068            message => 'From: My list...'
1069     );
1070    
1071    =cut
1072    
1073    sub AddMessageToList {
1074            my $self = shift;
1075    
1076            if ($_[0] !~ m/^HASH/) {
1077                    return $nos->add_message_to_list(
1078                            list => $_[0], message => $_[1],
1079                    );
1080            } else {
1081                    return $nos->add_message_to_list( %{ shift @_ } );
1082            }
1083    }
1084    
1085    
1086    ###
1087    
1088  =head1 EXPORT  =head1 EXPORT
1089    
1090  Nothing.  Nothing.
# Line 369  at your option, any later version of Per Line 1109  at your option, any later version of Per
1109    
1110    
1111  =cut  =cut
1112    
1113    1;
Legend:
Removed from v.32  
changed lines
  Added in v.70
  ViewVC Help
Powered by ViewVC 1.1.26