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