/[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 39 by dpavlin, Tue May 17 22:23:40 2005 UTC revision 59 by dpavlin, Tue Jun 21 20:49:27 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.3';  our $VERSION = '0.5';
20    
21  use Class::DBI::Loader;  use Class::DBI::Loader;
22  use Email::Valid;  use Email::Valid;
# Line 26  use Email::Auth::AddressHash; Line 26  use Email::Auth::AddressHash;
26  use Email::Simple;  use Email::Simple;
27  use Email::Address;  use Email::Address;
28  use Mail::DeliveryStatus::BounceParser;  use Mail::DeliveryStatus::BounceParser;
29  use Data::Dumper;  use Class::DBI::AbstractSearch;
30    
31    
32  =head1 NAME  =head1 NAME
33    
# Line 74  sub new { Line 75  sub new {
75                  user            => $self->{'user'},                  user            => $self->{'user'},
76                  password        => $self->{'passwd'},                  password        => $self->{'passwd'},
77                  namespace       => "Nos",                  namespace       => "Nos",
78  #               additional_classes      => qw/Class::DBI::AbstractSearch/,                  additional_classes      => qw/Class::DBI::AbstractSearch/,
79  #               additional_base_classes => qw/My::Stuff/,  #               additional_base_classes => qw/My::Stuff/,
80                  relationships   => 1,                  relationships   => 1,
81          ) || croak "can't init Class::DBI::Loader";          ) || croak "can't init Class::DBI::Loader";
# Line 92  C<email> address. Line 93  C<email> address.
93    
94   $nos->new_list(   $nos->new_list(
95          list => 'My list',          list => 'My list',
96            from => 'Outgoing from comment',
97          email => 'my-list@example.com',          email => 'my-list@example.com',
98   );   );
99    
# Line 107  sub new_list { Line 109  sub new_list {
109          my $arg = {@_};          my $arg = {@_};
110    
111          confess "need list name" unless ($arg->{'list'});          confess "need list name" unless ($arg->{'list'});
112          confess "need list email" unless ($arg->{'list'});          confess "need list email" unless ($arg->{'email'});
113    
114            $arg->{'list'} = lc($arg->{'list'});
115            $arg->{'email'} = lc($arg->{'email'});
116    
117          my $l = $self->_get_list($arg->{'list'}) ||          my $l = $self->_get_list($arg->{'list'}) ||
118                  $self->_add_list( @_ ) ||                  $self->_add_list( @_ ) ||
# Line 125  Add new member to list Line 130  Add new member to list
130          list => "My list",          list => "My list",
131          email => "john.doe@example.com",          email => "john.doe@example.com",
132          name => "John A. Doe",          name => "John A. Doe",
133            ext_id => 42,
134   );   );
135    
136  C<name> parametar is optional.  C<name> and C<ext_id> parametars are optional.
137    
138  Return member ID if user is added.  Return member ID if user is added.
139    
# Line 138  sub add_member_to_list { Line 144  sub add_member_to_list {
144    
145          my $arg = {@_};          my $arg = {@_};
146    
147          my $email = $arg->{'email'} || croak "can't add user without e-mail";          my $email = lc($arg->{'email'}) || croak "can't add user without e-mail";
148          my $name = $arg->{'name'} || '';          my $name = $arg->{'name'} || '';
149          my $list_name = $arg->{'list'} || croak "need list name";          my $list_name = lc($arg->{'list'}) || croak "need list name";
150            my $ext_id = $arg->{'ext_id'};
151    
152          my $list = $self->_get_list($list_name) || croak "list $list_name doesn't exist";          my $list = $self->_get_list($list_name) || croak "list $list_name doesn't exist";
153    
# Line 158  sub add_member_to_list { Line 165  sub add_member_to_list {
165                  email => $email,                  email => $email,
166          }) || croak "can't find or create member\n";          }) || croak "can't find or create member\n";
167    
168          if ($name && $this_user->full_name ne $name) {          if ($name && $this_user->name ne $name) {
169                  $this_user->full_name($name || '');                  $this_user->name($name || '');
170                    $this_user->update;
171            }
172    
173            if (defined($ext_id) && ($this_user->ext_id || '') ne $ext_id) {
174                    $this_user->ext_id($ext_id);
175                  $this_user->update;                  $this_user->update;
176          }          }
177    
# Line 175  sub add_member_to_list { Line 187  sub add_member_to_list {
187          return $this_user->id;          return $this_user->id;
188  }  }
189    
190    =head2 list_members
191    
192    List all members of some list.
193    
194     my @members = list_members(
195            list => 'My list',
196     );
197    
198    Returns array of hashes with user informations like this:
199    
200     $member = {
201            name => 'Dobrica Pavlinusic',
202            email => 'dpavlin@rot13.org
203     }
204    
205    If list is not found, returns false. If there is C<ext_id> in user data,
206    that will also be returned.
207    
208    =cut
209    
210    sub list_members {
211            my $self = shift;
212    
213            my $args = {@_};
214    
215            my $list_name = lc($args->{'list'}) || confess "need list name";
216    
217            my $lists = $self->{'loader'}->find_class('lists');
218            my $user_list = $self->{'loader'}->find_class('user_list');
219    
220            my $this_list = $lists->search( name => $list_name )->first || return;
221    
222            my @results;
223    
224            foreach my $user_on_list ($user_list->search(list_id => $this_list->id)) {
225                    my $row = {
226                            name => $user_on_list->user_id->name,
227                            email => $user_on_list->user_id->email,
228                    };
229    
230                    my $ext_id = $user_on_list->user_id->ext_id;
231                    $row->{'ext_id'} = $ext_id if (defined($ext_id));
232    
233                    push @results, $row;
234            }
235    
236            return @results;
237    
238    }
239    
240    
241    =head2 delete_member
242    
243    Delete member from database.
244    
245     my $ok = delete_member(
246            name => 'Dobrica Pavlinusic'
247     );
248    
249     my $ok = delete_member(
250            email => 'dpavlin@rot13.org'
251     );
252    
253    Returns false if user doesn't exist.
254    
255    =cut
256    
257    sub delete_member {
258            my $self = shift;
259    
260            my $args = {@_};
261    
262            croak "need name or email of user to delete" unless ($args->{'name'} || $args->{'email'});
263    
264            $args->{'email'} = lc($args->{'email'}) if ($args->{'email'});
265    
266            my $key = 'name';
267            $key = 'email' if ($args->{'email'});
268    
269            my $users = $self->{'loader'}->find_class('users');
270    
271            my $this_user = $users->search( $key => $args->{$key} )->first || return;
272    
273            $this_user->delete || croak "can't delete user\n";
274    
275            return $users->dbi_commit || croak "can't commit";
276    }
277    
278    =head2 delete_member_from_list
279    
280    Delete member from particular list.
281    
282     my $ok = delete_member_from_list(
283            list => 'My list',
284            email => 'dpavlin@rot13.org',
285     );
286    
287    Returns false if user doesn't exist on that particular list.
288    
289    It will die if list or user doesn't exist. You have been warned (you might
290    want to eval this functon to prevent it from croaking).
291    
292    =cut
293    
294    sub delete_member_from_list {
295            my $self = shift;
296    
297            my $args = {@_};
298    
299            croak "need list name and email of user to delete" unless ($args->{'list'} && $args->{'email'});
300    
301            $args->{'list'} = lc($args->{'list'});
302            $args->{'email'} = lc($args->{'email'});
303    
304            my $user = $self->{'loader'}->find_class('users');
305            my $list = $self->{'loader'}->find_class('lists');
306            my $user_list = $self->{'loader'}->find_class('user_list');
307    
308            my $this_user = $user->search( email => $args->{'email'} )->first || croak "can't find user: ".$args->{'email'};
309            my $this_list = $list->search( name => $args->{'list'} )->first || croak "can't find list: ".$args->{'list'};
310    
311            my $this_user_list = $user_list->search_where( list_id => $this_list->id, user_id => $this_list->id )->first || return;
312    
313            $this_user_list->delete || croak "can't delete user from list\n";
314    
315            return $user_list->dbi_commit || croak "can't commit";
316    }
317    
318  =head2 add_message_to_list  =head2 add_message_to_list
319    
320  Adds message to one list's queue for later sending.  Adds message to one list's queue for later sending.
# Line 200  sub add_message_to_list { Line 340  sub add_message_to_list {
340    
341          my $args = {@_};          my $args = {@_};
342    
343          my $list_name = $args->{'list'} || confess "need list name";          my $list_name = lc($args->{'list'}) || confess "need list name";
344          my $message_text = $args->{'message'} || croak "need message";          my $message_text = $args->{'message'} || croak "need message";
345    
346          my $m = Email::Simple->new($message_text) || croak "can't parse message";          my $m = Email::Simple->new($message_text) || croak "can't parse message";
# Line 241  sub add_message_to_list { Line 381  sub add_message_to_list {
381    
382  Send queued messages or just ones for selected list  Send queued messages or just ones for selected list
383    
384   $nos->send_queued_messages("My list");   $nos->send_queued_messages(
385            list => 'My list',
386            driver => 'smtp',
387            sleep => 3,
388     );
389    
390    Second option is driver which will be used for e-mail delivery. If not
391    specified, C<IO> driver will be used which will dump e-mail to C<STDERR>.
392    
393    Other valid drivers are:
394    
395    =over 10
396    
397    =item smtp
398    
399    Send e-mail using SMTP server at 127.0.0.1
400    
401    =back
402    
403    Default sleep wait between two messages is 3 seconds.
404    
405  =cut  =cut
406    
407  sub send_queued_messages {  sub send_queued_messages {
408          my $self = shift;          my $self = shift;
409    
410          my $list_name = shift;          my $arg = {@_};
411    
412            my $list_name = lc($arg->{'list'}) || '';
413            my $driver = $arg->{'driver'} || '';
414            my $sleep = $arg->{'sleep'};
415            $sleep ||= 3 unless defined($sleep);
416    
417            my $email_send_driver = 'Email::Send::IO';
418            my @email_send_options;
419    
420            if (lc($driver) eq 'smtp') {
421                    $email_send_driver = 'Email::Send::SMTP';
422                    @email_send_options = ['127.0.0.1'];
423            } else {
424                    warn "dumping all messages to STDERR\n";
425            }
426    
427          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
428          my $queue = $self->{'loader'}->find_class('queue');          my $queue = $self->{'loader'}->find_class('queue');
# Line 287  sub send_queued_messages { Line 461  sub send_queued_messages {
461    
462                                  my $hash = $auth->generate_hash( $to_email );                                  my $hash = $auth->generate_hash( $to_email );
463    
464                                  my $from = $u->list_id->name . " <" . $from . "+" . $hash . ( $domain ? "@" . $domain : '' ). ">";                                  my $from_addr;
465                                  my $to = $u->user_id->full_name . " <$to_email>";                                  my $from_email_only = $from . "+" . $hash . ( $domain ? '@' . $domain : '');
466    
467                                    $from_addr .= '"' . $u->list_id->from_addr . '" ' if ($u->list_id->from_addr);
468                                    $from_addr .= '<' . $from_email_only . '>';
469                                    my $to = '"' . $u->user_id->name . '" <' . $to_email . '>';
470    
471                                  my $m_obj = Email::Simple->new($msg) || croak "can't parse message";                                  my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
472    
473                                  $m_obj->header_set('From', $from) || croak "can't set From: header";                                  $m_obj->header_set('Return-Path', $from_email_only) || croak "can't set Return-Path: header";
474                                    $m_obj->header_set('Sender', $from_email_only) || croak "can't set Sender: header";
475                                    $m_obj->header_set('Errors-To', $from_email_only) || croak "can't set Errors-To: header";
476                                    $m_obj->header_set('From', $from_addr) || croak "can't set From: header";
477                                  $m_obj->header_set('To', $to) || croak "can't set To: header";                                  $m_obj->header_set('To', $to) || croak "can't set To: header";
478    
479                                  $m_obj->header_set('X-Nos-Version', $VERSION);                                  $m_obj->header_set('X-Nos-Version', $VERSION);
480                                  $m_obj->header_set('X-Nos-Hash', $hash);                                  $m_obj->header_set('X-Nos-Hash', $hash);
481    
482                                  # FIXME do real sending :-)                                  # really send e-mail
483                                  send IO => $m_obj->as_string;                                  if (@email_send_options) {
484                                            send $email_send_driver => $m_obj->as_string, @email_send_options;
485                                    } else {
486                                            send $email_send_driver => $m_obj->as_string;
487                                    }
488    
489                                  $sent->create({                                  $sent->create({
490                                          message_id => $m->message_id,                                          message_id => $m->message_id,
# Line 307  sub send_queued_messages { Line 492  sub send_queued_messages {
492                                          hash => $hash,                                          hash => $hash,
493                                  });                                  });
494                                  $sent->dbi_commit;                                  $sent->dbi_commit;
495    
496                                    if ($sleep) {
497                                            warn "sleeping $sleep seconds\n";
498                                            sleep($sleep);
499                                    }
500                          }                          }
501                  }                  }
502                  $m->all_sent(1);                  $m->all_sent(1);
# Line 335  sub inbox_message { Line 525  sub inbox_message {
525          return unless ($arg->{'message'});          return unless ($arg->{'message'});
526          croak "need list name" unless ($arg->{'list'});          croak "need list name" unless ($arg->{'list'});
527    
528            $arg->{'list'} = lc($arg->{'list'});
529    
530          my $this_list = $self->_get_list($arg->{'list'}) || croak "can't find list ".$arg->{'list'}."\n";          my $this_list = $self->_get_list($arg->{'list'}) || croak "can't find list ".$arg->{'list'}."\n";
531    
532          my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message";          my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message";
533    
534          my $to = $m->header('To') || die "can't find To: address in incomming message\n";          my $to = $m->header('To') || die "can't find To: address in incomming message\n";
535    
536            my $return_path = $m->header('Return-Path') || '';
537    
538          my @addrs = Email::Address->parse( $to );          my @addrs = Email::Address->parse( $to );
539    
540          die "can't parse To: $to address\n" unless (@addrs);          die "can't parse To: $to address\n" unless (@addrs);
# Line 350  sub inbox_message { Line 544  sub inbox_message {
544          my $hash;          my $hash;
545    
546          foreach my $a (@addrs) {          foreach my $a (@addrs) {
547                  if ($a->address =~ m/\+([a-f0-9]{$hl})@/) {                  if ($a->address =~ m/\+([a-f0-9]{$hl})@/i) {
548                          $hash = $1;                          $hash = $1;
549                          last;                          last;
550                  }                  }
551          }          }
552    
553          croak "can't find hash in e-mail $to\n" unless ($hash);          #warn "can't find hash in e-mail $to\n" unless ($hash);
554    
555          my $sent = $self->{'loader'}->find_class('sent');          my $sent = $self->{'loader'}->find_class('sent');
556    
557          # will use null if no matching message_id is found          # will use null if no matching message_id is found
558          my $sent_msg = $sent->search( hash => $hash )->first;          my $sent_msg;
559            $sent_msg = $sent->search( hash => $hash )->first if ($hash);
560    
561          my ($message_id, $user_id) = (undef, undef);    # init with NULL          my ($message_id, $user_id) = (undef, undef);    # init with NULL
562    
563          if ($sent_msg) {          if ($sent_msg) {
564                  $message_id = $sent_msg->message_id || carp "no message_id";                  $message_id = $sent_msg->message_id || carp "no message_id";
565                  $user_id = $sent_msg->user_id || carp "no user_id";                  $user_id = $sent_msg->user_id || carp "no user_id";
566            } else {
567                    #warn "can't find sender with hash $hash\n";
568                    my $users = $self->{'loader'}->find_class('users');
569                    my $from = $m->header('From');
570                    $from = $1 if ($from =~ m/<(.*)>/);
571                    my $this_user = $users->search( email => lc($from) )->first;
572                    $user_id = $this_user->id if ($this_user);
573          }          }
574    
 print "message_id: ",($message_id || "not found"),"\n";  
575    
576          my $is_bounce = 0;          my $is_bounce = 0;
577    
578          my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(          if ($return_path eq '<>' || $return_path eq '') {
579                  $arg->{'message'}, { report_non_bounces=>1 },                  no warnings;
580          ) };                  my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
581          carp "can't check if this message is bounce!" if ($@);                          $arg->{'message'}, { report_non_bounces=>1 },
582                    ) };
583          $is_bounce++ if ($bounce && $bounce->is_bounce);                  #warn "can't check if this message is bounce!" if ($@);
584            
585                    $is_bounce++ if ($bounce && $bounce->is_bounce);
586            }
587    
588          my $received = $self->{'loader'}->find_class('received');          my $received = $self->{'loader'}->find_class('received');
589    
# Line 393  print "message_id: ",($message_id || "no Line 597  print "message_id: ",($message_id || "no
597    
598          $this_received->dbi_commit;          $this_received->dbi_commit;
599    
600          warn "inbox is not yet implemented";  #       print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
601  }  }
602    
603    
# Line 407  Create new list Line 611  Create new list
611    
612   my $list_obj = $nos->_add_list(   my $list_obj = $nos->_add_list(
613          list => 'My list',          list => 'My list',
614            from => 'Outgoing from comment',
615          email => 'my-list@example.com',          email => 'my-list@example.com',
616   );   );
617    
# Line 424  sub _add_list { Line 629  sub _add_list {
629    
630          my $arg = {@_};          my $arg = {@_};
631    
632          my $name = $arg->{'list'} || confess "can't add list without name";          my $name = lc($arg->{'list'}) || confess "can't add list without name";
633          my $email = $arg->{'email'} || confess "can't add list without e-mail";          my $email = lc($arg->{'email'}) || confess "can't add list without e-mail";
634            my $from_addr = $arg->{'from'};
635    
636          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
637    
# Line 433  sub _add_list { Line 639  sub _add_list {
639                  name => $name,                  name => $name,
640                  email => $email,                  email => $email,
641          });          });
642            
643          croak "can't add list $name\n" unless ($l);          croak "can't add list $name\n" unless ($l);
644    
645            if ($from_addr && $l->from_addr ne $from_addr) {
646                    $l->from_addr($from_addr);
647                    $l->update;
648            }
649    
650          $l->dbi_commit;          $l->dbi_commit;
651    
652          return $l;          return $l;
# Line 460  sub _get_list { Line 671  sub _get_list {
671    
672          my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";          my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";
673    
674          return $lists->search({ name => $name })->first;          return $lists->search({ name => lc($name) })->first;
675  }  }
676    
677  ###  ###
# Line 469  sub _get_list { Line 680  sub _get_list {
680    
681  package Nos::SOAP;  package Nos::SOAP;
682    
683    use Carp;
684    
685  =head1 SOAP methods  =head1 SOAP methods
686    
687  This methods are thin wrappers to provide SOAP calls. They are grouped in  This methods are thin wrappers to provide SOAP calls. They are grouped in
# Line 500  sub new { Line 713  sub new {
713    
714   $message_id = NewList(   $message_id = NewList(
715          list => 'My list',          list => 'My list',
716            from => 'Name of my list',
717          email => 'my-list@example.com'          email => 'my-list@example.com'
718   );   );
719    
# Line 510  sub NewList { Line 724  sub NewList {
724    
725          if ($_[0] !~ m/^HASH/) {          if ($_[0] !~ m/^HASH/) {
726                  return $nos->new_list(                  return $nos->new_list(
727                          list => $_[0], email => $_[1],                          list => $_[0], from => $_[1], email => $_[2],
728                  );                  );
729          } else {          } else {
730                  return $nos->new_list( %{ shift @_ } );                  return $nos->new_list( %{ shift @_ } );
731          }          }
732  }  }
733    
734    
735  =head2 AddMemberToList  =head2 AddMemberToList
736    
737   $member_id = AddMemberToList(   $member_id = AddMemberToList(
738          list => "My list",          list => 'My list',
739          email => "e-mail@example.com",          email => 'e-mail@example.com',
740          name => "Full Name"          name => 'Full Name',
741            ext_id => 42,
742   );   );
743    
744  =cut  =cut
# Line 532  sub AddMemberToList { Line 748  sub AddMemberToList {
748    
749          if ($_[0] !~ m/^HASH/) {          if ($_[0] !~ m/^HASH/) {
750                  return $nos->add_member_to_list(                  return $nos->add_member_to_list(
751                          list => $_[0], email => $_[1], name => $_[2],                          list => $_[0], email => $_[1], name => $_[2], ext_id => $_[4],
752                  );                  );
753          } else {          } else {
754                  return $nos->add_member_to_list( %{ shift @_ } );                  return $nos->add_member_to_list( %{ shift @_ } );
755          }          }
756  }  }
757    
758    
759    =head2 ListMembers
760    
761     my @members = ListMembers(
762            list => 'My list',
763     );
764    
765    Returns array of hashes with user informations, see C<list_members>.
766    
767    =cut
768    
769    sub ListMembers {
770            my $self = shift;
771    
772            my $list_name;
773    
774            if ($_[0] !~ m/^HASH/) {
775                    $list_name = shift;
776            } else {
777                    $list_name = $_[0]->{'list'};
778            }
779    
780            return $nos->list_members( list => $list_name );
781    }
782    
783  =head2 AddMessageToList  =head2 AddMessageToList
784    
785   $message_id = AddMessageToList(   $message_id = AddMessageToList(
Legend:
Removed from v.39  
changed lines
  Added in v.59
  ViewVC Help
Powered by ViewVC 1.1.26