/[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

trunk/lib/Nos.pm revision 20 by dpavlin, Sun May 15 21:19:26 2005 UTC trunk/Nos.pm revision 75 by dpavlin, Wed Aug 24 21:27:40 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.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 Mail::Alias;
31    use Cwd qw(abs_path);
32    
33    
34  =head1 NAME  =head1 NAME
35    
# Line 34  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 48  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 57  sub new { Line 101  sub new {
101          my $self = {@_};          my $self = {@_};
102          bless($self, $class);          bless($self, $class);
103    
104            croak "need at least dsn" unless ($self->{'dsn'});
105    
106          $self->{'loader'} = Class::DBI::Loader->new(          $self->{'loader'} = Class::DBI::Loader->new(
107                  debug           => $self->{'debug'},                  debug           => $self->{'debug'},
108                  dsn             => $self->{'dsn'},                  dsn             => $self->{'dsn'},
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";
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    
 =head2 AUTOLOAD  
136    
137  Returns class from L<Class::DBI>.  =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
212    
213    Add new member to list
214    
215     $nos->add_member_to_list(
216            list => "My list",
217            email => "john.doe@example.com",
218            name => "John A. Doe",
219            ext_id => 42,
220     );
221    
222    C<name> and C<ext_id> parametars are optional.
223    
224    Return member ID if user is added.
225    
226    =cut
227    
228    sub add_member_to_list {
229            my $self = shift;
230    
231            my $arg = {@_};
232    
233            my $email = lc($arg->{'email'}) || croak "can't add user without e-mail";
234            my $name = $arg->{'name'} || '';
235            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";
239    
240            if (! Email::Valid->address($email)) {
241                    carp "SKIPPING $name <$email>\n";
242                    return 0;
243            }
244    
245            carp "# $name <$email>\n" if ($self->{'verbose'});
246    
247            my $users = $self->{'loader'}->find_class('users');
248            my $user_list = $self->{'loader'}->find_class('user_list');
249    
250            my $this_user = $users->find_or_create({
251                    email => $email,
252            }) || 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({
265                    user_id => $this_user->id,
266                    list_id => $list->id,
267            }) || croak "can't add user to list";
268    
269            $list->dbi_commit;
270            $this_user->dbi_commit;
271            $user_on_list->dbi_commit;
272    
273            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
408    
409    Adds message to one list's queue for later sending.
410    
411     $nos->add_message_to_list(
412            list => 'My list',
413            message => 'Subject: welcome to list
414    
415     This is example message
416     ',
417     );    
418    
419    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
426    
427    sub add_message_to_list {
428            my $self = shift;
429    
430            my $args = {@_};
431    
432            my $list_name = lc($args->{'list'}) || confess "need list name";
433            my $message_text = $args->{'message'} || croak "need message";
434    
435            my $m = Email::Simple->new($message_text) || croak "can't parse message";
436    
437            unless( $m->header('Subject') ) {
438                    warn "message doesn't have Subject header\n";
439                    return;
440            }
441    
442            my $lists = $self->{'loader'}->find_class('lists');
443    
444            my $this_list = $lists->search(
445                    name => $list_name,
446            )->first || croak "can't find list $list_name";
447    
448            my $messages = $self->{'loader'}->find_class('messages');
449    
450            my $this_message = $messages->find_or_create({
451                    message => $message_text
452            }) || croak "can't insert message";
453    
454            $this_message->dbi_commit() || croak "can't add message";
455    
456            my $queue = $self->{'loader'}->find_class('queue');
457    
458            $queue->find_or_create({
459                    message_id => $this_message->id,
460                    list_id => $this_list->id,
461            }) || croak "can't add message ",$this_message->id," to list ",$this_list->id, ": ",$this_list->name;
462    
463            $queue->dbi_commit || croak "can't add message to list ",$this_list->name;
464    
465            return $this_message->id;
466    }
467    
468    
469    =head2 send_queued_messages
470    
471    Send queued messages or just ones for selected list
472    
473     $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
499    
500    sub send_queued_messages {
501            my $self = shift;
502    
503            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');
526            my $queue = $self->{'loader'}->find_class('queue');
527            my $user_list = $self->{'loader'}->find_class('user_list');
528            my $sent = $self->{'loader'}->find_class('sent');
529    
530            my $my_q;
531            if ($list_name ne '') {
532                    my $l_id = $lists->search_like( name => $list_name )->first ||
533                            croak "can't find list $list_name";
534                    $my_q = $queue->search_like( list_id => $l_id ) ||
535                            croak "can't find list $list_name";
536            } else {
537                    $my_q = $queue->retrieve_all;
538            }
539    
540            while (my $m = $my_q->next) {
541                    next if ($m->all_sent);
542    
543                    print "sending message ",$m->message_id," enqueued on ",$m->date," to list ",$m->list_id->name,"\n";
544                    my $msg = $m->message_id->message;
545    
546                    foreach my $u ($user_list->search(list_id => $m->list_id)) {
547    
548                            my $to_email = $u->user_id->email;
549    
550                            my ($from,$domain) = split(/@/, $u->list_id->email, 2);
551    
552                            if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {
553                                    print "SKIP $to_email message allready sent\n";
554                            } else {
555                                    print "=> $to_email ";
556    
557                                    my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;
558                                    my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
559    
560                                    my $hash = $auth->generate_hash( $to_email );
561    
562                                    my $from_addr;
563                                    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";
570    
571                                    $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";
576    
577                                    $m_obj->header_set('X-Nos-Version', $VERSION);
578                                    $m_obj->header_set('X-Nos-Hash', $hash);
579    
580                                    # really send e-mail
581                                    my $sent_status;
582    
583                                    if (@email_send_options) {
584                                            $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);
617                    $m->update;
618                    $m->dbi_commit;
619            }
620    
621            return $ok;
622    
623    }
624    
625    =head2 inbox_message
626    
627    Receive single message for list's inbox.
628    
629     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
637    
638    sub inbox_message {
639            my $self = shift;
640    
641            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    This method is used by C<sender.pl> when receiving e-mail messages.
731    
732    =cut
733    
734    sub received_messages {
735            my $self = shift;
736    
737            my $arg = {@_};
738    
739            croak "need list name or email" unless ($arg->{'list'} || $arg->{'email'});
740    
741            $arg->{'list'} = lc($arg->{'list'});
742            $arg->{'email'} = lc($arg->{'email'});
743    
744            my $rcvd = $self->{'loader'}->find_class('received')->search_received();
745    
746            return $rcvd;
747    }
748    
749    
750    =head1 INTERNAL METHODS
751    
752    Beware of dragons! You shouldn't need to call those methods directly.
753    
754    
755    =head2 _add_aliases
756    
757    Add or update alias in C</etc/aliases> (or equivalent) file for selected list
758    
759     my $ok = $nos->add_aliases(
760            list => 'My list',
761            email => 'my-list@example.com',
762            aliases => '/etc/mail/mylist',
763            archive => '/path/to/mbox/archive',
764    
765     );
766    
767    C<archive> parametar is optional.
768    
769    Return false on failure.
770    
771    =cut
772    
773    sub _add_aliases {
774            my $self = shift;
775    
776            my $arg = {@_};
777    
778            foreach my $o (qw/list email aliases/) {
779                    croak "need $o option" unless ($arg->{$o});
780            }
781    
782            my $aliases = $arg->{'aliases'};
783            my $email = $arg->{'email'};
784            my $list = $arg->{'list'};
785    
786            unless (-e $aliases) {
787                    warn "aliases file $aliases doesn't exist, creating empty\n";
788                    open(my $fh, '>', $aliases) || croak "can't create $aliases: $!";
789                    close($fh);
790                    chmod 0777, $aliases || warn "can't change permission to 0777";
791            }
792    
793            die "FATAL: aliases file $aliases is not writable\n" unless (-w $aliases);
794    
795            my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
796    
797            my $target = '';
798    
799            if (my $archive = $arg->{'archive'}) {
800                    $target .= "$archive, ";
801    
802                    if (! -e $archive) {
803                            warn "please make sure that file $archive is writable for your e-mail user (defaulting to bad 777 permission for now)";
804    
805                            open(my $fh, '>', $archive) || croak "can't create archive file $archive: $!";
806                            close($fh);
807                            chmod 0777, $archive || croak "can't chmod archive file $archive to 0777: $!";
808                    }
809            }
810    
811            # resolve my path to absolute one
812            my $self_path = abs_path($0);
813            $self_path =~ s#/[^/]+$##;
814            $self_path =~ s#/t/*$#/#;
815    
816            $target .= qq#| cd $self_path && ./sender.pl --inbox="$list"#;
817    
818            if ($a->exists($email)) {
819                    $a->update($email, $target) or croak "can't update alias ".$a->error_check;
820            } else {
821                    $a->append($email, $target) or croak "can't add alias ".$a->error_check;
822            }
823    
824            #$a->write($aliases) or croak "can't save aliases $aliases ".$a->error_check;
825    
826            return 1;
827    }
828    
829    =head2 _add_list
830    
831    Create new list
832    
833     my $list_obj = $nos->_add_list(
834            list => 'My list',
835            from => 'Outgoing from comment',
836            email => 'my-list@example.com',
837            aliases => '/etc/mail/mylist',
838     );
839    
840    Returns C<Class::DBI> object for created list.
841    
842    C<email> address can be with domain or without it if your
843    MTA appends it. There is no checking for validity of your
844    list e-mail. Flexibility comes with resposibility, so please
845    feed correct (and configured) return addresses.
846    
847    =cut
848    
849    sub _add_list {
850            my $self = shift;
851    
852            my $arg = {@_};
853    
854            my $name = lc($arg->{'list'}) || confess "can't add list without name";
855            my $email = lc($arg->{'email'}) || confess "can't add list without e-mail";
856            my $aliases = lc($arg->{'aliases'}) || confess "can't add list without path to aliases file";
857    
858            my $from_addr = $arg->{'from'};
859    
860            my $lists = $self->{'loader'}->find_class('lists');
861    
862            $self->_add_aliases(
863                    list => $name,
864                    email => $email,
865                    aliases => $aliases,
866            ) || warn "can't add alias $email for list $name";
867    
868            my $l = $lists->find_or_create({
869                    name => $name,
870                    email => $email,
871            });
872    
873            croak "can't add list $name\n" unless ($l);
874    
875            if ($from_addr && $l->from_addr ne $from_addr) {
876                    $l->from_addr($from_addr);
877                    $l->update;
878            }
879    
880            $l->dbi_commit;
881    
882            return $l;
883    
884    }
885    
886    
887    
888    =head2 _get_list
889    
890    Get list C<Class::DBI> object.
891    
892     my $list_obj = $nos->check_list('My list');
893    
894    Returns false on failure.
895    
896    =cut
897    
898    sub _get_list {
899            my $self = shift;
900    
901            my $name = shift || return;
902    
903            my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";
904    
905            return $lists->search({ name => lc($name) })->first;
906    }
907    
908    
909    =head2 _remove_alias
910    
911    Remove list alias
912    
913     my $ok = $nos->_remove_alias(
914            email => 'mylist@example.com',
915            aliases => '/etc/mail/mylist',
916     );
917    
918    Returns true if list is removed or false if list doesn't exist. Dies in case of error.
919    
920    =cut
921    
922    sub _remove_alias {
923            my $self = shift;
924    
925            my $arg = {@_};
926    
927            my $email = lc($arg->{'email'}) || confess "can't remove alias without email";
928            my $aliases = lc($arg->{'aliases'}) || confess "can't remove alias without list";
929    
930            my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
931    
932            if ($a->exists($email)) {
933                    $a->delete($email) || croak "can't remove alias $email";
934            } else {
935                    return 0;
936            }
937    
938            return 1;
939    
940    }
941    
942    ###
943    ### SOAP
944    ###
945    
946    package Nos::SOAP;
947    
948    use Carp;
949    
950    =head1 SOAP methods
951    
952    This methods are thin wrappers to provide SOAP calls. They are grouped in
953    C<Nos::SOAP> package which is in same F<Nos.pm> module file.
954    
955    Usually, you want to use named variables in your SOAP calls if at all
956    possible.
957    
958    However, if you have broken SOAP library (like PHP SOAP class from PEAR)
959    you will want to use positional arguments (in same order as documented for
960    methods below).
961    
962    =cut
963    
964    my $nos;
965    
966    
967    =head2 new
968    
969    Create new SOAP object
970    
971     my $soap = new Nos::SOAP(
972            dsn => 'dbi:Pg:dbname=notices',
973            user => 'dpavlin',
974            passwd => '',
975            debug => 1,
976            verbose => 1,
977            hash_len => 8,
978            aliases => '/etc/aliases',
979     );
980    
981    If you are writing SOAP server (like C<soap.cgi> example), you will need to
982    call this method once to make new instance of Nos::SOAP and specify C<dsn>
983    and options for it.
984    
985    =cut
986    
987    sub new {
988            my $class = shift;
989            my $self = {@_};
990    
991            croak "need aliases parametar" unless ($self->{'aliases'});
992    
993            bless($self, $class);
994    
995            $nos = new Nos( @_ ) || die "can't create Nos object";
996    
997            $self ? return $self : return undef;
998    }
999    
1000    
1001    =head2 CreateList
1002    
1003     $message_id = CreateList(
1004            list => 'My list',
1005            from => 'Name of my list',
1006            email => 'my-list@example.com'
1007     );
1008    
1009    =cut
1010    
1011    sub CreateList {
1012            my $self = shift;
1013    
1014            my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
1015    
1016   my $lists = $nos->lists;          if ($_[0] !~ m/^HASH/) {
1017                    return $nos->create_list(
1018                            list => $_[0], from => $_[1], email => $_[2],
1019                            aliases => $aliases,
1020                    );
1021            } else {
1022                    return $nos->create_list( %{ shift @_ }, aliases => $aliases );
1023            }
1024    }
1025    
 is equivalent to:  
1026    
1027   my $lists = $loader->find_class('lists');  =head2 DropList
1028    
1029     $ok = DropList(
1030            list => 'My list',
1031     );
1032    
1033  =cut  =cut
1034    
1035  #sub AUTOLOAD {  sub DropList {
1036  #       return if $AUTOLOAD =~ m/DESTROY$/;          my $self = shift;
 #       my ($name) = $AUTOLOAD =~ /([^:]+)$/;  
 #  
 #       return $self->{'loader'}->find_class($AUTOLOAD) ||  
 #               croak "unknown method '$AUTOLOAD' called";  
 #}  
1037    
1038  =head2 send          my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
1039    
1040  Send a message using configured mailer.          if ($_[0] !~ m/^HASH/) {
1041                    return $nos->drop_list(
1042                            list => $_[0],
1043                            aliases => $aliases,
1044                    );
1045            } else {
1046                    return $nos->drop_list( %{ shift @_ }, aliases => $aliases );
1047            }
1048    }
1049    
1050   $nos->send("message with headers");  =head2 AddMemberToList
1051    
1052     $member_id = AddMemberToList(
1053            list => 'My list',
1054            email => 'e-mail@example.com',
1055            name => 'Full Name',
1056            ext_id => 42,
1057     );
1058    
1059  =cut  =cut
1060    
1061  sub send_email {  sub AddMemberToList {
1062          my $self = shift;          my $self = shift;
1063    
1064          my $message = shift || return;          if ($_[0] !~ m/^HASH/) {
1065                    return $nos->add_member_to_list(
1066                            list => $_[0], email => $_[1], name => $_[2], ext_id => $_[4],
1067                    );
1068            } else {
1069                    return $nos->add_member_to_list( %{ shift @_ } );
1070            }
1071    }
1072    
1073    
1074    =head2 ListMembers
1075    
1076          send IO => $message;   my @members = ListMembers(
1077            list => 'My list',
1078     );
1079    
1080    Returns array of hashes with user informations, see C<list_members>.
1081    
1082    =cut
1083    
1084    sub ListMembers {
1085            my $self = shift;
1086    
1087            my $list_name;
1088    
1089            if ($_[0] !~ m/^HASH/) {
1090                    $list_name = shift;
1091            } else {
1092                    $list_name = $_[0]->{'list'};
1093            }
1094    
1095            return [ $nos->list_members( list => $list_name ) ];
1096    }
1097    
1098    
1099    =head2 DeleteMemberFromList
1100    
1101     $member_id = DeleteMemberFromList(
1102            list => 'My list',
1103            email => 'e-mail@example.com',
1104     );
1105    
1106    =cut
1107    
1108    sub DeleteMemberFromList {
1109            my $self = shift;
1110    
1111            if ($_[0] !~ m/^HASH/) {
1112                    return $nos->delete_member_from_list(
1113                            list => $_[0], email => $_[1],
1114                    );
1115            } else {
1116                    return $nos->delete_member_from_list( %{ shift @_ } );
1117            }
1118  }  }
1119    
 =head2 EXPORT  
1120    
1121  None by default.  =head2 AddMessageToList
1122    
1123     $message_id = AddMessageToList(
1124            list => 'My list',
1125            message => 'From: My list...'
1126     );
1127    
1128    =cut
1129    
1130    sub AddMessageToList {
1131            my $self = shift;
1132    
1133            if ($_[0] !~ m/^HASH/) {
1134                    return $nos->add_message_to_list(
1135                            list => $_[0], message => $_[1],
1136                    );
1137            } else {
1138                    return $nos->add_message_to_list( %{ shift @_ } );
1139            }
1140    }
1141    
1142    =head1 UNIMPLEMENTED FUNCTIONS
1143    
1144    This is a stub for documentation of unimplemented functions.
1145    
1146    =head2 MessagesReceived
1147    
1148     my @result = MessagesReceived(
1149            list => 'My list',
1150            email => 'jdoe@example.com',
1151     );
1152    
1153    You can specify just C<list> or C<email> or any combination of those.
1154    
1155    It will return array of hashes with following structure:
1156    
1157     {
1158            id => 42,                       # unique ID of received message
1159            list => 'My list',              # useful only of filtering by email
1160            ext_id => 9999,                 # ext_id from message user
1161            email => 'jdoe@example.com',    # e-mail of user
1162            bounced => 0,                   # true value if message is bounce
1163            date => '2005-08-24 18:57:24',  # date of recival in ISO format
1164     }
1165    
1166    =head2 MessagesReceivedByDate
1167    
1168    =head2 MessagesReceivedByDateWithContent
1169    
1170    =head2 ReceivedMessasgeContent
1171    
1172    Return content of received message.
1173    
1174     my $mail_body = ReceivedMessageContent( id => 42 );
1175    
1176    =cut
1177    
1178    
1179    
1180    
1181    ###
1182    
1183    =head1 NOTE ON ARRAYS IN SOAP
1184    
1185    Returning arrays from SOAP calls is somewhat fuzzy (at least to me). It
1186    seems that SOAP::Lite client thinks that it has array with one element which
1187    is array of hashes with data.
1188    
1189    =head1 EXPORT
1190    
1191    Nothing.
1192    
1193  =head1 SEE ALSO  =head1 SEE ALSO
1194    
1195  mailman, ezmlm, sympa, L<Mail::Salsa>  mailman, ezmlm, sympa, L<Mail::Salsa>
1196    
1197    
1198  =head1 AUTHOR  =head1 AUTHOR
1199    
1200  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
1201    
1202    
1203  =head1 COPYRIGHT AND LICENSE  =head1 COPYRIGHT AND LICENSE
1204    
1205  Copyright (C) 2005 by Dobrica Pavlinusic  Copyright (C) 2005 by Dobrica Pavlinusic
# Line 129  at your option, any later version of Per Line 1210  at your option, any later version of Per
1210    
1211    
1212  =cut  =cut
1213    
1214    1;
Legend:
Removed from v.20  
changed lines
  Added in v.75
  ViewVC Help
Powered by ViewVC 1.1.26