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