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