/[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 24 by dpavlin, Sun May 15 22:30:54 2005 UTC 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 70  sub new { Line 79  sub new {
79                  relationships   => 1,                  relationships   => 1,
80          ) || croak "can't init Class::DBI::Loader";          ) || 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    
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            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  =head2 add_member_to_list
121    
122  Add new member to list  Add new member to list
# Line 85  Add new member to list Line 129  Add new member to list
129    
130  C<name> parametar is optional.  C<name> parametar is optional.
131    
132  Return true if user is added.  Return member ID if user is added.
133    
134  =cut  =cut
135    
# Line 94  sub add_member_to_list { Line 138  sub add_member_to_list {
138    
139          my $arg = {@_};          my $arg = {@_};
140    
141          my $email = $arg->{'email'} || confess "can't add user without e-mail";          my $email = $arg->{'email'} || croak "can't add user without e-mail";
142          my $name = $arg->{'name'} || '';          my $name = $arg->{'name'} || '';
143          confess "need list name" unless ($arg->{'list'});          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)) {          if (! Email::Valid->address($email)) {
148                  warn "SKIPPING $name <$email>";                  carp "SKIPPING $name <$email>\n";
149                  return 0;                  return 0;
150          }          }
151    
152          print "# $name <$email>\n";          carp "# $name <$email>\n" if ($self->{'verbose'});
153    
         my $lists = $self->{'loader'}->find_class('lists');  
154          my $users = $self->{'loader'}->find_class('users');          my $users = $self->{'loader'}->find_class('users');
155          my $user_list = $self->{'loader'}->find_class('user_list');          my $user_list = $self->{'loader'}->find_class('user_list');
156    
         my $list = $lists->find_or_create({  
                 name => $arg->{'list'},  
         }) || croak "can't add list ",$arg->{'list'},"\n";  
           
157          my $this_user = $users->find_or_create({          my $this_user = $users->find_or_create({
158                  email => $email,                  email => $email,
                 full_name => $name,  
159          }) || croak "can't find or create member\n";          }) || 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({          my $user_on_list = $user_list->find_or_create({
167                  user_id => $this_user->id,                  user_id => $this_user->id,
168                  list_id => $list->id,                  list_id => $list->id,
# Line 127  sub add_member_to_list { Line 172  sub add_member_to_list {
172          $this_user->dbi_commit;          $this_user->dbi_commit;
173          $user_on_list->dbi_commit;          $user_on_list->dbi_commit;
174    
175          return 1;          return $this_user->id;
176  }  }
177    
178  =head2 add_message_to_queue  =head2 add_message_to_list
179    
180  Adds message to one list's queue for later sending.  Adds message to one list's queue for later sending.
181    
182   $nos->add_message_to_queue(   $nos->add_message_to_list(
183          list => 'My list',          list => 'My list',
184          message => 'From: My list <mylist@example.com>          message => 'Subject: welcome to list
185   To: John A. Doe <john.doe@example.com>  
   
186   This is example message   This is example message
187   ',   ',
188   );       );    
189    
190  On success returns ID of newly created (or existing) message.  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 add_message_to_queue {  sub add_message_to_list {
199          my $self = shift;          my $self = shift;
200    
201          my $args = {@_};          my $args = {@_};
# Line 155  sub add_message_to_queue { Line 203  sub add_message_to_queue {
203          my $list_name = $args->{'list'} || confess "need list name";          my $list_name = $args->{'list'} || confess "need list name";
204          my $message_text = $args->{'message'} || croak "need message";          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');          my $lists = $self->{'loader'}->find_class('lists');
214    
215          my $this_list = $lists->search(          my $this_list = $lists->search(
# Line 218  sub send_queued_messages { Line 273  sub send_queued_messages {
273    
274                  foreach my $u ($user_list->search(list_id => $m->list_id)) {                  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 )) {                          if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {
281                                  print "SKIP ",$u->user_id->email," message allready sent\n";                                  print "SKIP $to_email message allready sent\n";
282                          } else {                          } else {
283                                  print "\t",$u->user_id->email,"\n";                                  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                                  my $hdr = "From: " . $u->list_id->name . " <" . $u->list_id->email . ">\n" .                                  $m_obj->header_set('From', $from) || croak "can't set From: header";
296                                          "To: " . $u->user_id->full_name . " <". $u->user_id->email. ">\n";                                  $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 :-)                                  # FIXME do real sending :-)
302                                  send IO => "$hdr\n$msg";                                  send IO => $m_obj->as_string;
303    
304                                  $sent->create({                                  $sent->create({
305                                          message_id => $m->message_id,                                          message_id => $m->message_id,
306                                          user_id => $u->user_id,                                          user_id => $u->user_id,
307                                            hash => $hash,
308                                  });                                  });
309                                  $sent->dbi_commit;                                  $sent->dbi_commit;
310                          }                          }
# Line 243  sub send_queued_messages { Line 316  sub send_queued_messages {
316    
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            $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  None by default.  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 265  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.24  
changed lines
  Added in v.39
  ViewVC Help
Powered by ViewVC 1.1.26