/[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 67 by dpavlin, Fri Jul 8 17:00:20 2005 UTC revision 86 by dpavlin, Tue Sep 6 11:14:49 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.6';  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>, C<email> address  Create new list. Required arguments are name of C<list>, C<email> address
127  and path to C<aliases> file.  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',
# Line 139  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 158  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 179  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 262  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 470  Send e-mail using SMTP server at 127.0.0 Line 476  Send e-mail using SMTP server at 127.0.0
476    
477  =back  =back
478    
479    Any other driver name will try to use C<Email::Send::that_driver> module.
480    
481  Default sleep wait between two messages is 3 seconds.  Default sleep wait between two messages is 3 seconds.
482    
483    This method will return number of succesfully sent messages.
484    
485  =cut  =cut
486    
487  sub send_queued_messages {  sub send_queued_messages {
# Line 484  sub send_queued_messages { Line 494  sub send_queued_messages {
494          my $sleep = $arg->{'sleep'};          my $sleep = $arg->{'sleep'};
495          $sleep ||= 3 unless defined($sleep);          $sleep ||= 3 unless defined($sleep);
496    
497            # number of messages sent o.k.
498            my $ok = 0;
499    
500          my $email_send_driver = 'Email::Send::IO';          my $email_send_driver = 'Email::Send::IO';
501          my @email_send_options;          my @email_send_options;
502    
503          if (lc($driver) eq 'smtp') {          if (lc($driver) eq 'smtp') {
504                  $email_send_driver = 'Email::Send::SMTP';                  $email_send_driver = 'Email::Send::SMTP';
505                  @email_send_options = ['127.0.0.1'];                  @email_send_options = ['127.0.0.1'];
506            } elsif ($driver && $driver ne '') {
507                    $email_send_driver = 'Email::Send::' . $driver;
508          } else {          } else {
509                  warn "dumping all messages to STDERR\n";                  warn "dumping all messages to STDERR\n";
510          }          }
# Line 541  sub send_queued_messages { Line 556  sub send_queued_messages {
556                                  my $m_obj = Email::Simple->new($msg) || croak "can't parse message";                                  my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
557    
558                                  $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";
559                                  $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";
560                                  $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";
561                                  $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";
562                                  $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 559  sub send_queued_messages { Line 574  sub send_queued_messages {
574                                  }                                  }
575    
576                                  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);
577                                  my @bad = @{ $sent_status->prop('bad') };                                  my @bad;
578                                    @bad = @{ $sent_status->prop('bad') } if (eval { $sent_status->can('prop') });
579                                  croak "failed sending to ",join(",",@bad) if (@bad);                                  croak "failed sending to ",join(",",@bad) if (@bad);
580    
581                                  if ($sent_status) {                                  if ($sent_status) {
# Line 573  sub send_queued_messages { Line 589  sub send_queued_messages {
589    
590                                          print " - $sent_status\n";                                          print " - $sent_status\n";
591    
592                                            $ok++;
593                                  } else {                                  } else {
594                                          warn "ERROR: $sent_status\n";                                          warn "ERROR: $sent_status\n";
595                                  }                                  }
# Line 588  sub send_queued_messages { Line 605  sub send_queued_messages {
605                  $m->dbi_commit;                  $m->dbi_commit;
606          }          }
607    
608            return $ok;
609    
610  }  }
611    
612  =head2 inbox_message  =head2 inbox_message
# Line 686  sub inbox_message { Line 705  sub inbox_message {
705  #       print "message_id: ",($message_id || "not found")," -- $is_bounce\n";  #       print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
706  }  }
707    
708    =head2 received_messages
709    
710    Returns all received messages for given list or user.
711    
712     my @received = $nos->received_messages(
713            list => 'My list',
714            email => "john.doe@example.com",
715            from_date => '2005-01-01 10:15:00',
716            to_date => '2005-01-01 12:00:00',
717            message => 0,
718     );
719    
720    If don't specify C<list> or C<email> it will return all received messages.
721    Results will be sorted by received date, oldest first.
722    
723    Other optional parametars include:
724    
725    =over 10
726    
727    =item from_date
728    
729    Date (in ISO format) for lower limit of dates received
730    
731    =item to_date
732    
733    Return just messages older than this date
734    
735    =item message
736    
737    Include whole received message in result. This will probably make result
738    array very large. Use with care.
739    
740    =back
741    
742    Date ranges are inclusive, so results will include messages sent on
743    particular date specified with C<date_from> or C<date_to>.
744    
745    Each element in returned array will have following structure:
746    
747     my $row = {
748            id => 42,                       # unique ID of received message
749            list => 'My list',              # useful if filtering by email
750            ext_id => 9999,                 # ext_id from message sender
751            email => 'jdoe@example.com',    # e-mail of message sender
752            bounced => 0,                   # true if message is bounce
753            date => '2005-08-24 18:57:24',  # date of receival in ISO format
754     }
755    
756    If you specified C<message> option, this hash will also have C<message> key
757    which will contain whole received message.
758    
759    =cut
760    
761    sub received_messages {
762            my $self = shift;
763    
764            my $arg = {@_} if (@_);
765    
766    #       croak "need list name or email" unless ($arg->{'list'} || $arg->{'email'});
767    
768            my $sql = qq{
769                            select
770                                    received.id as id,
771                                    lists.name as list,
772                                    users.ext_id as ext_id,
773                                    users.email as email,
774            };
775            $sql .= qq{             message,} if ($arg->{'message'});
776            $sql .= qq{
777                                    bounced,received.date as date
778                            from received
779                            join lists on lists.id = list_id
780                            join users on users.id = user_id
781            };
782    
783            my $order = qq{ order by date asc };
784    
785            my $where;
786    
787            $where->{'lists.name'} = lc($arg->{'list'}) if ($arg->{'list'});
788            $where->{'users.email'} = lc($arg->{'email'}) if ($arg->{'email'});
789            $where->{'received.date'} = { '>=', $arg->{'date_from'} } if ($arg->{'date_from'});
790            $where->{'received.date'} = { '<=', $arg->{'date_to'} } if ($arg->{'date_to'});
791    
792            # hum, yammy one-liner
793            my($stmt, @bind)  = SQL::Abstract->new->where($where);
794    
795            my $dbh = $self->{'loader'}->find_class('received')->db_Main;
796    
797            my $sth = $dbh->prepare($sql . $stmt . $order);
798            $sth->execute(@bind);
799            return $sth->fetchall_hash;
800    }
801    
802    
803  =head1 INTERNAL METHODS  =head1 INTERNAL METHODS
804    
# Line 694  Beware of dragons! You shouldn't need to Line 807  Beware of dragons! You shouldn't need to
807    
808  =head2 _add_aliases  =head2 _add_aliases
809    
810  Add new list to C</etc/aliases> (or equivavlent) file  Add or update alias in C</etc/aliases> (or equivalent) file for selected list
811    
812   my $ok = $nos->add_aliases(   my $ok = $nos->add_aliases(
813          list => 'My list',          list => 'My list',
# Line 715  sub _add_aliases { Line 828  sub _add_aliases {
828    
829          my $arg = {@_};          my $arg = {@_};
830    
831          croak "need list and email options" unless ($arg->{'list'} && $arg->{'email'});          foreach my $o (qw/list email aliases/) {
832                    croak "need $o option" unless ($arg->{$o});
833            }
834    
835          my $aliases = $arg->{'aliases'} || croak "need aliases";          my $aliases = $arg->{'aliases'};
836            my $email = $arg->{'email'};
837            my $list = $arg->{'list'};
838    
839          unless (-e $aliases) {          unless (-e $aliases) {
840                  warn "aliases file $aliases doesn't exist, creating empty\n";                  warn "aliases file $aliases doesn't exist, creating empty\n";
# Line 726  sub _add_aliases { Line 843  sub _add_aliases {
843                  chmod 0777, $aliases || warn "can't change permission to 0777";                  chmod 0777, $aliases || warn "can't change permission to 0777";
844          }          }
845    
846            die "FATAL: aliases file $aliases is not writable\n" unless (-w $aliases);
847    
848          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: $!";
849    
850          my $target = '';          my $target = '';
# Line 747  sub _add_aliases { Line 866  sub _add_aliases {
866          $self_path =~ s#/[^/]+$##;          $self_path =~ s#/[^/]+$##;
867          $self_path =~ s#/t/*$#/#;          $self_path =~ s#/t/*$#/#;
868    
869          $target .= qq#| cd $self_path && ./sender.pl --inbox="$arg->{'list'}"#;          $target .= qq#"| cd $self_path && ./sender.pl --inbox='$list'"#;
870    
871          unless ($a->append($arg->{'email'}, $target)) {          # remove hostname from email to make Postfix's postalias happy
872                  croak "can't add alias ".$a->error_check;          $email =~ s/@.+//;
873    
874            if ($a->exists($email)) {
875                    $a->update($email, $target) or croak "can't update alias ".$a->error_check;
876            } else {
877                    $a->append($email, $target) or croak "can't add alias ".$a->error_check;
878          }          }
879    
880            #$a->write($aliases) or croak "can't save aliases $aliases ".$a->error_check;
881    
882          return 1;          return 1;
883  }  }
884    
# Line 793  sub _add_list { Line 919  sub _add_list {
919                  list => $name,                  list => $name,
920                  email => $email,                  email => $email,
921                  aliases => $aliases,                  aliases => $aliases,
922          ) || croak "can't add alias $email for list $name";          ) || warn "can't add alias $email for list $name";
923    
924          my $l = $lists->find_or_create({          my $l = $lists->find_or_create({
925                  name => $name,                  name => $name,
# Line 835  sub _get_list { Line 961  sub _get_list {
961          return $lists->search({ name => lc($name) })->first;          return $lists->search({ name => lc($name) })->first;
962  }  }
963    
964    
965    =head2 _remove_alias
966    
967    Remove list alias
968    
969     my $ok = $nos->_remove_alias(
970            email => 'mylist@example.com',
971            aliases => '/etc/mail/mylist',
972     );
973    
974    Returns true if list is removed or false if list doesn't exist. Dies in case of error.
975    
976    =cut
977    
978    sub _remove_alias {
979            my $self = shift;
980    
981            my $arg = {@_};
982    
983            my $email = lc($arg->{'email'}) || confess "can't remove alias without email";
984            my $aliases = lc($arg->{'aliases'}) || confess "can't remove alias without list";
985    
986            my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
987    
988            if ($a->exists($email)) {
989                    $a->delete($email) || croak "can't remove alias $email";
990            } else {
991                    return 0;
992            }
993    
994            return 1;
995    
996    }
997    
998  ###  ###
999  ### SOAP  ### SOAP
1000  ###  ###
# Line 874  Create new SOAP object Line 1034  Create new SOAP object
1034          aliases => '/etc/aliases',          aliases => '/etc/aliases',
1035   );   );
1036    
1037    If you are writing SOAP server (like C<soap.cgi> example), you will need to
1038    call this method once to make new instance of Nos::SOAP and specify C<dsn>
1039    and options for it.
1040    
1041  =cut  =cut
1042    
1043  sub new {  sub new {
# Line 890  sub new { Line 1054  sub new {
1054  }  }
1055    
1056    
1057  =head2 NewList  =head2 CreateList
1058    
1059   $message_id = NewList(   $message_id = CreateList(
1060          list => 'My list',          list => 'My list',
1061          from => 'Name of my list',          from => 'Name of my list',
1062          email => 'my-list@example.com'          email => 'my-list@example.com'
# Line 900  sub new { Line 1064  sub new {
1064    
1065  =cut  =cut
1066    
1067  sub NewList {  sub CreateList {
1068          my $self = shift;          my $self = shift;
1069    
1070          croak "self is not Nos::SOAP object" unless (ref($self) eq 'Nos::SOAP');          my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
   
         my $aliases = $self->{'aliases'} || croak "need 'aliases' argument to new constructor";  
1071    
1072          if ($_[0] !~ m/^HASH/) {          if ($_[0] !~ m/^HASH/) {
1073                  return $nos->new_list(                  return $nos->create_list(
1074                          list => $_[0], from => $_[1], email => $_[2],                          list => $_[0], from => $_[1], email => $_[2],
1075                          aliases => $aliases,                          aliases => $aliases,
1076                  );                  );
1077          } else {          } else {
1078                  return $nos->new_list( %{ shift @_ }, aliases => $aliases );                  return $nos->create_list( %{ shift @_ }, aliases => $aliases );
1079          }          }
1080  }  }
1081    
1082    
1083  =head2 DeleteList  =head2 DropList
1084    
1085   $ok = DeleteList(   $ok = DropList(
1086          list => 'My list',          list => 'My list',
1087   );   );
1088    
1089  =cut  =cut
1090    
1091  sub DeleteList {  sub DropList {
1092          my $self = shift;          my $self = shift;
1093    
1094            my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
1095    
1096          if ($_[0] !~ m/^HASH/) {          if ($_[0] !~ m/^HASH/) {
1097                  return $nos->delete_list(                  return $nos->drop_list(
1098                          list => $_[0],                          list => $_[0],
1099                            aliases => $aliases,
1100                  );                  );
1101          } else {          } else {
1102                  return $nos->delete_list( %{ shift @_ } );                  return $nos->drop_list( %{ shift @_ }, aliases => $aliases );
1103          }          }
1104  }  }
1105    
# Line 954  sub AddMemberToList { Line 1119  sub AddMemberToList {
1119    
1120          if ($_[0] !~ m/^HASH/) {          if ($_[0] !~ m/^HASH/) {
1121                  return $nos->add_member_to_list(                  return $nos->add_member_to_list(
1122                          list => $_[0], email => $_[1], name => $_[2], ext_id => $_[4],                          list => $_[0], email => $_[1], name => $_[2], ext_id => $_[3],
1123                  );                  );
1124          } else {          } else {
1125                  return $nos->add_member_to_list( %{ shift @_ } );                  return $nos->add_member_to_list( %{ shift @_ } );
# Line 970  sub AddMemberToList { Line 1135  sub AddMemberToList {
1135    
1136  Returns array of hashes with user informations, see C<list_members>.  Returns array of hashes with user informations, see C<list_members>.
1137    
 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.  
   
1138  =cut  =cut
1139    
1140  sub ListMembers {  sub ListMembers {
# Line 1034  sub AddMessageToList { Line 1195  sub AddMessageToList {
1195          }          }
1196  }  }
1197    
1198    =head2 MessagesReceived
1199    
1200    Return statistics about received messages.
1201    
1202     my @result = MessagesReceived(
1203            list => 'My list',
1204            email => 'jdoe@example.com',
1205            from_date => '2005-01-01 10:15:00',
1206            to_date => '2005-01-01 12:00:00',
1207            message => 0,
1208     );
1209    
1210    You must specify C<list> or C<email> or any combination of those two. Other
1211    parametars are optional.
1212    
1213    For format of returned array element see C<received_messages>.
1214    
1215    =cut
1216    
1217    sub MessagesReceived {
1218            my $self = shift;
1219    
1220            if ($_[0] !~ m/^HASH/) {
1221                    die "need at least list or email" unless (scalar @_ < 2);
1222                    return \@{ $nos->received_messages(
1223                            list => $_[0], email => $_[1],
1224                            from_date => $_[2], to_date => $_[3],
1225                            message => $_[4]
1226                    ) };
1227            } else {
1228                    my $arg = shift;
1229                    die "need list or email argument" unless ($arg->{'list'} || $arg->{'email'});
1230                    return \@{ $nos->received_messages( %{ $arg } ) };
1231            }
1232    }
1233    
1234  ###  ###
1235    
1236    =head1 NOTE ON ARRAYS IN SOAP
1237    
1238    Returning arrays from SOAP calls is somewhat fuzzy (at least to me). It
1239    seems that SOAP::Lite client thinks that it has array with one element which
1240    is array of hashes with data.
1241    
1242  =head1 EXPORT  =head1 EXPORT
1243    
1244  Nothing.  Nothing.
Legend:
Removed from v.67  
changed lines
  Added in v.86
  ViewVC Help
Powered by ViewVC 1.1.26