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