/[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 68 by dpavlin, Mon Aug 1 08:59:36 2005 UTC revision 89 by dpavlin, Mon Dec 18 18:55:43 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.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 89  Create new instance specifing database, Line 90  Create new instance specifing database,
90          debug => 1,          debug => 1,
91          verbose => 1,          verbose => 1,
92          hash_len => 8,          hash_len => 8,
93            full_hostname_in_aliases => 0,
94   );   );
95    
96  Parametar C<hash_len> defines length of hash which will be added to each  Parametar C<hash_len> defines length of hash which will be added to each
97  outgoing e-mail message to ensure that replies can be linked with sent e-mails.  outgoing e-mail message to ensure that replies can be linked with sent e-mails.
98    
99    C<full_hostname_in_aliases> will turn on old behaviour (not supported by Postfix
100    postalias) to include full hostname in aliases file.
101    
102    
103  =cut  =cut
104    
105  sub new {  sub new {
106          my $class = shift;          my $class = shift;
107          my $self = {@_};          my $self = {@_};
108          bless($self, $class);          bless($self, $class);
109    
110          croak "need at least dsn" unless ($self->{'dsn'});          croak "need at least dsn" unless ($self->{'dsn'});
# Line 120  sub new { Line 126  sub new {
126  }  }
127    
128    
129  =head2 new_list  =head2 create_list
130    
131  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
132  and path to C<aliases> file.  and path to C<aliases> file.
133    
134   $nos->new_list(   $nos->create_list(
135          list => 'My list',          list => 'My list',
136          from => 'Outgoing from comment',          from => 'Outgoing from comment',
137          email => 'my-list@example.com',          email => 'my-list@example.com',
# Line 139  Calls internally C<_add_list>, see detai Line 145  Calls internally C<_add_list>, see detai
145    
146  =cut  =cut
147    
148  sub new_list {  sub create_list {
149          my $self = shift;          my $self = shift;
150    
151          my $arg = {@_};          my $arg = {@_};
# Line 158  sub new_list { Line 164  sub new_list {
164  }  }
165    
166    
167  =head2 delete_list  =head2 drop_list
168    
169  Delete list from database.  Delete list from database.
170    
171   my $ok = delete_list(   my $ok = drop_list(
172          list => 'My list'          list => 'My list'
173            aliases => '/etc/mail/mylist',
174   );   );
175    
176  Returns false if list doesn't exist.  Returns false if list doesn't exist.
177    
178  =cut  =cut
179    
180  sub delete_list {  sub drop_list {
181          my $self = shift;          my $self = shift;
182    
183          my $args = {@_};          my $args = {@_};
# Line 179  sub delete_list { Line 186  sub delete_list {
186    
187          $args->{'list'} = lc($args->{'list'});          $args->{'list'} = lc($args->{'list'});
188    
189            my $aliases = $args->{'aliases'} || croak "need path to aliases file";
190    
191          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
192    
193          my $this_list = $lists->search( name => $args->{'list'} )->first || return;          my $this_list = $lists->search( name => $args->{'list'} )->first || return;
194    
195            $self->_remove_alias( email => $this_list->email, aliases => $aliases);
196    
197          $this_list->delete || croak "can't delete list\n";          $this_list->delete || croak "can't delete list\n";
198    
199          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 273  List all members of some list.
273          list => 'My list',          list => 'My list',
274   );   );
275    
276  Returns array of hashes with user informations like this:  Returns array of hashes with user information like this:
277    
278   $member = {   $member = {
279          name => 'Dobrica Pavlinusic',          name => 'Dobrica Pavlinusic',
# Line 415  sub add_message_to_list { Line 426  sub add_message_to_list {
426    
427          my $m = Email::Simple->new($message_text) || croak "can't parse message";          my $m = Email::Simple->new($message_text) || croak "can't parse message";
428    
429          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;  
         }  
430    
431          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
432    
# Line 470  Send e-mail using SMTP server at 127.0.0 Line 478  Send e-mail using SMTP server at 127.0.0
478    
479  =back  =back
480    
481    Any other driver name will try to use C<Email::Send::that_driver> module.
482    
483  Default sleep wait between two messages is 3 seconds.  Default sleep wait between two messages is 3 seconds.
484    
485    This method will return number of succesfully sent messages.
486    
487  =cut  =cut
488    
489  sub send_queued_messages {  sub send_queued_messages {
# Line 484  sub send_queued_messages { Line 496  sub send_queued_messages {
496          my $sleep = $arg->{'sleep'};          my $sleep = $arg->{'sleep'};
497          $sleep ||= 3 unless defined($sleep);          $sleep ||= 3 unless defined($sleep);
498    
499            # number of messages sent o.k.
500            my $ok = 0;
501    
502          my $email_send_driver = 'Email::Send::IO';          my $email_send_driver = 'Email::Send::IO';
503          my @email_send_options;          my @email_send_options;
504    
505          if (lc($driver) eq 'smtp') {          if (lc($driver) eq 'smtp') {
506                  $email_send_driver = 'Email::Send::SMTP';                  $email_send_driver = 'Email::Send::SMTP';
507                  @email_send_options = ['127.0.0.1'];                  @email_send_options = ['127.0.0.1'];
508            } elsif ($driver && $driver ne '') {
509                    $email_send_driver = 'Email::Send::' . $driver;
510          } else {          } else {
511                  warn "dumping all messages to STDERR\n";                  warn "dumping all messages to STDERR\n";
512          }          }
# Line 541  sub send_queued_messages { Line 558  sub send_queued_messages {
558                                  my $m_obj = Email::Simple->new($msg) || croak "can't parse message";                                  my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
559    
560                                  $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";
561                                  $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";
562                                  $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";
563                                  $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";
564                                  $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 576  sub send_queued_messages {
576                                  }                                  }
577    
578                                  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);
579                                  my @bad = @{ $sent_status->prop('bad') };                                  my @bad;
580                                    @bad = @{ $sent_status->prop('bad') } if (eval { $sent_status->can('prop') });
581                                  croak "failed sending to ",join(",",@bad) if (@bad);                                  croak "failed sending to ",join(",",@bad) if (@bad);
582    
583                                  if ($sent_status) {                                  if ($sent_status) {
# Line 573  sub send_queued_messages { Line 591  sub send_queued_messages {
591    
592                                          print " - $sent_status\n";                                          print " - $sent_status\n";
593    
594                                            $ok++;
595                                  } else {                                  } else {
596                                          warn "ERROR: $sent_status\n";                                          warn "ERROR: $sent_status\n";
597                                  }                                  }
# Line 588  sub send_queued_messages { Line 607  sub send_queued_messages {
607                  $m->dbi_commit;                  $m->dbi_commit;
608          }          }
609    
610            return $ok;
611    
612  }  }
613    
614  =head2 inbox_message  =head2 inbox_message
# Line 686  sub inbox_message { Line 707  sub inbox_message {
707  #       print "message_id: ",($message_id || "not found")," -- $is_bounce\n";  #       print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
708  }  }
709    
710    =head2 received_messages
711    
712    Returns all received messages for given list or user.
713    
714     my @received = $nos->received_messages(
715            list => 'My list',
716            email => "john.doe@example.com",
717            from_date => '2005-01-01 10:15:00',
718            to_date => '2005-01-01 12:00:00',
719            message => 0,
720     );
721    
722    If don't specify C<list> or C<email> it will return all received messages.
723    Results will be sorted by received date, oldest first.
724    
725    Other optional parametars include:
726    
727    =over 10
728    
729    =item from_date
730    
731    Date (in ISO format) for lower limit of dates received
732    
733    =item to_date
734    
735    Return just messages older than this date
736    
737    =item message
738    
739    Include whole received message in result. This will probably make result
740    array very large. Use with care.
741    
742    =back
743    
744    Date ranges are inclusive, so results will include messages sent on
745    particular date specified with C<date_from> or C<date_to>.
746    
747    Each element in returned array will have following structure:
748    
749     my $row = {
750            id => 42,                       # unique ID of received message
751            list => 'My list',              # useful if filtering by email
752            ext_id => 9999,                 # ext_id from message sender
753            email => 'jdoe@example.com',    # e-mail of message sender
754            bounced => 0,                   # true if message is bounce
755            date => '2005-08-24 18:57:24',  # date of receival in ISO format
756     }
757    
758    If you specified C<message> option, this hash will also have C<message> key
759    which will contain whole received message.
760    
761    =cut
762    
763    sub received_messages {
764            my $self = shift;
765    
766            my $arg = {@_} if (@_);
767    
768    #       croak "need list name or email" unless ($arg->{'list'} || $arg->{'email'});
769    
770            my $sql = qq{
771                            select
772                                    received.id as id,
773                                    lists.name as list,
774                                    users.ext_id as ext_id,
775                                    users.email as email,
776            };
777            $sql .= qq{             message,} if ($arg->{'message'});
778            $sql .= qq{
779                                    bounced,received.date as date
780                            from received
781                            join lists on lists.id = list_id
782                            join users on users.id = user_id
783            };
784    
785            my $order = qq{ order by date asc };
786    
787            my $where;
788    
789            $where->{'lists.name'} = lc($arg->{'list'}) if ($arg->{'list'});
790            $where->{'users.email'} = lc($arg->{'email'}) if ($arg->{'email'});
791            $where->{'received.date'} = { '>=', $arg->{'date_from'} } if ($arg->{'date_from'});
792            $where->{'received.date'} = { '<=', $arg->{'date_to'} } if ($arg->{'date_to'});
793    
794            # hum, yammy one-liner
795            my($stmt, @bind)  = SQL::Abstract->new->where($where);
796    
797            my $dbh = $self->{'loader'}->find_class('received')->db_Main;
798    
799            my $sth = $dbh->prepare($sql . $stmt . $order);
800            $sth->execute(@bind);
801            return $sth->fetchall_hash;
802    }
803    
804    
805  =head1 INTERNAL METHODS  =head1 INTERNAL METHODS
806    
# Line 694  Beware of dragons! You shouldn't need to Line 809  Beware of dragons! You shouldn't need to
809    
810  =head2 _add_aliases  =head2 _add_aliases
811    
812  Add or update alias in C</etc/aliases> (or equivavlent) file for selected list  Add or update alias in C</etc/aliases> (or equivalent) file for selected list
813    
814   my $ok = $nos->add_aliases(   my $ok = $nos->add_aliases(
815          list => 'My list',          list => 'My list',
# Line 730  sub _add_aliases { Line 845  sub _add_aliases {
845                  chmod 0777, $aliases || warn "can't change permission to 0777";                  chmod 0777, $aliases || warn "can't change permission to 0777";
846          }          }
847    
848            die "FATAL: aliases file $aliases is not writable\n" unless (-w $aliases);
849    
850          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: $!";
851    
852          my $target = '';          my $target = '';
# Line 751  sub _add_aliases { Line 868  sub _add_aliases {
868          $self_path =~ s#/[^/]+$##;          $self_path =~ s#/[^/]+$##;
869          $self_path =~ s#/t/*$#/#;          $self_path =~ s#/t/*$#/#;
870    
871          $target .= qq#| cd $self_path && ./sender.pl --inbox="$list"#;          $target .= qq#"| cd $self_path && ./sender.pl --inbox='$list'"#;
872    
873            # remove hostname from email to make Postfix's postalias happy
874            $email =~ s/@.+// if (not $self->{full_hostname_in_aliases});
875    
876          if ($a->exists($email)) {          if ($a->exists($email)) {
877                  $a->update($email, $target) or croak "can't update alias ".$a->error_check;                  $a->update($email, $target) or croak "can't update alias ".$a->error_check;
# Line 759  sub _add_aliases { Line 879  sub _add_aliases {
879                  $a->append($email, $target) or croak "can't add alias ".$a->error_check;                  $a->append($email, $target) or croak "can't add alias ".$a->error_check;
880          }          }
881    
882    #       $a->write($aliases) or croak "can't save aliases $aliases ".$a->error_check;
883    
884          return 1;          return 1;
885  }  }
886    
# Line 841  sub _get_list { Line 963  sub _get_list {
963          return $lists->search({ name => lc($name) })->first;          return $lists->search({ name => lc($name) })->first;
964  }  }
965    
966    
967    =head2 _remove_alias
968    
969    Remove list alias
970    
971     my $ok = $nos->_remove_alias(
972            email => 'mylist@example.com',
973            aliases => '/etc/mail/mylist',
974     );
975    
976    Returns true if list is removed or false if list doesn't exist. Dies in case of error.
977    
978    =cut
979    
980    sub _remove_alias {
981            my $self = shift;
982    
983            my $arg = {@_};
984    
985            my $email = lc($arg->{'email'}) || confess "can't remove alias without email";
986            my $aliases = lc($arg->{'aliases'}) || confess "can't remove alias without list";
987    
988            my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
989    
990            if ($a->exists($email)) {
991                    $a->delete($email) || croak "can't remove alias $email";
992            } else {
993                    return 0;
994            }
995    
996            return 1;
997    
998    }
999    
1000  ###  ###
1001  ### SOAP  ### SOAP
1002  ###  ###
# Line 880  Create new SOAP object Line 1036  Create new SOAP object
1036          aliases => '/etc/aliases',          aliases => '/etc/aliases',
1037   );   );
1038    
1039    If you are writing SOAP server (like C<soap.cgi> example), you will need to
1040    call this method once to make new instance of Nos::SOAP and specify C<dsn>
1041    and options for it.
1042    
1043  =cut  =cut
1044    
1045  sub new {  sub new {
# Line 896  sub new { Line 1056  sub new {
1056  }  }
1057    
1058    
1059  =head2 NewList  =head2 CreateList
1060    
1061   $message_id = NewList(   $message_id = CreateList(
1062          list => 'My list',          list => 'My list',
1063          from => 'Name of my list',          from => 'Name of my list',
1064          email => 'my-list@example.com'          email => 'my-list@example.com'
# Line 906  sub new { Line 1066  sub new {
1066    
1067  =cut  =cut
1068    
1069  sub NewList {  sub CreateList {
1070          my $self = shift;          my $self = shift;
1071    
1072          my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";          my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
1073    
1074          if ($_[0] !~ m/^HASH/) {          if ($_[0] !~ m/^HASH/) {
1075                  return $nos->new_list(                  return $nos->create_list(
1076                          list => $_[0], from => $_[1], email => $_[2],                          list => $_[0], from => $_[1], email => $_[2],
1077                          aliases => $aliases,                          aliases => $aliases,
1078                  );                  );
1079          } else {          } else {
1080                  return $nos->new_list( %{ shift @_ }, aliases => $aliases );                  return $nos->create_list( %{ shift @_ }, aliases => $aliases );
1081          }          }
1082  }  }
1083    
1084    
1085  =head2 DeleteList  =head2 DropList
1086    
1087   $ok = DeleteList(   $ok = DropList(
1088          list => 'My list',          list => 'My list',
1089   );   );
1090    
1091  =cut  =cut
1092    
1093  sub DeleteList {  sub DropList {
1094          my $self = shift;          my $self = shift;
1095    
1096            my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
1097    
1098          if ($_[0] !~ m/^HASH/) {          if ($_[0] !~ m/^HASH/) {
1099                  return $nos->delete_list(                  return $nos->drop_list(
1100                          list => $_[0],                          list => $_[0],
1101                            aliases => $aliases,
1102                  );                  );
1103          } else {          } else {
1104                  return $nos->delete_list( %{ shift @_ } );                  return $nos->drop_list( %{ shift @_ }, aliases => $aliases );
1105          }          }
1106  }  }
1107    
# Line 958  sub AddMemberToList { Line 1121  sub AddMemberToList {
1121    
1122          if ($_[0] !~ m/^HASH/) {          if ($_[0] !~ m/^HASH/) {
1123                  return $nos->add_member_to_list(                  return $nos->add_member_to_list(
1124                          list => $_[0], email => $_[1], name => $_[2], ext_id => $_[4],                          list => $_[0], email => $_[1], name => $_[2], ext_id => $_[3],
1125                  );                  );
1126          } else {          } else {
1127                  return $nos->add_member_to_list( %{ shift @_ } );                  return $nos->add_member_to_list( %{ shift @_ } );
# Line 974  sub AddMemberToList { Line 1137  sub AddMemberToList {
1137    
1138  Returns array of hashes with user informations, see C<list_members>.  Returns array of hashes with user informations, see C<list_members>.
1139    
 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.  
   
1140  =cut  =cut
1141    
1142  sub ListMembers {  sub ListMembers {
# Line 1038  sub AddMessageToList { Line 1197  sub AddMessageToList {
1197          }          }
1198  }  }
1199    
1200    =head2 MessagesReceived
1201    
1202    Return statistics about received messages.
1203    
1204     my @result = MessagesReceived(
1205            list => 'My list',
1206            email => 'jdoe@example.com',
1207            from_date => '2005-01-01 10:15:00',
1208            to_date => '2005-01-01 12:00:00',
1209            message => 0,
1210     );
1211    
1212    You must specify C<list> or C<email> or any combination of those two. Other
1213    parametars are optional.
1214    
1215    For format of returned array element see C<received_messages>.
1216    
1217    =cut
1218    
1219    sub MessagesReceived {
1220            my $self = shift;
1221    
1222            if ($_[0] !~ m/^HASH/) {
1223                    die "need at least list or email" unless (scalar @_ < 2);
1224                    return \@{ $nos->received_messages(
1225                            list => $_[0], email => $_[1],
1226                            from_date => $_[2], to_date => $_[3],
1227                            message => $_[4]
1228                    ) };
1229            } else {
1230                    my $arg = shift;
1231                    die "need list or email argument" unless ($arg->{'list'} || $arg->{'email'});
1232                    return \@{ $nos->received_messages( %{ $arg } ) };
1233            }
1234    }
1235    
1236  ###  ###
1237    
1238    =head1 NOTE ON ARRAYS IN SOAP
1239    
1240    Returning arrays from SOAP calls is somewhat fuzzy (at least to me). It
1241    seems that SOAP::Lite client thinks that it has array with one element which
1242    is array of hashes with data.
1243    
1244  =head1 EXPORT  =head1 EXPORT
1245    
1246  Nothing.  Nothing.
Legend:
Removed from v.68  
changed lines
  Added in v.89
  ViewVC Help
Powered by ViewVC 1.1.26