/[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 93 by dpavlin, Tue Dec 19 15:04:05 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.9';
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 SQL::Abstract;
31    use Mail::Alias;
32    use Cwd qw(abs_path);
33    
34    
35  =head1 NAME  =head1 NAME
36    
# Line 37  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 51  Create new instance specifing database, Line 89  Create new instance specifing database,
89          passwd => '',          passwd => '',
90          debug => 1,          debug => 1,
91          verbose => 1,          verbose => 1,
92            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
97    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 68  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";
122    
123            $self->{'hash_len'} ||= 8;
124    
125          $self ? return $self : return undef;          $self ? return $self : return undef;
126  }  }
127    
128    
129    =head2 create_list
130    
131    Create new list. Required arguments are name of C<list>, C<email> address
132    and path to C<aliases> file.
133    
134     $nos->create_list(
135            list => 'My list',
136            from => 'Outgoing from comment',
137            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.
143    
144    Calls internally C<_add_list>, see details there.
145    
146    =cut
147    
148    sub create_list {
149            my $self = shift;
150    
151            my $arg = {@_};
152    
153            confess "need list name" unless ($arg->{'list'});
154            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'}) ||
160                    $self->_add_list( @_ ) ||
161                    return undef;
162    
163            return $l->id;
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 85  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 98  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    
232          if (! Email::Valid->address($email)) {          if (! Email::Valid->address($email)) {
233                  carp "SKIPPING $name <$email>\n" if ($self->{'verbose'});                  carp "SKIPPING $name <$email>\n";
234                  return 0;                  return 0;
235          }          }
236    
# Line 116  sub add_member_to_list { Line 241  sub add_member_to_list {
241    
242          my $this_user = $users->find_or_create({          my $this_user = $users->find_or_create({
243                  email => $email,                  email => $email,
                 full_name => $name,  
244          }) || croak "can't find or create member\n";          }) || croak "can't find or create member\n";
245    
246            if ($name && $this_user->name ne $name) {
247                    $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;
254            }
255    
256          my $user_on_list = $user_list->find_or_create({          my $user_on_list = $user_list->find_or_create({
257                  user_id => $this_user->id,                  user_id => $this_user->id,
258                  list_id => $list->id,                  list_id => $list->id,
# Line 131  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.
402    
403   $nos->add_message_to_list(   $nos->add_message_to_list(
404          list => 'My list',          list => 'My list',
405          message => 'From: My list <mylist@example.com>          message => 'Subject: welcome to list
406   To: John A. Doe <john.doe@example.com>  
   
407   This is example message   This is example message
408   ',   ',
409   );       );    
410    
411  On success returns ID of newly created (or existing) message.  On success returns ID of newly created (or existing) message.
412    
413    Only required header in e-mail is C<Subject:>. C<From:> and C<To:> headers
414    will be automatically generated, but if you want to use own headers, just
415    include them in messages.
416    
417  =cut  =cut
418    
419  sub add_message_to_list {  sub add_message_to_list {
# Line 153  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 194  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            verbose => 1,
467     );
468    
469    Second option is driver which will be used for e-mail delivery. If not
470    specified, C<IO> driver will be used which will dump e-mail to C<STDERR>.
471    
472    Other valid drivers are:
473    
474    =over 10
475    
476    =item smtp
477    
478    Send e-mail using SMTP server at 127.0.0.1
479    
480    =item verbose
481    
482    Display diagnostic output to C<STDOUT> and C<STDERR>.
483    
484    =back
485    
486    Any other driver name will try to use C<Email::Send::that_driver> module.
487    
488    Default sleep wait between two messages is 3 seconds.
489    
490    This method will return number of succesfully sent messages.
491    
492  =cut  =cut
493    
494  sub send_queued_messages {  sub send_queued_messages {
495          my $self = shift;          my $self = shift;
496    
497          my $list_name = shift;          my $arg = {@_};
498    
499            my $list_name = lc($arg->{'list'}) || '';
500            my $driver = $arg->{'driver'} || '';
501            my $sleep = $arg->{'sleep'};
502            my $verbose = $arg->{verbose};
503            $sleep ||= 3 unless defined($sleep);
504    
505            # number of messages sent o.k.
506            my $ok = 0;
507    
508            my $email_send_driver = 'Email::Send::IO';
509            my @email_send_options;
510    
511            if (lc($driver) eq 'smtp') {
512                    $email_send_driver = 'Email::Send::SMTP';
513                    @email_send_options = ['127.0.0.1'];
514            } elsif ($driver && $driver ne '') {
515                    $email_send_driver = 'Email::Send::' . $driver;
516            } else {
517                    warn "dumping all messages to STDERR\n" if ($verbose);
518            }
519    
520          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
521          my $queue = $self->{'loader'}->find_class('queue');          my $queue = $self->{'loader'}->find_class('queue');
# Line 221  sub send_queued_messages { Line 535  sub send_queued_messages {
535          while (my $m = $my_q->next) {          while (my $m = $my_q->next) {
536                  next if ($m->all_sent);                  next if ($m->all_sent);
537    
538                  print "sending message ",$m->message_id," enqueued on ",$m->date," to list ",$m->list_id->name,"\n";                  print "sending message ",$m->message_id," enqueued on ",$m->date," to list ",$m->list_id->name,"\n" if ($verbose);
539                  my $msg = $m->message_id->message;                  my $msg = $m->message_id->message;
540    
541                  foreach my $u ($user_list->search(list_id => $m->list_id)) {                  foreach my $u ($user_list->search(list_id => $m->list_id)) {
# Line 231  sub send_queued_messages { Line 545  sub send_queued_messages {
545                          my ($from,$domain) = split(/@/, $u->list_id->email, 2);                          my ($from,$domain) = split(/@/, $u->list_id->email, 2);
546    
547                          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 )) {
548                                  print "SKIP $to_email message allready sent\n";                                  print "SKIP $to_email message allready sent\n" if ($verbose);
549                          } else {                          } else {
550                                  print "=> $to_email\n";                                  print "=> $to_email " if ($verbose);
551    
552                                  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;
553                                  my $auth = Email::Auth::AddressHash->new( $secret, 10 );                                  my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
554    
555                                  my $hash = $auth->generate_hash( $to_email );                                  my $hash = $auth->generate_hash( $to_email );
556    
557                                  my $from = $u->list_id->name . " <" . $from . "+" . $hash . ( $domain ? "@" . $domain : '' ). ">";                                  my $from_addr;
558                                  my $to = $u->user_id->full_name . " <$to_email>";                                  my $from_email_only = $from . "+" . $hash . ( $domain ? '@' . $domain : '');
559    
560                                    $from_addr .= '"' . $u->list_id->from_addr . '" ' if ($u->list_id->from_addr);
561                                    $from_addr .= '<' . $from_email_only . '>';
562                                    my $to = '"' . $u->user_id->name . '" <' . $to_email . '>';
563    
564                                  my $m_obj = Email::Simple->new($msg) || croak "can't parse message";                                  my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
565    
566                                  $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";
567                                    #$m_obj->header_set('Sender', $from_email_only) || croak "can't set Sender: header";
568                                    $m_obj->header_set('Errors-To', $from_email_only) || croak "can't set Errors-To: header";
569                                    $m_obj->header_set('From', $from_addr) || croak "can't set From: header";
570                                  $m_obj->header_set('To', $to) || croak "can't set To: header";                                  $m_obj->header_set('To', $to) || croak "can't set To: header";
571    
572                                  # FIXME do real sending :-)                                  $m_obj->header_set('X-Nos-Version', $VERSION);
573                                  send IO => $m_obj->as_string;                                  $m_obj->header_set('X-Nos-Hash', $hash);
574    
575                                  $sent->create({                                  # really send e-mail
576                                          message_id => $m->message_id,                                  my $sent_status;
577                                          user_id => $u->user_id,  
578                                  });                                  if (@email_send_options) {
579                                  $sent->dbi_commit;                                          $sent_status = send $email_send_driver => $m_obj->as_string, @email_send_options;
580                                    } else {
581                                            $sent_status = send $email_send_driver => $m_obj->as_string;
582                                    }
583    
584                                    croak "can't send e-mail: $sent_status\n\nOriginal e-mail follows:\n".$m_obj->as_string unless ($sent_status);
585                                    my @bad;
586                                    @bad = @{ $sent_status->prop('bad') } if (eval { $sent_status->can('prop') });
587                                    croak "failed sending to ",join(",",@bad) if (@bad);
588    
589                                    if ($sent_status) {
590    
591                                            $sent->create({
592                                                    message_id => $m->message_id,
593                                                    user_id => $u->user_id,
594                                                    hash => $hash,
595                                            });
596                                            $sent->dbi_commit;
597    
598                                            print " - $sent_status\n" if ($verbose);
599    
600                                            $ok++;
601                                    } else {
602                                            warn "ERROR: $sent_status\n" if ($verbose);
603                                    }
604    
605                                    if ($sleep) {
606                                            warn "sleeping $sleep seconds\n" if ($verbose);
607                                            sleep($sleep);
608                                    }
609                          }                          }
610                  }                  }
611                  $m->all_sent(1);                  $m->all_sent(1);
# Line 263  sub send_queued_messages { Line 613  sub send_queued_messages {
613                  $m->dbi_commit;                  $m->dbi_commit;
614          }          }
615    
616            return $ok;
617    
618  }  }
619    
620  =head2 inbox_message  =head2 inbox_message
621    
622  Receive single message for list's inbox.  Receive single message for list's inbox.
623    
624   my $ok = $nos->inbox_message($message);   my $ok = $nos->inbox_message(
625            list => 'My list',
626            message => $message,
627     );
628    
629    This method is used by C<sender.pl> when receiving e-mail messages.
630    
631  =cut  =cut
632    
633  sub inbox_message {  sub inbox_message {
634          my $self = shift;          my $self = shift;
635    
636          my $message = shift || return;          my $arg = {@_};
637    
638            return unless ($arg->{'message'});
639            croak "need list name" unless ($arg->{'list'});
640    
641            $arg->{'list'} = lc($arg->{'list'});
642    
643            my $this_list = $self->_get_list($arg->{'list'}) || croak "can't find list ".$arg->{'list'}."\n";
644    
645            my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message";
646    
647            my $to = $m->header('To') || die "can't find To: address in incomming message\n";
648    
649            my $return_path = $m->header('Return-Path') || '';
650    
651            my @addrs = Email::Address->parse( $to );
652    
653            die "can't parse To: $to address\n" unless (@addrs);
654    
655            my $hl = $self->{'hash_len'} || confess "no hash_len?";
656    
657            my $hash;
658    
659            foreach my $a (@addrs) {
660                    if ($a->address =~ m/\+([a-f0-9]{$hl})@/i) {
661                            $hash = $1;
662                            last;
663                    }
664            }
665    
666            #warn "can't find hash in e-mail $to\n" unless ($hash);
667    
668            my $sent = $self->{'loader'}->find_class('sent');
669    
670            # will use null if no matching message_id is found
671            my $sent_msg;
672            $sent_msg = $sent->search( hash => $hash )->first if ($hash);
673    
674            my ($message_id, $user_id) = (undef, undef);    # init with NULL
675    
676            if ($sent_msg) {
677                    $message_id = $sent_msg->message_id || carp "no message_id";
678                    $user_id = $sent_msg->user_id || carp "no user_id";
679            } else {
680                    #warn "can't find sender with hash $hash\n";
681                    my $users = $self->{'loader'}->find_class('users');
682                    my $from = $m->header('From');
683                    $from = $1 if ($from =~ m/<(.*)>/);
684                    my $this_user = $users->search( email => lc($from) )->first;
685                    $user_id = $this_user->id if ($this_user);
686            }
687    
688    
689            my $is_bounce = 0;
690    
691            if ($return_path eq '<>' || $return_path eq '') {
692                    no warnings;
693                    my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
694                            $arg->{'message'}, { report_non_bounces=>1 },
695                    ) };
696                    #warn "can't check if this message is bounce!" if ($@);
697            
698                    $is_bounce++ if ($bounce && $bounce->is_bounce);
699            }
700    
701            my $received = $self->{'loader'}->find_class('received');
702    
703            my $this_received = $received->find_or_create({
704                    user_id => $user_id,
705                    list_id => $this_list->id,
706                    message_id => $message_id,
707                    message => $arg->{'message'},
708                    bounced => $is_bounce,
709            }) || croak "can't insert received message";
710    
711            $this_received->dbi_commit;
712    
713    #       print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
714    }
715    
716    =head2 received_messages
717    
718    Returns all received messages for given list or user.
719    
720     my @received = $nos->received_messages(
721            list => 'My list',
722            email => "john.doe@example.com",
723            from_date => '2005-01-01 10:15:00',
724            to_date => '2005-01-01 12:00:00',
725            message => 0,
726     );
727    
728    If don't specify C<list> or C<email> it will return all received messages.
729    Results will be sorted by received date, oldest first.
730    
731    Other optional parametars include:
732    
733    =over 10
734    
735    =item from_date
736    
737    Date (in ISO format) for lower limit of dates received
738    
739    =item to_date
740    
741    Return just messages older than this date
742    
743    =item message
744    
745    Include whole received message in result. This will probably make result
746    array very large. Use with care.
747    
748    =back
749    
750    Date ranges are inclusive, so results will include messages sent on
751    particular date specified with C<date_from> or C<date_to>.
752    
753    Each element in returned array will have following structure:
754    
755     my $row = {
756            id => 42,                       # unique ID of received message
757            list => 'My list',              # useful if filtering by email
758            ext_id => 9999,                 # ext_id from message sender
759            email => 'jdoe@example.com',    # e-mail of message sender
760            bounced => 0,                   # true if message is bounce
761            date => '2005-08-24 18:57:24',  # date of receival in ISO format
762     }
763    
764    If you specified C<message> option, this hash will also have C<message> key
765    which will contain whole received message.
766    
767    =cut
768    
769    sub received_messages {
770            my $self = shift;
771    
772            my $arg = {@_} if (@_);
773    
774          my $m = new Email::Simple->new($message);  #       croak "need list name or email" unless ($arg->{'list'} || $arg->{'email'});
775    
776            my $sql = qq{
777                            select
778                                    received.id as id,
779                                    lists.name as list,
780                                    users.ext_id as ext_id,
781                                    users.email as email,
782            };
783            $sql .= qq{             message,} if ($arg->{'message'});
784            $sql .= qq{
785                                    bounced,received.date as date
786                            from received
787                            join lists on lists.id = list_id
788                            join users on users.id = user_id
789            };
790    
791            my $order = qq{ order by date asc };
792    
793            my $where;
794    
795            $where->{'lists.name'} = lc($arg->{'list'}) if ($arg->{'list'});
796            $where->{'users.email'} = lc($arg->{'email'}) if ($arg->{'email'});
797            $where->{'received.date'} = { '>=', $arg->{'date_from'} } if ($arg->{'date_from'});
798            $where->{'received.date'} = { '<=', $arg->{'date_to'} } if ($arg->{'date_to'});
799    
800            # hum, yammy one-liner
801            my($stmt, @bind)  = SQL::Abstract->new->where($where);
802    
803            my $dbh = $self->{'loader'}->find_class('received')->db_Main;
804    
805            my $sth = $dbh->prepare($sql . $stmt . $order);
806            $sth->execute(@bind);
807            return $sth->fetchall_hash;
808  }  }
809    
810    
# Line 287  sub inbox_message { Line 812  sub inbox_message {
812    
813  Beware of dragons! You shouldn't need to call those methods directly.  Beware of dragons! You shouldn't need to call those methods directly.
814    
815    
816    =head2 _add_aliases
817    
818    Add or update alias in C</etc/aliases> (or equivalent) file for selected list
819    
820     my $ok = $nos->add_aliases(
821            list => 'My list',
822            email => 'my-list@example.com',
823            aliases => '/etc/mail/mylist',
824            archive => '/path/to/mbox/archive',
825    
826     );
827    
828    C<archive> parametar is optional.
829    
830    Return false on failure.
831    
832    =cut
833    
834    sub _add_aliases {
835            my $self = shift;
836    
837            my $arg = {@_};
838    
839            foreach my $o (qw/list email aliases/) {
840                    croak "need $o option" unless ($arg->{$o});
841            }
842    
843            my $aliases = $arg->{'aliases'};
844            my $email = $arg->{'email'};
845            my $list = $arg->{'list'};
846    
847            unless (-e $aliases) {
848                    warn "aliases file $aliases doesn't exist, creating empty\n";
849                    open(my $fh, '>', $aliases) || croak "can't create $aliases: $!";
850                    close($fh);
851                    chmod 0777, $aliases || warn "can't change permission to 0777";
852            }
853    
854            die "FATAL: aliases file $aliases is not writable\n" unless (-w $aliases);
855    
856            my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
857    
858            my $target = '';
859    
860            if (my $archive = $arg->{'archive'}) {
861                    $target .= "$archive, ";
862    
863                    if (! -e $archive) {
864                            warn "please make sure that file $archive is writable for your e-mail user (defaulting to bad 777 permission for now)";
865    
866                            open(my $fh, '>', $archive) || croak "can't create archive file $archive: $!";
867                            close($fh);
868                            chmod 0777, $archive || croak "can't chmod archive file $archive to 0777: $!";
869                    }
870            }
871    
872            # resolve my path to absolute one
873            my $self_path = abs_path($0);
874            $self_path =~ s#/[^/]+$##;
875            $self_path =~ s#/t/*$#/#;
876    
877            $target .= qq#"| cd $self_path && ./sender.pl --inbox='$list'"#;
878    
879            # remove hostname from email to make Postfix's postalias happy
880            $email =~ s/@.+// if (not $self->{full_hostname_in_aliases});
881    
882            if ($a->exists($email)) {
883                    $a->update($email, $target) or croak "can't update alias ".$a->error_check;
884            } else {
885                    $a->append($email, $target) or croak "can't add alias ".$a->error_check;
886            }
887    
888    #       $a->write($aliases) or croak "can't save aliases $aliases ".$a->error_check;
889    
890            return 1;
891    }
892    
893  =head2 _add_list  =head2 _add_list
894    
895  Create new list  Create new list
896    
897   my $list_obj = $nos->_add_list(   my $list_obj = $nos->_add_list(
898          list => 'My list',          list => 'My list',
899            from => 'Outgoing from comment',
900          email => 'my-list@example.com',          email => 'my-list@example.com',
901            aliases => '/etc/mail/mylist',
902   );   );
903    
904  Returns C<Class::DBI> object for created list.  Returns C<Class::DBI> object for created list.
905    
906    C<email> address can be with domain or without it if your
907    MTA appends it. There is no checking for validity of your
908    list e-mail. Flexibility comes with resposibility, so please
909    feed correct (and configured) return addresses.
910    
911  =cut  =cut
912    
913  sub _add_list {  sub _add_list {
# Line 305  sub _add_list { Line 915  sub _add_list {
915    
916          my $arg = {@_};          my $arg = {@_};
917    
918          my $name = $arg->{'list'} || confess "can't add list without name";          my $name = lc($arg->{'list'}) || confess "can't add list without name";
919          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";
920            my $aliases = lc($arg->{'aliases'}) || confess "can't add list without path to aliases file";
921    
922            my $from_addr = $arg->{'from'};
923    
924          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
925    
926            $self->_add_aliases(
927                    list => $name,
928                    email => $email,
929                    aliases => $aliases,
930            ) || warn "can't add alias $email for list $name";
931    
932          my $l = $lists->find_or_create({          my $l = $lists->find_or_create({
933                  name => $name,                  name => $name,
934                  email => $email,                  email => $email,
935          });          });
936            
937          croak "can't add list $name\n" unless ($l);          croak "can't add list $name\n" unless ($l);
938    
939            if ($from_addr && $l->from_addr ne $from_addr) {
940                    $l->from_addr($from_addr);
941                    $l->update;
942            }
943    
944          $l->dbi_commit;          $l->dbi_commit;
945    
946          return $l;          return $l;
# Line 324  sub _add_list { Line 948  sub _add_list {
948  }  }
949    
950    
951    
952  =head2 _get_list  =head2 _get_list
953    
954  Get list C<Class::DBI> object.  Get list C<Class::DBI> object.
# Line 341  sub _get_list { Line 966  sub _get_list {
966    
967          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";
968    
969          return $lists->search({ name => $name })->first;          return $lists->search({ name => lc($name) })->first;
970    }
971    
972    
973    =head2 _remove_alias
974    
975    Remove list alias
976    
977     my $ok = $nos->_remove_alias(
978            email => 'mylist@example.com',
979            aliases => '/etc/mail/mylist',
980     );
981    
982    Returns true if list is removed or false if list doesn't exist. Dies in case of error.
983    
984    =cut
985    
986    sub _remove_alias {
987            my $self = shift;
988    
989            my $arg = {@_};
990    
991            my $email = lc($arg->{'email'}) || confess "can't remove alias without email";
992            my $aliases = lc($arg->{'aliases'}) || confess "can't remove alias without list";
993    
994            my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
995    
996            if ($a->exists($email)) {
997                    $a->delete($email) || croak "can't remove alias $email";
998            } else {
999                    return 0;
1000            }
1001    
1002            return 1;
1003    
1004    }
1005    
1006    ###
1007    ### SOAP
1008    ###
1009    
1010    package Nos::SOAP;
1011    
1012    use Carp;
1013    
1014    =head1 SOAP methods
1015    
1016    This methods are thin wrappers to provide SOAP calls. They are grouped in
1017    C<Nos::SOAP> package which is in same F<Nos.pm> module file.
1018    
1019    Usually, you want to use named variables in your SOAP calls if at all
1020    possible.
1021    
1022    However, if you have broken SOAP library (like PHP SOAP class from PEAR)
1023    you will want to use positional arguments (in same order as documented for
1024    methods below).
1025    
1026    =cut
1027    
1028    my $nos;
1029    
1030    
1031    =head2 new
1032    
1033    Create new SOAP object
1034    
1035     my $soap = new Nos::SOAP(
1036            dsn => 'dbi:Pg:dbname=notices',
1037            user => 'dpavlin',
1038            passwd => '',
1039            debug => 1,
1040            verbose => 1,
1041            hash_len => 8,
1042            aliases => '/etc/aliases',
1043     );
1044    
1045    If you are writing SOAP server (like C<soap.cgi> example), you will need to
1046    call this method once to make new instance of Nos::SOAP and specify C<dsn>
1047    and options for it.
1048    
1049    =cut
1050    
1051    sub new {
1052            my $class = shift;
1053            my $self = {@_};
1054    
1055            croak "need aliases parametar" unless ($self->{'aliases'});
1056    
1057            bless($self, $class);
1058    
1059            $nos = new Nos( @_ ) || die "can't create Nos object";
1060    
1061            $self ? return $self : return undef;
1062    }
1063    
1064    
1065    =head2 CreateList
1066    
1067     $message_id = CreateList(
1068            list => 'My list',
1069            from => 'Name of my list',
1070            email => 'my-list@example.com'
1071     );
1072    
1073    =cut
1074    
1075    sub CreateList {
1076            my $self = shift;
1077    
1078            my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
1079    
1080            if ($_[0] !~ m/^HASH/) {
1081                    return $nos->create_list(
1082                            list => $_[0], from => $_[1], email => $_[2],
1083                            aliases => $aliases,
1084                    );
1085            } else {
1086                    return $nos->create_list( %{ shift @_ }, aliases => $aliases );
1087            }
1088    }
1089    
1090    
1091    =head2 DropList
1092    
1093     $ok = DropList(
1094            list => 'My list',
1095     );
1096    
1097    =cut
1098    
1099    sub DropList {
1100            my $self = shift;
1101    
1102            my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
1103    
1104            if ($_[0] !~ m/^HASH/) {
1105                    return $nos->drop_list(
1106                            list => $_[0],
1107                            aliases => $aliases,
1108                    );
1109            } else {
1110                    return $nos->drop_list( %{ shift @_ }, aliases => $aliases );
1111            }
1112    }
1113    
1114    =head2 AddMemberToList
1115    
1116     $member_id = AddMemberToList(
1117            list => 'My list',
1118            email => 'e-mail@example.com',
1119            name => 'Full Name',
1120            ext_id => 42,
1121     );
1122    
1123    =cut
1124    
1125    sub AddMemberToList {
1126            my $self = shift;
1127    
1128            if ($_[0] !~ m/^HASH/) {
1129                    return $nos->add_member_to_list(
1130                            list => $_[0], email => $_[1], name => $_[2], ext_id => $_[3],
1131                    );
1132            } else {
1133                    return $nos->add_member_to_list( %{ shift @_ } );
1134            }
1135    }
1136    
1137    
1138    =head2 ListMembers
1139    
1140     my @members = ListMembers(
1141            list => 'My list',
1142     );
1143    
1144    Returns array of hashes with user informations, see C<list_members>.
1145    
1146    =cut
1147    
1148    sub ListMembers {
1149            my $self = shift;
1150    
1151            my $list_name;
1152    
1153            if ($_[0] !~ m/^HASH/) {
1154                    $list_name = shift;
1155            } else {
1156                    $list_name = $_[0]->{'list'};
1157            }
1158    
1159            return [ $nos->list_members( list => $list_name ) ];
1160  }  }
1161    
1162    
1163    =head2 DeleteMemberFromList
1164    
1165     $member_id = DeleteMemberFromList(
1166            list => 'My list',
1167            email => 'e-mail@example.com',
1168     );
1169    
1170    =cut
1171    
1172    sub DeleteMemberFromList {
1173            my $self = shift;
1174    
1175            if ($_[0] !~ m/^HASH/) {
1176                    return $nos->delete_member_from_list(
1177                            list => $_[0], email => $_[1],
1178                    );
1179            } else {
1180                    return $nos->delete_member_from_list( %{ shift @_ } );
1181            }
1182    }
1183    
1184    
1185    =head2 AddMessageToList
1186    
1187     $message_id = AddMessageToList(
1188            list => 'My list',
1189            message => 'From: My list...'
1190     );
1191    
1192    =cut
1193    
1194    sub AddMessageToList {
1195            my $self = shift;
1196    
1197            if ($_[0] !~ m/^HASH/) {
1198                    return $nos->add_message_to_list(
1199                            list => $_[0], message => $_[1],
1200                    );
1201            } else {
1202                    return $nos->add_message_to_list( %{ shift @_ } );
1203            }
1204    }
1205    
1206    =head2 MessagesReceived
1207    
1208    Return statistics about received messages.
1209    
1210     my @result = MessagesReceived(
1211            list => 'My list',
1212            email => 'jdoe@example.com',
1213            from_date => '2005-01-01 10:15:00',
1214            to_date => '2005-01-01 12:00:00',
1215            message => 0,
1216     );
1217    
1218    You must specify C<list> or C<email> or any combination of those two. Other
1219    parametars are optional.
1220    
1221    For format of returned array element see C<received_messages>.
1222    
1223    =cut
1224    
1225    sub MessagesReceived {
1226            my $self = shift;
1227    
1228            if ($_[0] !~ m/^HASH/) {
1229                    die "need at least list or email" unless (scalar @_ < 2);
1230                    return \@{ $nos->received_messages(
1231                            list => $_[0], email => $_[1],
1232                            from_date => $_[2], to_date => $_[3],
1233                            message => $_[4]
1234                    ) };
1235            } else {
1236                    my $arg = shift;
1237                    die "need list or email argument" unless ($arg->{'list'} || $arg->{'email'});
1238                    return \@{ $nos->received_messages( %{ $arg } ) };
1239            }
1240    }
1241    
1242    =head2 SendTest
1243    
1244    Internal function which does e-mail sending using C<Email::Send::Test> driver.
1245    
1246      my $sent = SendTest( list => 'My list' );
1247    
1248    Returns number of messages sent
1249    
1250    =cut
1251    
1252    sub SendTest {
1253            my $self = shift;
1254            my $args = shift;
1255            die "list name required" unless ($args->{list});
1256    
1257            require Email::Send::Test;
1258    
1259            my $nr_sent = $nos->send_queued_messages(
1260                    list => $args->{list},
1261                    driver => 'Test',
1262                    sleep => 0,
1263                    verbose => 0,
1264            );
1265    
1266            my @emails = Email::Send::Test->emails;
1267    
1268            open(my $tmp, ">/tmp/soap-debug");
1269            use Data::Dump qw/dump/;
1270            print $tmp "sent $nr_sent emails\n", dump(@emails);
1271            close($tmp);
1272    
1273            return $nr_sent;
1274    }
1275    
1276    ###
1277    
1278    =head1 NOTE ON ARRAYS IN SOAP
1279    
1280    Returning arrays from SOAP calls is somewhat fuzzy (at least to me). It
1281    seems that SOAP::Lite client thinks that it has array with one element which
1282    is array of hashes with data.
1283    
1284  =head1 EXPORT  =head1 EXPORT
1285    
1286  Nothing.  Nothing.
# Line 369  at your option, any later version of Per Line 1305  at your option, any later version of Per
1305    
1306    
1307  =cut  =cut
1308    
1309    1;
Legend:
Removed from v.32  
changed lines
  Added in v.93
  ViewVC Help
Powered by ViewVC 1.1.26