/[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 75 by dpavlin, Wed Aug 24 21:27:40 2005 UTC revision 93 by dpavlin, Tue Dec 19 15:04:05 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.8';  our $VERSION = '0.9';
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 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 116  sub new { Line 122  sub new {
122    
123          $self->{'hash_len'} ||= 8;          $self->{'hash_len'} ||= 8;
124    
         $self->{'loader'}->find_class('received')->set_sql(  
                 'received' => qq{  
                         select  
                                 received.id as id,  
                                 lists.name as list,  
                                 users.ext_id as ext_id,  
                                 users.email as email,  
                                 bounced,received.date as date  
                         from received  
                         join lists on lists.id = list_id  
                         join users on users.id = user_id  
                 },  
         );  
   
125          $self ? return $self : return undef;          $self ? return $self : return undef;
126  }  }
127    
# Line 434  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 474  Send queued messages or just ones for se Line 463  Send queued messages or just ones for se
463          list => 'My list',          list => 'My list',
464          driver => 'smtp',          driver => 'smtp',
465          sleep => 3,          sleep => 3,
466            verbose => 1,
467   );   );
468    
469  Second option is driver which will be used for e-mail delivery. If not  Second option is driver which will be used for e-mail delivery. If not
# Line 487  Other valid drivers are: Line 477  Other valid drivers are:
477    
478  Send e-mail using SMTP server at 127.0.0.1  Send e-mail using SMTP server at 127.0.0.1
479    
480    =item verbose
481    
482    Display diagnostic output to C<STDOUT> and C<STDERR>.
483    
484  =back  =back
485    
486  Any other driver name will try to use C<Email::Send::that_driver> module.  Any other driver name will try to use C<Email::Send::that_driver> module.
# Line 505  sub send_queued_messages { Line 499  sub send_queued_messages {
499          my $list_name = lc($arg->{'list'}) || '';          my $list_name = lc($arg->{'list'}) || '';
500          my $driver = $arg->{'driver'} || '';          my $driver = $arg->{'driver'} || '';
501          my $sleep = $arg->{'sleep'};          my $sleep = $arg->{'sleep'};
502            my $verbose = $arg->{verbose};
503          $sleep ||= 3 unless defined($sleep);          $sleep ||= 3 unless defined($sleep);
504    
505          # number of messages sent o.k.          # number of messages sent o.k.
# Line 519  sub send_queued_messages { Line 514  sub send_queued_messages {
514          } elsif ($driver && $driver ne '') {          } elsif ($driver && $driver ne '') {
515                  $email_send_driver = 'Email::Send::' . $driver;                  $email_send_driver = 'Email::Send::' . $driver;
516          } else {          } else {
517                  warn "dumping all messages to STDERR\n";                  warn "dumping all messages to STDERR\n" if ($verbose);
518          }          }
519    
520          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
# Line 540  sub send_queued_messages { Line 535  sub send_queued_messages {
535          while (my $m = $my_q->next) {          while (my $m = $my_q->next) {
536                  next if ($m->all_sent);                  next if ($m->all_sent);
537    
538                  print "sending message ",$m->message_id," enqueued on ",$m->date," to list ",$m->list_id->name,"\n";                  print "sending message ",$m->message_id," enqueued on ",$m->date," to list ",$m->list_id->name,"\n" if ($verbose);
539                  my $msg = $m->message_id->message;                  my $msg = $m->message_id->message;
540    
541                  foreach my $u ($user_list->search(list_id => $m->list_id)) {                  foreach my $u ($user_list->search(list_id => $m->list_id)) {
# Line 550  sub send_queued_messages { Line 545  sub send_queued_messages {
545                          my ($from,$domain) = split(/@/, $u->list_id->email, 2);                          my ($from,$domain) = split(/@/, $u->list_id->email, 2);
546    
547                          if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {                          if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {
548                                  print "SKIP $to_email message allready sent\n";                                  print "SKIP $to_email message allready sent\n" if ($verbose);
549                          } else {                          } else {
550                                  print "=> $to_email ";                                  print "=> $to_email " if ($verbose);
551    
552                                  my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;                                  my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;
553                                  my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );                                  my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
# Line 569  sub send_queued_messages { Line 564  sub send_queued_messages {
564                                  my $m_obj = Email::Simple->new($msg) || croak "can't parse message";                                  my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
565    
566                                  $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";
567                                  $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";
568                                  $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";
569                                  $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";
570                                  $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 600  sub send_queued_messages { Line 595  sub send_queued_messages {
595                                          });                                          });
596                                          $sent->dbi_commit;                                          $sent->dbi_commit;
597    
598                                          print " - $sent_status\n";                                          print " - $sent_status\n" if ($verbose);
599    
600                                          $ok++;                                          $ok++;
601                                  } else {                                  } else {
602                                          warn "ERROR: $sent_status\n";                                          warn "ERROR: $sent_status\n" if ($verbose);
603                                  }                                  }
604    
605                                  if ($sleep) {                                  if ($sleep) {
606                                          warn "sleeping $sleep seconds\n";                                          warn "sleeping $sleep seconds\n" if ($verbose);
607                                          sleep($sleep);                                          sleep($sleep);
608                                  }                                  }
609                          }                          }
# Line 722  sub inbox_message { Line 717  sub inbox_message {
717    
718  Returns all received messages for given list or user.  Returns all received messages for given list or user.
719    
720   my @received = $nos->received_message(   my @received = $nos->received_messages(
721          list => 'My list',          list => 'My list',
722          email => "john.doe@example.com",          email => "john.doe@example.com",
723            from_date => '2005-01-01 10:15:00',
724            to_date => '2005-01-01 12:00:00',
725            message => 0,
726   );   );
727    
728  This method is used by C<sender.pl> when receiving e-mail messages.  If don't specify C<list> or C<email> it will return all received messages.
729    Results will be sorted by received date, oldest first.
730    
731    Other optional parametars include:
732    
733    =over 10
734    
735    =item from_date
736    
737    Date (in ISO format) for lower limit of dates received
738    
739    =item to_date
740    
741    Return just messages older than this date
742    
743    =item message
744    
745    Include whole received message in result. This will probably make result
746    array very large. Use with care.
747    
748    =back
749    
750    Date ranges are inclusive, so results will include messages sent on
751    particular date specified with C<date_from> or C<date_to>.
752    
753    Each element in returned array will have following structure:
754    
755     my $row = {
756            id => 42,                       # unique ID of received message
757            list => 'My list',              # useful if filtering by email
758            ext_id => 9999,                 # ext_id from message sender
759            email => 'jdoe@example.com',    # e-mail of message sender
760            bounced => 0,                   # true if message is bounce
761            date => '2005-08-24 18:57:24',  # date of receival in ISO format
762     }
763    
764    If you specified C<message> option, this hash will also have C<message> key
765    which will contain whole received message.
766    
767  =cut  =cut
768    
769  sub received_messages {  sub received_messages {
770          my $self = shift;          my $self = shift;
771    
772          my $arg = {@_};          my $arg = {@_} if (@_);
773    
774          croak "need list name or email" unless ($arg->{'list'} || $arg->{'email'});  #       croak "need list name or email" unless ($arg->{'list'} || $arg->{'email'});
775    
776          $arg->{'list'} = lc($arg->{'list'});          my $sql = qq{
777          $arg->{'email'} = lc($arg->{'email'});                          select
778                                    received.id as id,
779                                    lists.name as list,
780                                    users.ext_id as ext_id,
781                                    users.email as email,
782            };
783            $sql .= qq{             message,} if ($arg->{'message'});
784            $sql .= qq{
785                                    bounced,received.date as date
786                            from received
787                            join lists on lists.id = list_id
788                            join users on users.id = user_id
789            };
790    
791            my $order = qq{ order by date asc };
792    
793            my $where;
794    
795            $where->{'lists.name'} = lc($arg->{'list'}) if ($arg->{'list'});
796            $where->{'users.email'} = lc($arg->{'email'}) if ($arg->{'email'});
797            $where->{'received.date'} = { '>=', $arg->{'date_from'} } if ($arg->{'date_from'});
798            $where->{'received.date'} = { '<=', $arg->{'date_to'} } if ($arg->{'date_to'});
799    
800          my $rcvd = $self->{'loader'}->find_class('received')->search_received();          # hum, yammy one-liner
801            my($stmt, @bind)  = SQL::Abstract->new->where($where);
802    
803          return $rcvd;          my $dbh = $self->{'loader'}->find_class('received')->db_Main;
804    
805            my $sth = $dbh->prepare($sql . $stmt . $order);
806            $sth->execute(@bind);
807            return $sth->fetchall_hash;
808  }  }
809    
810    
# Line 813  sub _add_aliases { Line 874  sub _add_aliases {
874          $self_path =~ s#/[^/]+$##;          $self_path =~ s#/[^/]+$##;
875          $self_path =~ s#/t/*$#/#;          $self_path =~ s#/t/*$#/#;
876    
877          $target .= qq#| cd $self_path && ./sender.pl --inbox="$list"#;          $target .= qq#"| cd $self_path && ./sender.pl --inbox='$list'"#;
878    
879            # remove hostname from email to make Postfix's postalias happy
880            $email =~ s/@.+// if (not $self->{full_hostname_in_aliases});
881    
882          if ($a->exists($email)) {          if ($a->exists($email)) {
883                  $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 821  sub _add_aliases { Line 885  sub _add_aliases {
885                  $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;
886          }          }
887    
888          #$a->write($aliases) or croak "can't save aliases $aliases ".$a->error_check;  #       $a->write($aliases) or croak "can't save aliases $aliases ".$a->error_check;
889    
890          return 1;          return 1;
891  }  }
# Line 985  and options for it. Line 1049  and options for it.
1049  =cut  =cut
1050    
1051  sub new {  sub new {
1052          my $class = shift;          my $class = shift;
1053          my $self = {@_};          my $self = {@_};
1054    
1055          croak "need aliases parametar" unless ($self->{'aliases'});          croak "need aliases parametar" unless ($self->{'aliases'});
1056    
# Line 1063  sub AddMemberToList { Line 1127  sub AddMemberToList {
1127    
1128          if ($_[0] !~ m/^HASH/) {          if ($_[0] !~ m/^HASH/) {
1129                  return $nos->add_member_to_list(                  return $nos->add_member_to_list(
1130                          list => $_[0], email => $_[1], name => $_[2], ext_id => $_[4],                          list => $_[0], email => $_[1], name => $_[2], ext_id => $_[3],
1131                  );                  );
1132          } else {          } else {
1133                  return $nos->add_member_to_list( %{ shift @_ } );                  return $nos->add_member_to_list( %{ shift @_ } );
# Line 1139  sub AddMessageToList { Line 1203  sub AddMessageToList {
1203          }          }
1204  }  }
1205    
 =head1 UNIMPLEMENTED FUNCTIONS  
   
 This is a stub for documentation of unimplemented functions.  
   
1206  =head2 MessagesReceived  =head2 MessagesReceived
1207    
1208    Return statistics about received messages.
1209    
1210   my @result = MessagesReceived(   my @result = MessagesReceived(
1211          list => 'My list',          list => 'My list',
1212          email => 'jdoe@example.com',          email => 'jdoe@example.com',
1213            from_date => '2005-01-01 10:15:00',
1214            to_date => '2005-01-01 12:00:00',
1215            message => 0,
1216   );   );
1217    
1218  You can specify just C<list> or C<email> or any combination of those.  You must specify C<list> or C<email> or any combination of those two. Other
1219    parametars are optional.
1220    
1221  It will return array of hashes with following structure:  For format of returned array element see C<received_messages>.
1222    
1223   {  =cut
         id => 42,                       # unique ID of received message  
         list => 'My list',              # useful only of filtering by email  
         ext_id => 9999,                 # ext_id from message user  
         email => 'jdoe@example.com',    # e-mail of user  
         bounced => 0,                   # true value if message is bounce  
         date => '2005-08-24 18:57:24',  # date of recival in ISO format  
  }  
1224    
1225  =head2 MessagesReceivedByDate  sub MessagesReceived {
1226            my $self = shift;
1227    
1228            if ($_[0] !~ m/^HASH/) {
1229                    die "need at least list or email" unless (scalar @_ < 2);
1230                    return \@{ $nos->received_messages(
1231                            list => $_[0], email => $_[1],
1232                            from_date => $_[2], to_date => $_[3],
1233                            message => $_[4]
1234                    ) };
1235            } else {
1236                    my $arg = shift;
1237                    die "need list or email argument" unless ($arg->{'list'} || $arg->{'email'});
1238                    return \@{ $nos->received_messages( %{ $arg } ) };
1239            }
1240    }
1241    
1242  =head2 MessagesReceivedByDateWithContent  =head2 SendTest
1243    
1244  =head2 ReceivedMessasgeContent  Internal function which does e-mail sending using C<Email::Send::Test> driver.
1245    
1246  Return content of received message.    my $sent = SendTest( list => 'My list' );
1247    
1248   my $mail_body = ReceivedMessageContent( id => 42 );  Returns number of messages sent
1249    
1250  =cut  =cut
1251    
1252    sub SendTest {
1253            my $self = shift;
1254            my $args = shift;
1255            die "list name required" unless ($args->{list});
1256    
1257            require Email::Send::Test;
1258    
1259            my $nr_sent = $nos->send_queued_messages(
1260                    list => $args->{list},
1261                    driver => 'Test',
1262                    sleep => 0,
1263                    verbose => 0,
1264            );
1265    
1266            my @emails = Email::Send::Test->emails;
1267    
1268            open(my $tmp, ">/tmp/soap-debug");
1269            use Data::Dump qw/dump/;
1270            print $tmp "sent $nr_sent emails\n", dump(@emails);
1271            close($tmp);
1272    
1273            return $nr_sent;
1274    }
1275    
1276  ###  ###
1277    
Legend:
Removed from v.75  
changed lines
  Added in v.93
  ViewVC Help
Powered by ViewVC 1.1.26