/[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 21 by dpavlin, Sun May 15 21:35:15 2005 UTC revision 48 by dpavlin, Tue May 24 15:19:44 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.4';
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 Data::Dumper;
30    
31    my $email_send_driver = 'Email::Send::IO';
32    my @email_send_options;
33    
34    #$email_send_driver = 'Sendmail';
35    
36    
37  =head1 NAME  =head1 NAME
38    
# Line 48  Create new instance specifing database, Line 59  Create new instance specifing database,
59          passwd => '',          passwd => '',
60          debug => 1,          debug => 1,
61          verbose => 1,          verbose => 1,
62            hash_len => 8,
63   );   );
64    
65    Parametar C<hash_len> defines length of hash which will be added to each
66    outgoing e-mail message to ensure that replies can be linked with sent e-mails.
67    
68  =cut  =cut
69    
70  sub new {  sub new {
# Line 57  sub new { Line 72  sub new {
72          my $self = {@_};          my $self = {@_};
73          bless($self, $class);          bless($self, $class);
74    
75            croak "need at least dsn" unless ($self->{'dsn'});
76    
77          $self->{'loader'} = Class::DBI::Loader->new(          $self->{'loader'} = Class::DBI::Loader->new(
78                  debug           => $self->{'debug'},                  debug           => $self->{'debug'},
79                  dsn             => $self->{'dsn'},                  dsn             => $self->{'dsn'},
# Line 66  sub new { Line 83  sub new {
83  #               additional_classes      => qw/Class::DBI::AbstractSearch/,  #               additional_classes      => qw/Class::DBI::AbstractSearch/,
84  #               additional_base_classes => qw/My::Stuff/,  #               additional_base_classes => qw/My::Stuff/,
85                  relationships   => 1,                  relationships   => 1,
86          );          ) || croak "can't init Class::DBI::Loader";
87    
88            $self->{'hash_len'} ||= 8;
89    
90          $self ? return $self : return undef;          $self ? return $self : return undef;
91  }  }
92    
 =head2 update_list_email  
93    
94  Update list e-mail address  =head2 new_list
95    
96    Create new list. Required arguments are name of C<list> and
97    C<email> address.
98    
99     $nos->new_list(
100            list => 'My list',
101            from => 'Outgoing from comment',
102            email => 'my-list@example.com',
103     );
104    
105    Returns ID of newly created list.
106    
107   $noc->update_list_email($list, 'foobar@example.com');  Calls internally L<_add_list>, see details there.
108    
109  =cut  =cut
110    
111  sub update_list_email {  sub new_list {
112          my $self = shift;          my $self = shift;
113    
114            my $arg = {@_};
115    
116            confess "need list name" unless ($arg->{'list'});
117            confess "need list email" unless ($arg->{'list'});
118    
119            my $l = $self->_get_list($arg->{'list'}) ||
120                    $self->_add_list( @_ ) ||
121                    return undef;
122    
123            return $l->id;
124    }
125    
126    
127    =head2 add_member_to_list
128    
129    Add new member to list
130    
131     $nos->add_member_to_list(
132            list => "My list",
133            email => "john.doe@example.com",
134            name => "John A. Doe",
135     );
136    
137    C<name> parametar is optional.
138    
139    Return member ID if user is added.
140    
141    =cut
142    
143    sub add_member_to_list {
144            my $self = shift;
145    
146            my $arg = {@_};
147    
148            my $email = $arg->{'email'} || croak "can't add user without e-mail";
149            my $name = $arg->{'name'} || '';
150            my $list_name = $arg->{'list'} || croak "need list name";
151    
152            my $list = $self->_get_list($list_name) || croak "list $list_name doesn't exist";
153    
154            if (! Email::Valid->address($email)) {
155                    carp "SKIPPING $name <$email>\n";
156                    return 0;
157            }
158    
159            carp "# $name <$email>\n" if ($self->{'verbose'});
160    
161            my $users = $self->{'loader'}->find_class('users');
162            my $user_list = $self->{'loader'}->find_class('user_list');
163    
164            my $this_user = $users->find_or_create({
165                    email => $email,
166            }) || croak "can't find or create member\n";
167    
168            if ($name && $this_user->name ne $name) {
169                    $this_user->name($name || '');
170                    $this_user->update;
171            }
172    
173            my $user_on_list = $user_list->find_or_create({
174                    user_id => $this_user->id,
175                    list_id => $list->id,
176            }) || croak "can't add user to list";
177    
178            $list->dbi_commit;
179            $this_user->dbi_commit;
180            $user_on_list->dbi_commit;
181    
182            return $this_user->id;
183  }  }
184    
185  =head2 send  =head2 list_members
186    
187    List all members of some list.
188    
189     my @members = list_members(
190            list => 'My list',
191     );
192    
193    Returns array of hashes with user informations like this:
194    
195  Send a message using configured mailer.   $member = {
196            name => 'Dobrica Pavlinusic',
197            email => 'dpavlin@rot13.org
198     }
199    
200   $nos->send("message with headers");  If list is not found, returns false.
201    
202  =cut  =cut
203    
204  sub send_email {  sub list_members {
205          my $self = shift;          my $self = shift;
206    
207          my $message = shift || return;          my $args = {@_};
208    
209            my $list_name = $args->{'list'} || confess "need list name";
210    
211            my $lists = $self->{'loader'}->find_class('lists');
212            my $user_list = $self->{'loader'}->find_class('user_list');
213    
214            my $this_list = $lists->search( name => $list_name )->first || return;
215    
216            my @results;
217    
218            foreach my $user_on_list ($user_list->search(list_id => $this_list->id)) {
219                    my $row = {
220                            name => $user_on_list->user_id->name,
221                            email => $user_on_list->user_id->email,
222                    };
223    
224                    push @results, $row;
225            }
226    
227            return @results;
228    
         send IO => $message;  
229  }  }
230    
 =head2 EXPORT  
231    
232  None by default.  =head2 delete_member
233    
234    Delete member from database.
235    
236     my $ok = delete_member(
237            name => 'Dobrica Pavlinusic'
238     );
239    
240     my $ok = delete_member(
241            email => 'dpavlin@rot13.org'
242     );
243    
244    Returns false if user doesn't exist.
245    
246    =cut
247    
248    sub delete_member {
249            my $self = shift;
250    
251            my $args = {@_};
252    
253            croak "need name or email of user to delete" unless ($args->{'name'} || $args->{'email'});
254    
255            my $key = 'name';
256            $key = 'email' if ($args->{'email'});
257    
258            my $users = $self->{'loader'}->find_class('users');
259    
260            my $this_user = $users->search( $key => $args->{$key} )->first || return;
261    
262    print Dumper($this_user);
263    
264            $this_user->delete || croak "can't delete user\n";
265    
266            return $users->dbi_commit || croak "can't commit";
267    }
268    
269    =head2 add_message_to_list
270    
271    Adds message to one list's queue for later sending.
272    
273     $nos->add_message_to_list(
274            list => 'My list',
275            message => 'Subject: welcome to list
276    
277     This is example message
278     ',
279     );    
280    
281    On success returns ID of newly created (or existing) message.
282    
283    Only required header in e-mail is C<Subject:>. C<From:> and C<To:> headers
284    will be automatically generated, but if you want to use own headers, just
285    include them in messages.
286    
287    =cut
288    
289    sub add_message_to_list {
290            my $self = shift;
291    
292            my $args = {@_};
293    
294            my $list_name = $args->{'list'} || confess "need list name";
295            my $message_text = $args->{'message'} || croak "need message";
296    
297            my $m = Email::Simple->new($message_text) || croak "can't parse message";
298    
299            unless( $m->header('Subject') ) {
300                    warn "message doesn't have Subject header\n";
301                    return;
302            }
303    
304            my $lists = $self->{'loader'}->find_class('lists');
305    
306            my $this_list = $lists->search(
307                    name => $list_name,
308            )->first || croak "can't find list $list_name";
309    
310            my $messages = $self->{'loader'}->find_class('messages');
311    
312            my $this_message = $messages->find_or_create({
313                    message => $message_text
314            }) || croak "can't insert message";
315    
316            $this_message->dbi_commit() || croak "can't add message";
317    
318            my $queue = $self->{'loader'}->find_class('queue');
319    
320            $queue->find_or_create({
321                    message_id => $this_message->id,
322                    list_id => $this_list->id,
323            }) || croak "can't add message ",$this_message->id," to list ",$this_list->id, ": ",$this_list->name;
324    
325            $queue->dbi_commit || croak "can't add message to list ",$this_list->name;
326    
327            return $this_message->id;
328    }
329    
330    
331    =head2 send_queued_messages
332    
333    Send queued messages or just ones for selected list
334    
335     $nos->send_queued_messages("My list",'smtp');
336    
337    Second option is driver which will be used for e-mail delivery. If not
338    specified, C<IO> driver will be used which will dump e-mail to C<STDERR>.
339    
340    Other valid drivers are:
341    
342    =over 10
343    
344    =item smtp
345    
346    Send e-mail using SMTP server at 127.0.0.1
347    
348    =back
349    
350    =cut
351    
352    sub send_queued_messages {
353            my $self = shift;
354    
355            my $list_name = shift;
356    
357            my $driver = shift || '';
358    
359            if (lc($driver) eq 'smtp') {
360                    $email_send_driver = 'Email::Send::SMTP';
361                    @email_send_options = ['127.0.0.1'];
362            }
363            warn "using $driver [$email_send_driver]\n";
364    
365            my $lists = $self->{'loader'}->find_class('lists');
366            my $queue = $self->{'loader'}->find_class('queue');
367            my $user_list = $self->{'loader'}->find_class('user_list');
368            my $sent = $self->{'loader'}->find_class('sent');
369    
370            my $my_q;
371            if ($list_name ne '') {
372                    my $l_id = $lists->search_like( name => $list_name )->first ||
373                            croak "can't find list $list_name";
374                    $my_q = $queue->search_like( list_id => $l_id ) ||
375                            croak "can't find list $list_name";
376            } else {
377                    $my_q = $queue->retrieve_all;
378            }
379    
380            while (my $m = $my_q->next) {
381                    next if ($m->all_sent);
382    
383                    print "sending message ",$m->message_id," enqueued on ",$m->date," to list ",$m->list_id->name,"\n";
384                    my $msg = $m->message_id->message;
385    
386                    foreach my $u ($user_list->search(list_id => $m->list_id)) {
387    
388                            my $to_email = $u->user_id->email;
389    
390                            my ($from,$domain) = split(/@/, $u->list_id->email, 2);
391    
392                            if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {
393                                    print "SKIP $to_email message allready sent\n";
394                            } else {
395                                    print "=> $to_email\n";
396    
397                                    my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;
398                                    my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
399    
400                                    my $hash = $auth->generate_hash( $to_email );
401    
402                                    my $from_addr;
403                                    my $email_hash = "+" . $hash . ( $domain ? '@' . $domain : '');
404                                    my $from_email_only = $from . $email_hash;
405                                    my $from_bounce = $from . '-bounce' . $email_hash;
406    
407                                    $from_addr .= '"' . $u->list_id->from_addr . '" ' if ($u->list_id->from_addr);
408                                    $from_addr .= '<' . $from_email_only . '>';
409                                    my $to = '"' . $u->user_id->name . '" <' . $to_email . '>';
410    
411                                    my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
412    
413                                    $m_obj->header_set('Return-Path', $from_bounce) || croak "can't set Return-Path: header";
414                                    $m_obj->header_set('Sender', $from_bounce) || croak "can't set Sender: header";
415                                    $m_obj->header_set('Errors-To', $from_bounce) || croak "can't set Errors-To: header";
416                                    $m_obj->header_set('From', $from_addr) || croak "can't set From: header";
417                                    $m_obj->header_set('To', $to) || croak "can't set To: header";
418    
419                                    $m_obj->header_set('X-Nos-Version', $VERSION);
420                                    $m_obj->header_set('X-Nos-Hash', $hash);
421    
422                                    # really send e-mail
423                                    if (@email_send_options) {
424                                            send $email_send_driver => $m_obj->as_string, @email_send_options;
425                                    } else {
426                                            send $email_send_driver => $m_obj->as_string;
427                                    }
428    
429                                    $sent->create({
430                                            message_id => $m->message_id,
431                                            user_id => $u->user_id,
432                                            hash => $hash,
433                                    });
434                                    $sent->dbi_commit;
435                            }
436                    }
437                    $m->all_sent(1);
438                    $m->update;
439                    $m->dbi_commit;
440            }
441    
442    }
443    
444    =head2 inbox_message
445    
446    Receive single message for list's inbox.
447    
448     my $ok = $nos->inbox_message(
449            list => 'My list',
450            message => $message,
451     );
452    
453    =cut
454    
455    sub inbox_message {
456            my $self = shift;
457    
458            my $arg = {@_};
459    
460            return unless ($arg->{'message'});
461            croak "need list name" unless ($arg->{'list'});
462    
463            my $this_list = $self->_get_list($arg->{'list'}) || croak "can't find list ".$arg->{'list'}."\n";
464    
465            my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message";
466    
467            my $to = $m->header('To') || die "can't find To: address in incomming message\n";
468    
469            my $return_path = $m->header('Return-Path') || '';
470    
471            my @addrs = Email::Address->parse( $to );
472    
473            die "can't parse To: $to address\n" unless (@addrs);
474    
475            my $hl = $self->{'hash_len'} || confess "no hash_len?";
476    
477            my $hash;
478    
479            foreach my $a (@addrs) {
480                    if ($a->address =~ m/\+([a-f0-9]{$hl})@/) {
481                            $hash = $1;
482                            last;
483                    }
484            }
485    
486            warn "can't find hash in e-mail $to\n" unless ($hash);
487    
488            my $sent = $self->{'loader'}->find_class('sent');
489    
490            # will use null if no matching message_id is found
491            my $sent_msg = $sent->search( hash => $hash )->first;
492    
493            my ($message_id, $user_id) = (undef, undef);    # init with NULL
494    
495            if ($sent_msg) {
496                    $message_id = $sent_msg->message_id || carp "no message_id";
497                    $user_id = $sent_msg->user_id || carp "no user_id";
498            } else {
499                    warn "can't find sender with hash $hash\n";
500            }
501    
502    
503            my $is_bounce = 0;
504    
505            if ($arg->{'bounce'} || $return_path eq '<>' || $return_path eq '') {
506                    no warnings;
507                    my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
508                            $arg->{'message'}, { report_non_bounces=>1 },
509                    ) };
510                    carp "can't check if this message is bounce!" if ($@);
511            
512                    $is_bounce++ if ($bounce && $bounce->is_bounce);
513            }
514    
515            my $received = $self->{'loader'}->find_class('received');
516    
517            my $this_received = $received->find_or_create({
518                    user_id => $user_id,
519                    list_id => $this_list->id,
520                    message_id => $message_id,
521                    message => $arg->{'message'},
522                    bounced => $is_bounce,
523            }) || croak "can't insert received message";
524    
525            $this_received->dbi_commit;
526    
527            print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
528    
529    
530            warn "inbox is not yet implemented";
531    }
532    
533    
534    =head1 INTERNAL METHODS
535    
536    Beware of dragons! You shouldn't need to call those methods directly.
537    
538    =head2 _add_list
539    
540    Create new list
541    
542     my $list_obj = $nos->_add_list(
543            list => 'My list',
544            from => 'Outgoing from comment',
545            email => 'my-list@example.com',
546     );
547    
548    Returns C<Class::DBI> object for created list.
549    
550    C<email> address can be with domain or without it if your
551    MTA appends it. There is no checking for validity of your
552    list e-mail. Flexibility comes with resposibility, so please
553    feed correct (and configured) return addresses.
554    
555    =cut
556    
557    sub _add_list {
558            my $self = shift;
559    
560            my $arg = {@_};
561    
562            my $name = $arg->{'list'} || confess "can't add list without name";
563            my $email = $arg->{'email'} || confess "can't add list without e-mail";
564            my $from_addr = $arg->{'from'};
565    
566            my $lists = $self->{'loader'}->find_class('lists');
567    
568            my $l = $lists->find_or_create({
569                    name => $name,
570                    email => $email,
571            });
572    
573            croak "can't add list $name\n" unless ($l);
574    
575            if ($from_addr && $l->from_addr ne $from_addr) {
576                    $l->from_addr($from_addr);
577                    $l->update;
578            }
579    
580            $l->dbi_commit;
581    
582            return $l;
583    
584    }
585    
586    
587    =head2 _get_list
588    
589    Get list C<Class::DBI> object.
590    
591     my $list_obj = $nos->check_list('My list');
592    
593    Returns false on failure.
594    
595    =cut
596    
597    sub _get_list {
598            my $self = shift;
599    
600            my $name = shift || return;
601    
602            my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";
603    
604            return $lists->search({ name => $name })->first;
605    }
606    
607    ###
608    ### SOAP
609    ###
610    
611    package Nos::SOAP;
612    
613    use Carp;
614    
615    =head1 SOAP methods
616    
617    This methods are thin wrappers to provide SOAP calls. They are grouped in
618    C<Nos::SOAP> package which is in same F<Nos.pm> module file.
619    
620    Usually, you want to use named variables in your SOAP calls if at all
621    possible.
622    
623    However, if you have broken SOAP library (like PHP SOAP class from PEAR)
624    you will want to use positional arguments (in same order as documented for
625    methods below).
626    
627    =cut
628    
629    my $nos;
630    
631    sub new {
632            my $class = shift;
633            my $self = {@_};
634            bless($self, $class);
635    
636            $nos = new Nos( @_ ) || die "can't create Nos object";
637    
638            $self ? return $self : return undef;
639    }
640    
641    
642    =head2 NewList
643    
644     $message_id = NewList(
645            list => 'My list',
646            email => 'my-list@example.com'
647     );
648    
649    =cut
650    
651    sub NewList {
652            my $self = shift;
653    
654            if ($_[0] !~ m/^HASH/) {
655                    return $nos->new_list(
656                            list => $_[0], email => $_[1],
657                    );
658            } else {
659                    return $nos->new_list( %{ shift @_ } );
660            }
661    }
662    
663    
664    =head2 AddMemberToList
665    
666     $member_id = AddMemberToList(
667            list => 'My list',
668            email => 'e-mail@example.com',
669            name => 'Full Name'
670     );
671    
672    =cut
673    
674    sub AddMemberToList {
675            my $self = shift;
676    
677            if ($_[0] !~ m/^HASH/) {
678                    return $nos->add_member_to_list(
679                            list => $_[0], email => $_[1], name => $_[2],
680                    );
681            } else {
682                    return $nos->add_member_to_list( %{ shift @_ } );
683            }
684    }
685    
686    
687    =head2 ListMembers
688    
689     my @members = ListMembers(
690            list => 'My list',
691     );
692    
693    Returns array of hashes with user informations, see C<list_members>.
694    
695    =cut
696    
697    sub ListMembers {
698            my $self = shift;
699    
700            my $list_name;
701    
702            if ($_[0] !~ m/^HASH/) {
703                    $list_name = shift;
704            } else {
705                    $list_name = $_[0]->{'list'};
706            }
707    
708            return $nos->list_members( list => $list_name );
709    }
710    
711    =head2 AddMessageToList
712    
713     $message_id = AddMessageToList(
714            list => 'My list',
715            message => 'From: My list...'
716     );
717    
718    =cut
719    
720    sub AddMessageToList {
721            my $self = shift;
722    
723            if ($_[0] !~ m/^HASH/) {
724                    return $nos->add_message_to_list(
725                            list => $_[0], message => $_[1],
726                    );
727            } else {
728                    return $nos->add_message_to_list( %{ shift @_ } );
729            }
730    }
731    
732    
733    ###
734    
735    =head1 EXPORT
736    
737    Nothing.
738    
739  =head1 SEE ALSO  =head1 SEE ALSO
740    
741  mailman, ezmlm, sympa, L<Mail::Salsa>  mailman, ezmlm, sympa, L<Mail::Salsa>
742    
743    
744  =head1 AUTHOR  =head1 AUTHOR
745    
746  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
747    
748    
749  =head1 COPYRIGHT AND LICENSE  =head1 COPYRIGHT AND LICENSE
750    
751  Copyright (C) 2005 by Dobrica Pavlinusic  Copyright (C) 2005 by Dobrica Pavlinusic
# Line 123  at your option, any later version of Per Line 756  at your option, any later version of Per
756    
757    
758  =cut  =cut
759    
760    1;
Legend:
Removed from v.21  
changed lines
  Added in v.48
  ViewVC Help
Powered by ViewVC 1.1.26