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