/[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 66 by dpavlin, Fri Jul 8 11:46:35 2005 UTC revision 87 by dpavlin, Thu Sep 21 10:49:00 2006 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.5';  our $VERSION = '0.8';
20    
21  use Class::DBI::Loader;  use Class::DBI::Loader;
22  use Email::Valid;  use Email::Valid;
# Line 27  use Email::Simple; Line 27  use Email::Simple;
27  use Email::Address;  use Email::Address;
28  use Mail::DeliveryStatus::BounceParser;  use Mail::DeliveryStatus::BounceParser;
29  use Class::DBI::AbstractSearch;  use Class::DBI::AbstractSearch;
30    use SQL::Abstract;
31  use Mail::Alias;  use Mail::Alias;
32  use Cwd qw(abs_path);  use Cwd qw(abs_path);
33    
# Line 62  encoded) or anything else. Line 63  encoded) or anything else.
63  It will just queue your e-mail message to particular list (sending it to  It will just queue your e-mail message to particular list (sending it to
64  possibly remote Notice Sender SOAP server just once), send it out at  possibly remote Notice Sender SOAP server just once), send it out at
65  reasonable rate (so that it doesn't flood your e-mail infrastructure) and  reasonable rate (so that it doesn't flood your e-mail infrastructure) and
66  track replies.  keep track replies.
67    
68  It is best used to send smaller number of messages to more-or-less fixed  It is best used to send small number of messages to more-or-less fixed
69  list of recipients while allowing individual responses to be examined.  list of recipients while allowing individual responses to be examined.
70  Tipical use include replacing php e-mail sending code with SOAP call to  Tipical use include replacing php e-mail sending code with SOAP call to
71  Notice Sender. It does support additional C<ext_id> field for each member  Notice Sender. It does support additional C<ext_id> field for each member
# Line 72  which can be used to track some unique i Line 73  which can be used to track some unique i
73  particular user.  particular user.
74    
75  It comes with command-line utility C<sender.pl> which can be used to perform  It comes with command-line utility C<sender.pl> which can be used to perform
76  all available operation from scripts (see C<perldoc sender.pl>).  all available operation from scripts (see C<sender.pl --man>).
77  This command is also useful for debugging while writing client SOAP  This command is also useful for debugging while writing client SOAP
78  application.  application.
79    
# Line 120  sub new { Line 121  sub new {
121  }  }
122    
123    
124  =head2 new_list  =head2 create_list
125    
126  Create new list. Required arguments are name of C<list> and  Create new list. Required arguments are name of C<list>, C<email> address
127  C<email> address.  and path to C<aliases> file.
128    
129   $nos->new_list(   $nos->create_list(
130          list => 'My list',          list => 'My list',
131          from => 'Outgoing from comment',          from => 'Outgoing from comment',
132          email => 'my-list@example.com',          email => 'my-list@example.com',
133            aliases => '/etc/mail/mylist',
134            archive => '/path/to/mbox/archive',
135   );   );
136    
137  Returns ID of newly created list.  Returns ID of newly created list.
# Line 137  Calls internally C<_add_list>, see detai Line 140  Calls internally C<_add_list>, see detai
140    
141  =cut  =cut
142    
143  sub new_list {  sub create_list {
144          my $self = shift;          my $self = shift;
145    
146          my $arg = {@_};          my $arg = {@_};
# Line 156  sub new_list { Line 159  sub new_list {
159  }  }
160    
161    
162  =head2 delete_list  =head2 drop_list
163    
164  Delete list from database.  Delete list from database.
165    
166   my $ok = delete_list(   my $ok = drop_list(
167          list => 'My list'          list => 'My list'
168            aliases => '/etc/mail/mylist',
169   );   );
170    
171  Returns false if list doesn't exist.  Returns false if list doesn't exist.
172    
173  =cut  =cut
174    
175  sub delete_list {  sub drop_list {
176          my $self = shift;          my $self = shift;
177    
178          my $args = {@_};          my $args = {@_};
# Line 177  sub delete_list { Line 181  sub delete_list {
181    
182          $args->{'list'} = lc($args->{'list'});          $args->{'list'} = lc($args->{'list'});
183    
184            my $aliases = $args->{'aliases'} || croak "need path to aliases file";
185    
186          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
187    
188          my $this_list = $lists->search( name => $args->{'list'} )->first || return;          my $this_list = $lists->search( name => $args->{'list'} )->first || return;
189    
190            $self->_remove_alias( email => $this_list->email, aliases => $aliases);
191    
192          $this_list->delete || croak "can't delete list\n";          $this_list->delete || croak "can't delete list\n";
193    
194          return $lists->dbi_commit || croak "can't commit";          return $lists->dbi_commit || croak "can't commit";
# Line 260  List all members of some list. Line 268  List all members of some list.
268          list => 'My list',          list => 'My list',
269   );   );
270    
271  Returns array of hashes with user informations like this:  Returns array of hashes with user information like this:
272    
273   $member = {   $member = {
274          name => 'Dobrica Pavlinusic',          name => 'Dobrica Pavlinusic',
# Line 413  sub add_message_to_list { Line 421  sub add_message_to_list {
421    
422          my $m = Email::Simple->new($message_text) || croak "can't parse message";          my $m = Email::Simple->new($message_text) || croak "can't parse message";
423    
424          unless( $m->header('Subject') ) {          warn "message doesn't have Subject header\n" unless( $m->header('Subject') );
                 warn "message doesn't have Subject header\n";  
                 return;  
         }  
425    
426          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
427    
# Line 468  Send e-mail using SMTP server at 127.0.0 Line 473  Send e-mail using SMTP server at 127.0.0
473    
474  =back  =back
475    
476    Any other driver name will try to use C<Email::Send::that_driver> module.
477    
478  Default sleep wait between two messages is 3 seconds.  Default sleep wait between two messages is 3 seconds.
479    
480    This method will return number of succesfully sent messages.
481    
482  =cut  =cut
483    
484  sub send_queued_messages {  sub send_queued_messages {
# Line 482  sub send_queued_messages { Line 491  sub send_queued_messages {
491          my $sleep = $arg->{'sleep'};          my $sleep = $arg->{'sleep'};
492          $sleep ||= 3 unless defined($sleep);          $sleep ||= 3 unless defined($sleep);
493    
494            # number of messages sent o.k.
495            my $ok = 0;
496    
497          my $email_send_driver = 'Email::Send::IO';          my $email_send_driver = 'Email::Send::IO';
498          my @email_send_options;          my @email_send_options;
499    
500          if (lc($driver) eq 'smtp') {          if (lc($driver) eq 'smtp') {
501                  $email_send_driver = 'Email::Send::SMTP';                  $email_send_driver = 'Email::Send::SMTP';
502                  @email_send_options = ['127.0.0.1'];                  @email_send_options = ['127.0.0.1'];
503            } elsif ($driver && $driver ne '') {
504                    $email_send_driver = 'Email::Send::' . $driver;
505          } else {          } else {
506                  warn "dumping all messages to STDERR\n";                  warn "dumping all messages to STDERR\n";
507          }          }
# Line 539  sub send_queued_messages { Line 553  sub send_queued_messages {
553                                  my $m_obj = Email::Simple->new($msg) || croak "can't parse message";                                  my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
554    
555                                  $m_obj->header_set('Return-Path', $from_email_only) || croak "can't set Return-Path: header";                                  $m_obj->header_set('Return-Path', $from_email_only) || croak "can't set Return-Path: header";
556                                  $m_obj->header_set('Sender', $from_email_only) || croak "can't set Sender: header";                                  #$m_obj->header_set('Sender', $from_email_only) || croak "can't set Sender: header";
557                                  $m_obj->header_set('Errors-To', $from_email_only) || croak "can't set Errors-To: header";                                  $m_obj->header_set('Errors-To', $from_email_only) || croak "can't set Errors-To: header";
558                                  $m_obj->header_set('From', $from_addr) || croak "can't set From: header";                                  $m_obj->header_set('From', $from_addr) || croak "can't set From: header";
559                                  $m_obj->header_set('To', $to) || croak "can't set To: header";                                  $m_obj->header_set('To', $to) || croak "can't set To: header";
# Line 557  sub send_queued_messages { Line 571  sub send_queued_messages {
571                                  }                                  }
572    
573                                  croak "can't send e-mail: $sent_status\n\nOriginal e-mail follows:\n".$m_obj->as_string unless ($sent_status);                                  croak "can't send e-mail: $sent_status\n\nOriginal e-mail follows:\n".$m_obj->as_string unless ($sent_status);
574                                  my @bad = @{ $sent_status->prop('bad') };                                  my @bad;
575                                    @bad = @{ $sent_status->prop('bad') } if (eval { $sent_status->can('prop') });
576                                  croak "failed sending to ",join(",",@bad) if (@bad);                                  croak "failed sending to ",join(",",@bad) if (@bad);
577    
578                                  if ($sent_status) {                                  if ($sent_status) {
# Line 571  sub send_queued_messages { Line 586  sub send_queued_messages {
586    
587                                          print " - $sent_status\n";                                          print " - $sent_status\n";
588    
589                                            $ok++;
590                                  } else {                                  } else {
591                                          warn "ERROR: $sent_status\n";                                          warn "ERROR: $sent_status\n";
592                                  }                                  }
# Line 586  sub send_queued_messages { Line 602  sub send_queued_messages {
602                  $m->dbi_commit;                  $m->dbi_commit;
603          }          }
604    
605            return $ok;
606    
607  }  }
608    
609  =head2 inbox_message  =head2 inbox_message
# Line 684  sub inbox_message { Line 702  sub inbox_message {
702  #       print "message_id: ",($message_id || "not found")," -- $is_bounce\n";  #       print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
703  }  }
704    
705    =head2 received_messages
706    
707    Returns all received messages for given list or user.
708    
709     my @received = $nos->received_messages(
710            list => 'My list',
711            email => "john.doe@example.com",
712            from_date => '2005-01-01 10:15:00',
713            to_date => '2005-01-01 12:00:00',
714            message => 0,
715     );
716    
717    If don't specify C<list> or C<email> it will return all received messages.
718    Results will be sorted by received date, oldest first.
719    
720    Other optional parametars include:
721    
722    =over 10
723    
724    =item from_date
725    
726    Date (in ISO format) for lower limit of dates received
727    
728    =item to_date
729    
730    Return just messages older than this date
731    
732    =item message
733    
734    Include whole received message in result. This will probably make result
735    array very large. Use with care.
736    
737    =back
738    
739    Date ranges are inclusive, so results will include messages sent on
740    particular date specified with C<date_from> or C<date_to>.
741    
742    Each element in returned array will have following structure:
743    
744     my $row = {
745            id => 42,                       # unique ID of received message
746            list => 'My list',              # useful if filtering by email
747            ext_id => 9999,                 # ext_id from message sender
748            email => 'jdoe@example.com',    # e-mail of message sender
749            bounced => 0,                   # true if message is bounce
750            date => '2005-08-24 18:57:24',  # date of receival in ISO format
751     }
752    
753    If you specified C<message> option, this hash will also have C<message> key
754    which will contain whole received message.
755    
756    =cut
757    
758    sub received_messages {
759            my $self = shift;
760    
761            my $arg = {@_} if (@_);
762    
763    #       croak "need list name or email" unless ($arg->{'list'} || $arg->{'email'});
764    
765            my $sql = qq{
766                            select
767                                    received.id as id,
768                                    lists.name as list,
769                                    users.ext_id as ext_id,
770                                    users.email as email,
771            };
772            $sql .= qq{             message,} if ($arg->{'message'});
773            $sql .= qq{
774                                    bounced,received.date as date
775                            from received
776                            join lists on lists.id = list_id
777                            join users on users.id = user_id
778            };
779    
780            my $order = qq{ order by date asc };
781    
782            my $where;
783    
784            $where->{'lists.name'} = lc($arg->{'list'}) if ($arg->{'list'});
785            $where->{'users.email'} = lc($arg->{'email'}) if ($arg->{'email'});
786            $where->{'received.date'} = { '>=', $arg->{'date_from'} } if ($arg->{'date_from'});
787            $where->{'received.date'} = { '<=', $arg->{'date_to'} } if ($arg->{'date_to'});
788    
789            # hum, yammy one-liner
790            my($stmt, @bind)  = SQL::Abstract->new->where($where);
791    
792            my $dbh = $self->{'loader'}->find_class('received')->db_Main;
793    
794            my $sth = $dbh->prepare($sql . $stmt . $order);
795            $sth->execute(@bind);
796            return $sth->fetchall_hash;
797    }
798    
799    
800  =head1 INTERNAL METHODS  =head1 INTERNAL METHODS
801    
# Line 692  Beware of dragons! You shouldn't need to Line 804  Beware of dragons! You shouldn't need to
804    
805  =head2 _add_aliases  =head2 _add_aliases
806    
807  Add new list to C</etc/aliases> (or equivavlent) file  Add or update alias in C</etc/aliases> (or equivalent) file for selected list
808    
809   my $ok = $nos->add_aliases(   my $ok = $nos->add_aliases(
810          list => 'My list',          list => 'My list',
# Line 713  sub _add_aliases { Line 825  sub _add_aliases {
825    
826          my $arg = {@_};          my $arg = {@_};
827    
828          croak "need list and email options" unless ($arg->{'list'} && $arg->{'email'});          foreach my $o (qw/list email aliases/) {
829                    croak "need $o option" unless ($arg->{$o});
830            }
831    
832          my $aliases = $arg->{'aliases'} || croak "need aliases";          my $aliases = $arg->{'aliases'};
833            my $email = $arg->{'email'};
834            my $list = $arg->{'list'};
835    
836          unless (-e $aliases) {          unless (-e $aliases) {
837                  warn "aliases file $aliases doesn't exist, creating empty\n";                  warn "aliases file $aliases doesn't exist, creating empty\n";
838                  open(my $fh, '>', $aliases) || croak "can't create $aliases: $!";                  open(my $fh, '>', $aliases) || croak "can't create $aliases: $!";
839                  close($fh);                  close($fh);
840                    chmod 0777, $aliases || warn "can't change permission to 0777";
841          }          }
842    
843            die "FATAL: aliases file $aliases is not writable\n" unless (-w $aliases);
844    
845          my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";          my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
846    
847          my $target = '';          my $target = '';
# Line 744  sub _add_aliases { Line 863  sub _add_aliases {
863          $self_path =~ s#/[^/]+$##;          $self_path =~ s#/[^/]+$##;
864          $self_path =~ s#/t/*$#/#;          $self_path =~ s#/t/*$#/#;
865    
866          $target .= qq#| cd $self_path && ./sender.pl --inbox="$arg->{'list'}"#;          $target .= qq#"| cd $self_path && ./sender.pl --inbox='$list'"#;
867    
868            # remove hostname from email to make Postfix's postalias happy
869            $email =~ s/@.+//;
870    
871          unless ($a->append($arg->{'email'}, $target)) {          if ($a->exists($email)) {
872                  croak "can't add alias ".$a->error_check;                  $a->update($email, $target) or croak "can't update alias ".$a->error_check;
873            } else {
874                    $a->append($email, $target) or croak "can't add alias ".$a->error_check;
875          }          }
876    
877            #$a->write($aliases) or croak "can't save aliases $aliases ".$a->error_check;
878    
879          return 1;          return 1;
880  }  }
881    
# Line 790  sub _add_list { Line 916  sub _add_list {
916                  list => $name,                  list => $name,
917                  email => $email,                  email => $email,
918                  aliases => $aliases,                  aliases => $aliases,
919          ) || croak "can't add alias $email for list $name";          ) || warn "can't add alias $email for list $name";
920    
921          my $l = $lists->find_or_create({          my $l = $lists->find_or_create({
922                  name => $name,                  name => $name,
# Line 832  sub _get_list { Line 958  sub _get_list {
958          return $lists->search({ name => lc($name) })->first;          return $lists->search({ name => lc($name) })->first;
959  }  }
960    
961    
962    =head2 _remove_alias
963    
964    Remove list alias
965    
966     my $ok = $nos->_remove_alias(
967            email => 'mylist@example.com',
968            aliases => '/etc/mail/mylist',
969     );
970    
971    Returns true if list is removed or false if list doesn't exist. Dies in case of error.
972    
973    =cut
974    
975    sub _remove_alias {
976            my $self = shift;
977    
978            my $arg = {@_};
979    
980            my $email = lc($arg->{'email'}) || confess "can't remove alias without email";
981            my $aliases = lc($arg->{'aliases'}) || confess "can't remove alias without list";
982    
983            my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
984    
985            if ($a->exists($email)) {
986                    $a->delete($email) || croak "can't remove alias $email";
987            } else {
988                    return 0;
989            }
990    
991            return 1;
992    
993    }
994    
995  ###  ###
996  ### SOAP  ### SOAP
997  ###  ###
# Line 871  Create new SOAP object Line 1031  Create new SOAP object
1031          aliases => '/etc/aliases',          aliases => '/etc/aliases',
1032   );   );
1033    
1034    If you are writing SOAP server (like C<soap.cgi> example), you will need to
1035    call this method once to make new instance of Nos::SOAP and specify C<dsn>
1036    and options for it.
1037    
1038  =cut  =cut
1039    
1040  sub new {  sub new {
# Line 887  sub new { Line 1051  sub new {
1051  }  }
1052    
1053    
1054  =head2 NewList  =head2 CreateList
1055    
1056   $message_id = NewList(   $message_id = CreateList(
1057          list => 'My list',          list => 'My list',
1058          from => 'Name of my list',          from => 'Name of my list',
1059          email => 'my-list@example.com'          email => 'my-list@example.com'
# Line 897  sub new { Line 1061  sub new {
1061    
1062  =cut  =cut
1063    
1064  sub NewList {  sub CreateList {
1065          my $self = shift;          my $self = shift;
1066    
1067          my $aliases = $self->{'aliases'} || croak "Nos::SOAP need 'aliases' argument to new constructor";          my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
1068    
1069          if ($_[0] !~ m/^HASH/) {          if ($_[0] !~ m/^HASH/) {
1070                  return $nos->new_list(                  return $nos->create_list(
1071                          list => $_[0], from => $_[1], email => $_[2],                          list => $_[0], from => $_[1], email => $_[2],
1072                          aliases => $aliases,                          aliases => $aliases,
1073                  );                  );
1074          } else {          } else {
1075                  return $nos->new_list( %{ shift @_ }, aliases => $aliases );                  return $nos->create_list( %{ shift @_ }, aliases => $aliases );
1076          }          }
1077  }  }
1078    
1079    
1080  =head2 DeleteList  =head2 DropList
1081    
1082   $ok = DeleteList(   $ok = DropList(
1083          list => 'My list',          list => 'My list',
1084   );   );
1085    
1086  =cut  =cut
1087    
1088  sub DeleteList {  sub DropList {
1089          my $self = shift;          my $self = shift;
1090    
1091            my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
1092    
1093          if ($_[0] !~ m/^HASH/) {          if ($_[0] !~ m/^HASH/) {
1094                  return $nos->delete_list(                  return $nos->drop_list(
1095                          list => $_[0],                          list => $_[0],
1096                            aliases => $aliases,
1097                  );                  );
1098          } else {          } else {
1099                  return $nos->delete_list( %{ shift @_ } );                  return $nos->drop_list( %{ shift @_ }, aliases => $aliases );
1100          }          }
1101  }  }
1102    
# Line 949  sub AddMemberToList { Line 1116  sub AddMemberToList {
1116    
1117          if ($_[0] !~ m/^HASH/) {          if ($_[0] !~ m/^HASH/) {
1118                  return $nos->add_member_to_list(                  return $nos->add_member_to_list(
1119                          list => $_[0], email => $_[1], name => $_[2], ext_id => $_[4],                          list => $_[0], email => $_[1], name => $_[2], ext_id => $_[3],
1120                  );                  );
1121          } else {          } else {
1122                  return $nos->add_member_to_list( %{ shift @_ } );                  return $nos->add_member_to_list( %{ shift @_ } );
# Line 965  sub AddMemberToList { Line 1132  sub AddMemberToList {
1132    
1133  Returns array of hashes with user informations, see C<list_members>.  Returns array of hashes with user informations, see C<list_members>.
1134    
 Returning arrays from SOAP calls is somewhat fuzzy (at least to me). It  
 seems that SOAP::Lite client thinks that it has array with one element which  
 is array of hashes with data.  
   
1135  =cut  =cut
1136    
1137  sub ListMembers {  sub ListMembers {
# Line 1029  sub AddMessageToList { Line 1192  sub AddMessageToList {
1192          }          }
1193  }  }
1194    
1195    =head2 MessagesReceived
1196    
1197    Return statistics about received messages.
1198    
1199     my @result = MessagesReceived(
1200            list => 'My list',
1201            email => 'jdoe@example.com',
1202            from_date => '2005-01-01 10:15:00',
1203            to_date => '2005-01-01 12:00:00',
1204            message => 0,
1205     );
1206    
1207    You must specify C<list> or C<email> or any combination of those two. Other
1208    parametars are optional.
1209    
1210    For format of returned array element see C<received_messages>.
1211    
1212    =cut
1213    
1214    sub MessagesReceived {
1215            my $self = shift;
1216    
1217            if ($_[0] !~ m/^HASH/) {
1218                    die "need at least list or email" unless (scalar @_ < 2);
1219                    return \@{ $nos->received_messages(
1220                            list => $_[0], email => $_[1],
1221                            from_date => $_[2], to_date => $_[3],
1222                            message => $_[4]
1223                    ) };
1224            } else {
1225                    my $arg = shift;
1226                    die "need list or email argument" unless ($arg->{'list'} || $arg->{'email'});
1227                    return \@{ $nos->received_messages( %{ $arg } ) };
1228            }
1229    }
1230    
1231  ###  ###
1232    
1233    =head1 NOTE ON ARRAYS IN SOAP
1234    
1235    Returning arrays from SOAP calls is somewhat fuzzy (at least to me). It
1236    seems that SOAP::Lite client thinks that it has array with one element which
1237    is array of hashes with data.
1238    
1239  =head1 EXPORT  =head1 EXPORT
1240    
1241  Nothing.  Nothing.
Legend:
Removed from v.66  
changed lines
  Added in v.87
  ViewVC Help
Powered by ViewVC 1.1.26