/[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 36 by dpavlin, Tue May 17 17:49:14 2005 UTC revision 67 by dpavlin, Fri Jul 8 17:00:20 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 25  use Carp; Line 25  use Carp;
25  use Email::Auth::AddressHash;  use Email::Auth::AddressHash;
26  use Email::Simple;  use Email::Simple;
27  use Email::Address;  use Email::Address;
28  use Data::Dumper;  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 38  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 55  Create new instance specifing database, Line 91  Create new instance specifing database,
91          hash_len => 8,          hash_len => 8,
92   );   );
93    
94  Parametar C<hash_len> defined length of hash which will be added to each  Parametar C<hash_len> defines length of hash which will be added to each
95  outgoing e-mail message.  outgoing e-mail message to ensure that replies can be linked with sent e-mails.
96    
97  =cut  =cut
98    
# Line 73  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 86  sub new { Line 122  sub new {
122    
123  =head2 new_list  =head2 new_list
124    
125  Create new list  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(   $nos->new_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 C<_add_list>, see details there.
139    
140  =cut  =cut
141    
142  sub new_list {  sub new_list {
# Line 103  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 113  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 121  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 134  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 154  sub add_member_to_list { Line 232  sub add_member_to_list {
232                  email => $email,                  email => $email,
233          }) || croak "can't find or create member\n";          }) || croak "can't find or create member\n";
234    
235          if ($name && $this_user->full_name ne $name) {          if ($name && $this_user->name ne $name) {
236                  $this_user->full_name($name || '');                  $this_user->name($name || '');
237                    $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;                  $this_user->update;
243          }          }
244    
# Line 171  sub add_member_to_list { Line 254  sub add_member_to_list {
254          return $this_user->id;          return $this_user->id;
255  }  }
256    
257    =head2 list_members
258    
259    List all members of some list.
260    
261     my @members = list_members(
262            list => 'My list',
263     );
264    
265    Returns array of hashes with user informations like this:
266    
267     $member = {
268            name => 'Dobrica Pavlinusic',
269            email => 'dpavlin@rot13.org
270     }
271    
272    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
276    
277    sub list_members {
278            my $self = shift;
279    
280            my $args = {@_};
281    
282            my $list_name = lc($args->{'list'}) || confess "need list name";
283    
284            my $lists = $self->{'loader'}->find_class('lists');
285            my $user_list = $self->{'loader'}->find_class('user_list');
286    
287            my $this_list = $lists->search( name => $list_name )->first || return;
288    
289            my @results;
290    
291            foreach my $user_on_list ($user_list->search(list_id => $this_list->id)) {
292                    my $row = {
293                            name => $user_on_list->user_id->name,
294                            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;
301            }
302    
303            return @results;
304    
305    }
306    
307    
308    =head2 delete_member
309    
310    Delete member from database.
311    
312     my $ok = delete_member(
313            name => 'Dobrica Pavlinusic'
314     );
315    
316     my $ok = delete_member(
317            email => 'dpavlin@rot13.org'
318     );
319    
320    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
326    
327    sub delete_member {
328            my $self = shift;
329    
330            my $args = {@_};
331    
332            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';
337            $key = 'email' if ($args->{'email'});
338    
339            my $users = $self->{'loader'}->find_class('users');
340    
341            my $this_user = $users->search( $key => $args->{$key} )->first || return;
342    
343            $this_user->delete || croak "can't delete user\n";
344    
345            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 178  Adds message to one list's queue for lat Line 392  Adds message to one list's queue for lat
392   $nos->add_message_to_list(   $nos->add_message_to_list(
393          list => 'My list',          list => 'My list',
394          message => 'Subject: welcome to list          message => 'Subject: welcome to list
395    
396   This is example message   This is example message
397   ',   ',
398   );       );    
# Line 196  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 237  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");   $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
461    specified, C<IO> driver will be used which will dump e-mail to C<STDERR>.
462    
463    Other valid drivers are:
464    
465    =over 10
466    
467    =item smtp
468    
469    Send e-mail using SMTP server at 127.0.0.1
470    
471    =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 $email_send_driver = 'Email::Send::IO';
488            my @email_send_options;
489    
490            if (lc($driver) eq 'smtp') {
491                    $email_send_driver = 'Email::Send::SMTP';
492                    @email_send_options = ['127.0.0.1'];
493            } else {
494                    warn "dumping all messages to STDERR\n";
495            }
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 276  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'} );
531    
532                                  my $hash = $auth->generate_hash( $to_email );                                  my $hash = $auth->generate_hash( $to_email );
533    
534                                  my $from = $u->list_id->name . " <" . $from . "+" . $hash . ( $domain ? "@" . $domain : '' ). ">";                                  my $from_addr;
535                                  my $to = $u->user_id->full_name . " <$to_email>";                                  my $from_email_only = $from . "+" . $hash . ( $domain ? '@' . $domain : '');
536    
537                                    $from_addr .= '"' . $u->list_id->from_addr . '" ' if ($u->list_id->from_addr);
538                                    $from_addr .= '<' . $from_email_only . '>';
539                                    my $to = '"' . $u->user_id->name . '" <' . $to_email . '>';
540    
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('From', $from) || croak "can't set From: 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 Sender: header";
545                                    $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";
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    
549                                  # FIXME do real sending :-)                                  $m_obj->header_set('X-Nos-Version', $VERSION);
550                                  send IO => $m_obj->as_string;                                  $m_obj->header_set('X-Nos-Hash', $hash);
551    
552                                    # really send e-mail
553                                    my $sent_status;
554    
555                                  $sent->create({                                  if (@email_send_options) {
556                                          message_id => $m->message_id,                                          $sent_status = send $email_send_driver => $m_obj->as_string, @email_send_options;
557                                          user_id => $u->user_id,                                  } else {
558                                          hash => $hash,                                          $sent_status = send $email_send_driver => $m_obj->as_string;
559                                  });                                  }
560                                  $sent->dbi_commit;  
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 {
577                                            warn "ERROR: $sent_status\n";
578                                    }
579    
580                                    if ($sleep) {
581                                            warn "sleeping $sleep seconds\n";
582                                            sleep($sleep);
583                                    }
584                          }                          }
585                  }                  }
586                  $m->all_sent(1);                  $m->all_sent(1);
# Line 318  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 328  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";
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 341  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 $message_id = $sent->search( hash => $hash )->first->message_id;          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
648    
649            if ($sent_msg) {
650                    $message_id = $sent_msg->message_id || carp "no message_id";
651                    $user_id = $sent_msg->user_id || carp "no user_id";
652            } else {
653                    #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  print "message_id: $message_id\n";          my $is_bounce = 0;
663    
664          warn "inbox is not yet implemented";          if ($return_path eq '<>' || $return_path eq '') {
665                    no warnings;
666                    my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
667                            $arg->{'message'}, { report_non_bounces=>1 },
668                    ) };
669                    #warn "can't check if this message is bounce!" if ($@);
670            
671                    $is_bounce++ if ($bounce && $bounce->is_bounce);
672            }
673    
674            my $received = $self->{'loader'}->find_class('received');
675    
676            my $this_received = $received->find_or_create({
677                    user_id => $user_id,
678                    list_id => $this_list->id,
679                    message_id => $message_id,
680                    message => $arg->{'message'},
681                    bounced => $is_bounce,
682            }) || croak "can't insert received message";
683    
684            $this_received->dbi_commit;
685    
686    #       print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
687  }  }
688    
689    
# Line 364  print "message_id: $message_id\n"; Line 691  print "message_id: $message_id\n";
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 new list to C</etc/aliases> (or equivavlent) file
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            croak "need list and email options" unless ($arg->{'list'} && $arg->{'email'});
719    
720            my $aliases = $arg->{'aliases'} || croak "need aliases";
721    
722            unless (-e $aliases) {
723                    warn "aliases file $aliases doesn't exist, creating empty\n";
724                    open(my $fh, '>', $aliases) || croak "can't create $aliases: $!";
725                    close($fh);
726                    chmod 0777, $aliases || warn "can't change permission to 0777";
727            }
728    
729            my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
730    
731            my $target = '';
732    
733            if (my $archive = $arg->{'archive'}) {
734                    $target .= "$archive, ";
735    
736                    if (! -e $archive) {
737                            warn "please make sure that file $archive is writable for your e-mail user (defaulting to bad 777 permission for now)";
738    
739                            open(my $fh, '>', $archive) || croak "can't create archive file $archive: $!";
740                            close($fh);
741                            chmod 0777, $archive || croak "can't chmod archive file $archive to 0777: $!";
742                    }
743            }
744    
745            # resolve my path to absolute one
746            my $self_path = abs_path($0);
747            $self_path =~ s#/[^/]+$##;
748            $self_path =~ s#/t/*$#/#;
749    
750            $target .= qq#| cd $self_path && ./sender.pl --inbox="$arg->{'list'}"#;
751    
752            unless ($a->append($arg->{'email'}, $target)) {
753                    croak "can't add alias ".$a->error_check;
754            }
755    
756            return 1;
757    }
758    
759  =head2 _add_list  =head2 _add_list
760    
761  Create new list  Create new list
762    
763   my $list_obj = $nos->_add_list(   my $list_obj = $nos->_add_list(
764          list => 'My list',          list => 'My list',
765            from => 'Outgoing from comment',
766          email => 'my-list@example.com',          email => 'my-list@example.com',
767            aliases => '/etc/mail/mylist',
768   );   );
769    
770  Returns C<Class::DBI> object for created list.  Returns C<Class::DBI> object for created list.
771    
772    C<email> address can be with domain or without it if your
773    MTA appends it. There is no checking for validity of your
774    list e-mail. Flexibility comes with resposibility, so please
775    feed correct (and configured) return addresses.
776    
777  =cut  =cut
778    
779  sub _add_list {  sub _add_list {
# Line 382  sub _add_list { Line 781  sub _add_list {
781    
782          my $arg = {@_};          my $arg = {@_};
783    
784          my $name = $arg->{'list'} || confess "can't add list without name";          my $name = lc($arg->{'list'}) || confess "can't add list without name";
785          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";
786            my $aliases = lc($arg->{'aliases'}) || confess "can't add list without path to aliases file";
787    
788            my $from_addr = $arg->{'from'};
789    
790          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
791    
792            $self->_add_aliases(
793                    list => $name,
794                    email => $email,
795                    aliases => $aliases,
796            ) || croak "can't add alias $email for list $name";
797    
798          my $l = $lists->find_or_create({          my $l = $lists->find_or_create({
799                  name => $name,                  name => $name,
800                  email => $email,                  email => $email,
801          });          });
802            
803          croak "can't add list $name\n" unless ($l);          croak "can't add list $name\n" unless ($l);
804    
805            if ($from_addr && $l->from_addr ne $from_addr) {
806                    $l->from_addr($from_addr);
807                    $l->update;
808            }
809    
810          $l->dbi_commit;          $l->dbi_commit;
811    
812          return $l;          return $l;
# Line 401  sub _add_list { Line 814  sub _add_list {
814  }  }
815    
816    
817    
818  =head2 _get_list  =head2 _get_list
819    
820  Get list C<Class::DBI> object.  Get list C<Class::DBI> object.
# Line 418  sub _get_list { Line 832  sub _get_list {
832    
833          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";
834    
835          return $lists->search({ name => $name })->first;          return $lists->search({ name => lc($name) })->first;
836    }
837    
838    ###
839    ### SOAP
840    ###
841    
842    package Nos::SOAP;
843    
844    use Carp;
845    
846    =head1 SOAP methods
847    
848    This methods are thin wrappers to provide SOAP calls. They are grouped in
849    C<Nos::SOAP> package which is in same F<Nos.pm> module file.
850    
851    Usually, you want to use named variables in your SOAP calls if at all
852    possible.
853    
854    However, if you have broken SOAP library (like PHP SOAP class from PEAR)
855    you will want to use positional arguments (in same order as documented for
856    methods below).
857    
858    =cut
859    
860    my $nos;
861    
862    
863    =head2 new
864    
865    Create new SOAP object
866    
867     my $soap = new Nos::SOAP(
868            dsn => 'dbi:Pg:dbname=notices',
869            user => 'dpavlin',
870            passwd => '',
871            debug => 1,
872            verbose => 1,
873            hash_len => 8,
874            aliases => '/etc/aliases',
875     );
876    
877    =cut
878    
879    sub new {
880            my $class = shift;
881            my $self = {@_};
882    
883            croak "need aliases parametar" unless ($self->{'aliases'});
884    
885            bless($self, $class);
886    
887            $nos = new Nos( @_ ) || die "can't create Nos object";
888    
889            $self ? return $self : return undef;
890    }
891    
892    
893    =head2 NewList
894    
895     $message_id = NewList(
896            list => 'My list',
897            from => 'Name of my list',
898            email => 'my-list@example.com'
899     );
900    
901    =cut
902    
903    sub NewList {
904            my $self = shift;
905    
906            croak "self is not Nos::SOAP object" unless (ref($self) eq 'Nos::SOAP');
907    
908            my $aliases = $self->{'aliases'} || croak "need 'aliases' argument to new constructor";
909    
910            if ($_[0] !~ m/^HASH/) {
911                    return $nos->new_list(
912                            list => $_[0], from => $_[1], email => $_[2],
913                            aliases => $aliases,
914                    );
915            } else {
916                    return $nos->new_list( %{ shift @_ }, aliases => $aliases );
917            }
918    }
919    
920    
921    =head2 DeleteList
922    
923     $ok = DeleteList(
924            list => 'My list',
925     );
926    
927    =cut
928    
929    sub DeleteList {
930            my $self = shift;
931    
932            if ($_[0] !~ m/^HASH/) {
933                    return $nos->delete_list(
934                            list => $_[0],
935                    );
936            } else {
937                    return $nos->delete_list( %{ shift @_ } );
938            }
939    }
940    
941    =head2 AddMemberToList
942    
943     $member_id = AddMemberToList(
944            list => 'My list',
945            email => 'e-mail@example.com',
946            name => 'Full Name',
947            ext_id => 42,
948     );
949    
950    =cut
951    
952    sub AddMemberToList {
953            my $self = shift;
954    
955            if ($_[0] !~ m/^HASH/) {
956                    return $nos->add_member_to_list(
957                            list => $_[0], email => $_[1], name => $_[2], ext_id => $_[4],
958                    );
959            } else {
960                    return $nos->add_member_to_list( %{ shift @_ } );
961            }
962    }
963    
964    
965    =head2 ListMembers
966    
967     my @members = ListMembers(
968            list => 'My list',
969     );
970    
971    Returns array of hashes with user informations, see C<list_members>.
972    
973    Returning arrays from SOAP calls is somewhat fuzzy (at least to me). It
974    seems that SOAP::Lite client thinks that it has array with one element which
975    is array of hashes with data.
976    
977    =cut
978    
979    sub ListMembers {
980            my $self = shift;
981    
982            my $list_name;
983    
984            if ($_[0] !~ m/^HASH/) {
985                    $list_name = shift;
986            } else {
987                    $list_name = $_[0]->{'list'};
988            }
989    
990            return [ $nos->list_members( list => $list_name ) ];
991    }
992    
993    
994    =head2 DeleteMemberFromList
995    
996     $member_id = DeleteMemberFromList(
997            list => 'My list',
998            email => 'e-mail@example.com',
999     );
1000    
1001    =cut
1002    
1003    sub DeleteMemberFromList {
1004            my $self = shift;
1005    
1006            if ($_[0] !~ m/^HASH/) {
1007                    return $nos->delete_member_from_list(
1008                            list => $_[0], email => $_[1],
1009                    );
1010            } else {
1011                    return $nos->delete_member_from_list( %{ shift @_ } );
1012            }
1013    }
1014    
1015    
1016    =head2 AddMessageToList
1017    
1018     $message_id = AddMessageToList(
1019            list => 'My list',
1020            message => 'From: My list...'
1021     );
1022    
1023    =cut
1024    
1025    sub AddMessageToList {
1026            my $self = shift;
1027    
1028            if ($_[0] !~ m/^HASH/) {
1029                    return $nos->add_message_to_list(
1030                            list => $_[0], message => $_[1],
1031                    );
1032            } else {
1033                    return $nos->add_message_to_list( %{ shift @_ } );
1034            }
1035  }  }
1036    
1037    
1038    ###
1039    
1040  =head1 EXPORT  =head1 EXPORT
1041    
1042  Nothing.  Nothing.
# Line 446  at your option, any later version of Per Line 1061  at your option, any later version of Per
1061    
1062    
1063  =cut  =cut
1064    
1065    1;
Legend:
Removed from v.36  
changed lines
  Added in v.67
  ViewVC Help
Powered by ViewVC 1.1.26