/[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 79 by dpavlin, Thu Aug 25 11:58:15 2005 UTC
# Line 16  our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all' Line 16  our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'
16  our @EXPORT = qw(  our @EXPORT = qw(
17  );  );
18    
19  our $VERSION = '0.3';  our $VERSION = '0.8';
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   );   );
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 68  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 85  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 member ID if user is added.  Return member ID if user is added.
212    
# Line 98  sub add_member_to_list { Line 217  sub add_member_to_list {
217    
218          my $arg = {@_};          my $arg = {@_};
219    
220          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";
221          my $name = $arg->{'name'} || '';          my $name = $arg->{'name'} || '';
222          my $list_name = $arg->{'list'} || croak "need list name";          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";          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                  carp "SKIPPING $name <$email>\n" if ($self->{'verbose'});                  carp "SKIPPING $name <$email>\n";
229                  return 0;                  return 0;
230          }          }
231    
# Line 116  sub add_member_to_list { Line 236  sub add_member_to_list {
236    
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 131  sub add_member_to_list { Line 260  sub add_member_to_list {
260          return $this_user->id;          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_list  =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_list(   $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_list {  sub add_message_to_list {
# Line 153  sub add_message_to_list { Line 416  sub add_message_to_list {
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";          my $m = Email::Simple->new($message_text) || croak "can't parse message";
# Line 194  sub add_message_to_list { Line 457  sub add_message_to_list {
457    
458  Send queued messages or just ones for selected list  Send queued messages or just ones for selected list
459    
460   $nos->send_queued_messages("My list");   $nos->send_queued_messages(
461            list => 'My list',
462            driver => 'smtp',
463            sleep => 3,
464     );
465    
466    Second option is driver which will be used for e-mail delivery. If not
467    specified, C<IO> driver will be used which will dump e-mail to C<STDERR>.
468    
469    Other valid drivers are:
470    
471    =over 10
472    
473    =item smtp
474    
475    Send e-mail using SMTP server at 127.0.0.1
476    
477    =back
478    
479    Any other driver name will try to use C<Email::Send::that_driver> module.
480    
481    Default sleep wait between two messages is 3 seconds.
482    
483    This method will return number of succesfully sent messages.
484    
485  =cut  =cut
486    
487  sub send_queued_messages {  sub send_queued_messages {
488          my $self = shift;          my $self = shift;
489    
490          my $list_name = shift;          my $arg = {@_};
491    
492            my $list_name = lc($arg->{'list'}) || '';
493            my $driver = $arg->{'driver'} || '';
494            my $sleep = $arg->{'sleep'};
495            $sleep ||= 3 unless defined($sleep);
496    
497            # number of messages sent o.k.
498            my $ok = 0;
499    
500            my $email_send_driver = 'Email::Send::IO';
501            my @email_send_options;
502    
503            if (lc($driver) eq 'smtp') {
504                    $email_send_driver = 'Email::Send::SMTP';
505                    @email_send_options = ['127.0.0.1'];
506            } elsif ($driver && $driver ne '') {
507                    $email_send_driver = 'Email::Send::' . $driver;
508            } else {
509                    warn "dumping all messages to STDERR\n";
510            }
511    
512          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
513          my $queue = $self->{'loader'}->find_class('queue');          my $queue = $self->{'loader'}->find_class('queue');
# Line 233  sub send_queued_messages { Line 539  sub send_queued_messages {
539                          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 )) {
540                                  print "SKIP $to_email message allready sent\n";                                  print "SKIP $to_email message allready sent\n";
541                          } else {                          } else {
542                                  print "=> $to_email\n";                                  print "=> $to_email ";
543    
544                                  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;
545                                  my $auth = Email::Auth::AddressHash->new( $secret, 10 );                                  my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
546    
547                                  my $hash = $auth->generate_hash( $to_email );                                  my $hash = $auth->generate_hash( $to_email );
548    
549                                  my $from = $u->list_id->name . " <" . $from . "+" . $hash . ( $domain ? "@" . $domain : '' ). ">";                                  my $from_addr;
550                                  my $to = $u->user_id->full_name . " <$to_email>";                                  my $from_email_only = $from . "+" . $hash . ( $domain ? '@' . $domain : '');
551    
552                                    $from_addr .= '"' . $u->list_id->from_addr . '" ' if ($u->list_id->from_addr);
553                                    $from_addr .= '<' . $from_email_only . '>';
554                                    my $to = '"' . $u->user_id->name . '" <' . $to_email . '>';
555    
556                                  my $m_obj = Email::Simple->new($msg) || croak "can't parse message";                                  my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
557    
558                                  $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";
559                                    $m_obj->header_set('Sender', $from_email_only) || croak "can't set Sender: header";
560                                    $m_obj->header_set('Errors-To', $from_email_only) || croak "can't set Errors-To: header";
561                                    $m_obj->header_set('From', $from_addr) || croak "can't set From: header";
562                                  $m_obj->header_set('To', $to) || croak "can't set To: header";                                  $m_obj->header_set('To', $to) || croak "can't set To: header";
563    
564                                  # FIXME do real sending :-)                                  $m_obj->header_set('X-Nos-Version', $VERSION);
565                                  send IO => $m_obj->as_string;                                  $m_obj->header_set('X-Nos-Hash', $hash);
566    
567                                    # really send e-mail
568                                    my $sent_status;
569    
570                                  $sent->create({                                  if (@email_send_options) {
571                                          message_id => $m->message_id,                                          $sent_status = send $email_send_driver => $m_obj->as_string, @email_send_options;
572                                          user_id => $u->user_id,                                  } else {
573                                  });                                          $sent_status = send $email_send_driver => $m_obj->as_string;
574                                  $sent->dbi_commit;                                  }
575    
576                                    croak "can't send e-mail: $sent_status\n\nOriginal e-mail follows:\n".$m_obj->as_string unless ($sent_status);
577                                    my @bad;
578                                    @bad = @{ $sent_status->prop('bad') } if (eval { $sent_status->can('prop') });
579                                    croak "failed sending to ",join(",",@bad) if (@bad);
580    
581                                    if ($sent_status) {
582    
583                                            $sent->create({
584                                                    message_id => $m->message_id,
585                                                    user_id => $u->user_id,
586                                                    hash => $hash,
587                                            });
588                                            $sent->dbi_commit;
589    
590                                            print " - $sent_status\n";
591    
592                                            $ok++;
593                                    } else {
594                                            warn "ERROR: $sent_status\n";
595                                    }
596    
597                                    if ($sleep) {
598                                            warn "sleeping $sleep seconds\n";
599                                            sleep($sleep);
600                                    }
601                          }                          }
602                  }                  }
603                  $m->all_sent(1);                  $m->all_sent(1);
# Line 263  sub send_queued_messages { Line 605  sub send_queued_messages {
605                  $m->dbi_commit;                  $m->dbi_commit;
606          }          }
607    
608            return $ok;
609    
610  }  }
611    
612  =head2 inbox_message  =head2 inbox_message
613    
614  Receive single message for list's inbox.  Receive single message for list's inbox.
615    
616   my $ok = $nos->inbox_message($message);   my $ok = $nos->inbox_message(
617            list => 'My list',
618            message => $message,
619     );
620    
621    This method is used by C<sender.pl> when receiving e-mail messages.
622    
623  =cut  =cut
624    
625  sub inbox_message {  sub inbox_message {
626          my $self = shift;          my $self = shift;
627    
628          my $message = shift || return;          my $arg = {@_};
629    
630            return unless ($arg->{'message'});
631            croak "need list name" unless ($arg->{'list'});
632    
633            $arg->{'list'} = lc($arg->{'list'});
634    
635            my $this_list = $self->_get_list($arg->{'list'}) || croak "can't find list ".$arg->{'list'}."\n";
636    
637            my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message";
638    
639            my $to = $m->header('To') || die "can't find To: address in incomming message\n";
640    
641            my $return_path = $m->header('Return-Path') || '';
642    
643            my @addrs = Email::Address->parse( $to );
644    
645            die "can't parse To: $to address\n" unless (@addrs);
646    
647            my $hl = $self->{'hash_len'} || confess "no hash_len?";
648    
649            my $hash;
650    
651            foreach my $a (@addrs) {
652                    if ($a->address =~ m/\+([a-f0-9]{$hl})@/i) {
653                            $hash = $1;
654                            last;
655                    }
656            }
657    
658            #warn "can't find hash in e-mail $to\n" unless ($hash);
659    
660            my $sent = $self->{'loader'}->find_class('sent');
661    
662            # will use null if no matching message_id is found
663            my $sent_msg;
664            $sent_msg = $sent->search( hash => $hash )->first if ($hash);
665    
666            my ($message_id, $user_id) = (undef, undef);    # init with NULL
667    
668            if ($sent_msg) {
669                    $message_id = $sent_msg->message_id || carp "no message_id";
670                    $user_id = $sent_msg->user_id || carp "no user_id";
671            } else {
672                    #warn "can't find sender with hash $hash\n";
673                    my $users = $self->{'loader'}->find_class('users');
674                    my $from = $m->header('From');
675                    $from = $1 if ($from =~ m/<(.*)>/);
676                    my $this_user = $users->search( email => lc($from) )->first;
677                    $user_id = $this_user->id if ($this_user);
678            }
679    
680    
681            my $is_bounce = 0;
682    
683            if ($return_path eq '<>' || $return_path eq '') {
684                    no warnings;
685                    my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
686                            $arg->{'message'}, { report_non_bounces=>1 },
687                    ) };
688                    #warn "can't check if this message is bounce!" if ($@);
689            
690                    $is_bounce++ if ($bounce && $bounce->is_bounce);
691            }
692    
693            my $received = $self->{'loader'}->find_class('received');
694    
695            my $this_received = $received->find_or_create({
696                    user_id => $user_id,
697                    list_id => $this_list->id,
698                    message_id => $message_id,
699                    message => $arg->{'message'},
700                    bounced => $is_bounce,
701            }) || croak "can't insert received message";
702    
703            $this_received->dbi_commit;
704    
705    #       print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
706    }
707    
708    =head2 received_messages
709    
710    Returns all received messages for given list or user.
711    
712     my @received = $nos->received_message(
713            list => 'My list',
714            email => "john.doe@example.com",
715     );
716    
717    Each element in returned array will have following structure:
718    
719     {
720            id => 42,                       # unique ID of received message
721            list => 'My list',              # useful if filtering by email
722            ext_id => 9999,                 # ext_id from message sender
723            email => 'jdoe@example.com',    # e-mail of message sender
724            bounced => 0,                   # true if message is bounce
725            date => '2005-08-24 18:57:24',  # date of receival in ISO format
726     }
727    
728    
729    =cut
730    
731    sub received_messages {
732            my $self = shift;
733    
734            my $arg = {@_} if (@_);
735    
736          my $m = new Email::Simple->new($message);  #       croak "need list name or email" unless ($arg->{'list'} || $arg->{'email'});
737    
738            my $sql = qq{
739                            select
740                                    received.id as id,
741                                    lists.name as list,
742                                    users.ext_id as ext_id,
743                                    users.email as email,
744                                    bounced,received.date as date
745                            from received
746                            join lists on lists.id = list_id
747                            join users on users.id = user_id
748            };
749    
750            my $where;
751    
752            $where->{'lists.name'} = lc($arg->{'list'}) if ($arg->{'list'});
753            $where->{'users.email'} = lc($arg->{'email'}) if ($arg->{'email'});
754    
755            # hum, yammy one-liner
756            my($stmt, @bind)  = SQL::Abstract->new->where($where);
757    
758            my $dbh = $self->{'loader'}->find_class('received')->db_Main;
759    
760            my $sth = $dbh->prepare($sql . $stmt);
761            $sth->execute(@bind);
762            return $sth->fetchall_hash;
763  }  }
764    
765    
# Line 287  sub inbox_message { Line 767  sub inbox_message {
767    
768  Beware of dragons! You shouldn't need to call those methods directly.  Beware of dragons! You shouldn't need to call those methods directly.
769    
770    
771    =head2 _add_aliases
772    
773    Add or update alias in C</etc/aliases> (or equivalent) file for selected list
774    
775     my $ok = $nos->add_aliases(
776            list => 'My list',
777            email => 'my-list@example.com',
778            aliases => '/etc/mail/mylist',
779            archive => '/path/to/mbox/archive',
780    
781     );
782    
783    C<archive> parametar is optional.
784    
785    Return false on failure.
786    
787    =cut
788    
789    sub _add_aliases {
790            my $self = shift;
791    
792            my $arg = {@_};
793    
794            foreach my $o (qw/list email aliases/) {
795                    croak "need $o option" unless ($arg->{$o});
796            }
797    
798            my $aliases = $arg->{'aliases'};
799            my $email = $arg->{'email'};
800            my $list = $arg->{'list'};
801    
802            unless (-e $aliases) {
803                    warn "aliases file $aliases doesn't exist, creating empty\n";
804                    open(my $fh, '>', $aliases) || croak "can't create $aliases: $!";
805                    close($fh);
806                    chmod 0777, $aliases || warn "can't change permission to 0777";
807            }
808    
809            die "FATAL: aliases file $aliases is not writable\n" unless (-w $aliases);
810    
811            my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
812    
813            my $target = '';
814    
815            if (my $archive = $arg->{'archive'}) {
816                    $target .= "$archive, ";
817    
818                    if (! -e $archive) {
819                            warn "please make sure that file $archive is writable for your e-mail user (defaulting to bad 777 permission for now)";
820    
821                            open(my $fh, '>', $archive) || croak "can't create archive file $archive: $!";
822                            close($fh);
823                            chmod 0777, $archive || croak "can't chmod archive file $archive to 0777: $!";
824                    }
825            }
826    
827            # resolve my path to absolute one
828            my $self_path = abs_path($0);
829            $self_path =~ s#/[^/]+$##;
830            $self_path =~ s#/t/*$#/#;
831    
832            $target .= qq#| cd $self_path && ./sender.pl --inbox="$list"#;
833    
834            if ($a->exists($email)) {
835                    $a->update($email, $target) or croak "can't update alias ".$a->error_check;
836            } else {
837                    $a->append($email, $target) or croak "can't add alias ".$a->error_check;
838            }
839    
840            #$a->write($aliases) or croak "can't save aliases $aliases ".$a->error_check;
841    
842            return 1;
843    }
844    
845  =head2 _add_list  =head2 _add_list
846    
847  Create new list  Create new list
848    
849   my $list_obj = $nos->_add_list(   my $list_obj = $nos->_add_list(
850          list => 'My list',          list => 'My list',
851            from => 'Outgoing from comment',
852          email => 'my-list@example.com',          email => 'my-list@example.com',
853            aliases => '/etc/mail/mylist',
854   );   );
855    
856  Returns C<Class::DBI> object for created list.  Returns C<Class::DBI> object for created list.
857    
858    C<email> address can be with domain or without it if your
859    MTA appends it. There is no checking for validity of your
860    list e-mail. Flexibility comes with resposibility, so please
861    feed correct (and configured) return addresses.
862    
863  =cut  =cut
864    
865  sub _add_list {  sub _add_list {
# Line 305  sub _add_list { Line 867  sub _add_list {
867    
868          my $arg = {@_};          my $arg = {@_};
869    
870          my $name = $arg->{'list'} || confess "can't add list without name";          my $name = lc($arg->{'list'}) || confess "can't add list without name";
871          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";
872            my $aliases = lc($arg->{'aliases'}) || confess "can't add list without path to aliases file";
873    
874            my $from_addr = $arg->{'from'};
875    
876          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
877    
878            $self->_add_aliases(
879                    list => $name,
880                    email => $email,
881                    aliases => $aliases,
882            ) || warn "can't add alias $email for list $name";
883    
884          my $l = $lists->find_or_create({          my $l = $lists->find_or_create({
885                  name => $name,                  name => $name,
886                  email => $email,                  email => $email,
887          });          });
888            
889          croak "can't add list $name\n" unless ($l);          croak "can't add list $name\n" unless ($l);
890    
891            if ($from_addr && $l->from_addr ne $from_addr) {
892                    $l->from_addr($from_addr);
893                    $l->update;
894            }
895    
896          $l->dbi_commit;          $l->dbi_commit;
897    
898          return $l;          return $l;
# Line 324  sub _add_list { Line 900  sub _add_list {
900  }  }
901    
902    
903    
904  =head2 _get_list  =head2 _get_list
905    
906  Get list C<Class::DBI> object.  Get list C<Class::DBI> object.
# Line 341  sub _get_list { Line 918  sub _get_list {
918    
919          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";
920    
921          return $lists->search({ name => $name })->first;          return $lists->search({ name => lc($name) })->first;
922  }  }
923    
924    
925    =head2 _remove_alias
926    
927    Remove list alias
928    
929     my $ok = $nos->_remove_alias(
930            email => 'mylist@example.com',
931            aliases => '/etc/mail/mylist',
932     );
933    
934    Returns true if list is removed or false if list doesn't exist. Dies in case of error.
935    
936    =cut
937    
938    sub _remove_alias {
939            my $self = shift;
940    
941            my $arg = {@_};
942    
943            my $email = lc($arg->{'email'}) || confess "can't remove alias without email";
944            my $aliases = lc($arg->{'aliases'}) || confess "can't remove alias without list";
945    
946            my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
947    
948            if ($a->exists($email)) {
949                    $a->delete($email) || croak "can't remove alias $email";
950            } else {
951                    return 0;
952            }
953    
954            return 1;
955    
956    }
957    
958    ###
959    ### SOAP
960    ###
961    
962    package Nos::SOAP;
963    
964    use Carp;
965    
966    =head1 SOAP methods
967    
968    This methods are thin wrappers to provide SOAP calls. They are grouped in
969    C<Nos::SOAP> package which is in same F<Nos.pm> module file.
970    
971    Usually, you want to use named variables in your SOAP calls if at all
972    possible.
973    
974    However, if you have broken SOAP library (like PHP SOAP class from PEAR)
975    you will want to use positional arguments (in same order as documented for
976    methods below).
977    
978    =cut
979    
980    my $nos;
981    
982    
983    =head2 new
984    
985    Create new SOAP object
986    
987     my $soap = new Nos::SOAP(
988            dsn => 'dbi:Pg:dbname=notices',
989            user => 'dpavlin',
990            passwd => '',
991            debug => 1,
992            verbose => 1,
993            hash_len => 8,
994            aliases => '/etc/aliases',
995     );
996    
997    If you are writing SOAP server (like C<soap.cgi> example), you will need to
998    call this method once to make new instance of Nos::SOAP and specify C<dsn>
999    and options for it.
1000    
1001    =cut
1002    
1003    sub new {
1004            my $class = shift;
1005            my $self = {@_};
1006    
1007            croak "need aliases parametar" unless ($self->{'aliases'});
1008    
1009            bless($self, $class);
1010    
1011            $nos = new Nos( @_ ) || die "can't create Nos object";
1012    
1013            $self ? return $self : return undef;
1014    }
1015    
1016    
1017    =head2 CreateList
1018    
1019     $message_id = CreateList(
1020            list => 'My list',
1021            from => 'Name of my list',
1022            email => 'my-list@example.com'
1023     );
1024    
1025    =cut
1026    
1027    sub CreateList {
1028            my $self = shift;
1029    
1030            my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
1031    
1032            if ($_[0] !~ m/^HASH/) {
1033                    return $nos->create_list(
1034                            list => $_[0], from => $_[1], email => $_[2],
1035                            aliases => $aliases,
1036                    );
1037            } else {
1038                    return $nos->create_list( %{ shift @_ }, aliases => $aliases );
1039            }
1040    }
1041    
1042    
1043    =head2 DropList
1044    
1045     $ok = DropList(
1046            list => 'My list',
1047     );
1048    
1049    =cut
1050    
1051    sub DropList {
1052            my $self = shift;
1053    
1054            my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
1055    
1056            if ($_[0] !~ m/^HASH/) {
1057                    return $nos->drop_list(
1058                            list => $_[0],
1059                            aliases => $aliases,
1060                    );
1061            } else {
1062                    return $nos->drop_list( %{ shift @_ }, aliases => $aliases );
1063            }
1064    }
1065    
1066    =head2 AddMemberToList
1067    
1068     $member_id = AddMemberToList(
1069            list => 'My list',
1070            email => 'e-mail@example.com',
1071            name => 'Full Name',
1072            ext_id => 42,
1073     );
1074    
1075    =cut
1076    
1077    sub AddMemberToList {
1078            my $self = shift;
1079    
1080            if ($_[0] !~ m/^HASH/) {
1081                    return $nos->add_member_to_list(
1082                            list => $_[0], email => $_[1], name => $_[2], ext_id => $_[4],
1083                    );
1084            } else {
1085                    return $nos->add_member_to_list( %{ shift @_ } );
1086            }
1087    }
1088    
1089    
1090    =head2 ListMembers
1091    
1092     my @members = ListMembers(
1093            list => 'My list',
1094     );
1095    
1096    Returns array of hashes with user informations, see C<list_members>.
1097    
1098    =cut
1099    
1100    sub ListMembers {
1101            my $self = shift;
1102    
1103            my $list_name;
1104    
1105            if ($_[0] !~ m/^HASH/) {
1106                    $list_name = shift;
1107            } else {
1108                    $list_name = $_[0]->{'list'};
1109            }
1110    
1111            return [ $nos->list_members( list => $list_name ) ];
1112    }
1113    
1114    
1115    =head2 DeleteMemberFromList
1116    
1117     $member_id = DeleteMemberFromList(
1118            list => 'My list',
1119            email => 'e-mail@example.com',
1120     );
1121    
1122    =cut
1123    
1124    sub DeleteMemberFromList {
1125            my $self = shift;
1126    
1127            if ($_[0] !~ m/^HASH/) {
1128                    return $nos->delete_member_from_list(
1129                            list => $_[0], email => $_[1],
1130                    );
1131            } else {
1132                    return $nos->delete_member_from_list( %{ shift @_ } );
1133            }
1134    }
1135    
1136    
1137    =head2 AddMessageToList
1138    
1139     $message_id = AddMessageToList(
1140            list => 'My list',
1141            message => 'From: My list...'
1142     );
1143    
1144    =cut
1145    
1146    sub AddMessageToList {
1147            my $self = shift;
1148    
1149            if ($_[0] !~ m/^HASH/) {
1150                    return $nos->add_message_to_list(
1151                            list => $_[0], message => $_[1],
1152                    );
1153            } else {
1154                    return $nos->add_message_to_list( %{ shift @_ } );
1155            }
1156    }
1157    
1158    =head2 MessagesReceived
1159    
1160    Return statistics about received messages.
1161    
1162     my @result = MessagesReceived(
1163            list => 'My list',
1164            email => 'jdoe@example.com',
1165     );
1166    
1167    You must specify C<list> or C<email> or any combination of those.
1168    
1169    For format of returned array element see C<received_messages>.
1170    
1171    =cut
1172    
1173    sub MessagesReceived {
1174            my $self = shift;
1175    
1176            if ($_[0] !~ m/^HASH/) {
1177                    die "need at least list or email" unless (scalar @_ < 2);
1178                    return $nos->received_messages(
1179                            list => $_[0], email => $_[1],
1180                    );
1181            } else {
1182                    my $arg = shift;
1183                    die "need list or email argument" unless ($arg->{'list'} || $arg->{'email'});
1184                    return $nos->received_messages( $arg );
1185            }
1186    }
1187    
1188    ###
1189    
1190    =head1 UNIMPLEMENTED SOAP FUNCTIONS
1191    
1192    This is a stub for documentation of unimplemented functions.
1193    
1194    =head2 MessagesReceivedByDate
1195    
1196    =head2 MessagesReceivedByDateWithContent
1197    
1198    =head2 ReceivedMessageContent
1199    
1200    Return content of received message.
1201    
1202     my $mail_body = ReceivedMessageContent( id => 42 );
1203    
1204    
1205    
1206    
1207    =head1 NOTE ON ARRAYS IN SOAP
1208    
1209    Returning arrays from SOAP calls is somewhat fuzzy (at least to me). It
1210    seems that SOAP::Lite client thinks that it has array with one element which
1211    is array of hashes with data.
1212    
1213  =head1 EXPORT  =head1 EXPORT
1214    
1215  Nothing.  Nothing.
# Line 369  at your option, any later version of Per Line 1234  at your option, any later version of Per
1234    
1235    
1236  =cut  =cut
1237    
1238    1;
Legend:
Removed from v.32  
changed lines
  Added in v.79
  ViewVC Help
Powered by ViewVC 1.1.26