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