/[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 60 by dpavlin, Tue Jun 21 21:24:10 2005 UTC revision 77 by dpavlin, Thu Aug 25 00:37:48 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.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;
32    use Cwd qw(abs_path);
33    
34    
35  =head1 NAME  =head1 NAME
# Line 60  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 70  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 118  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 135  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 154  sub new_list { Line 159  sub new_list {
159  }  }
160    
161    
162    =head2 drop_list
163    
164    Delete list from database.
165    
166     my $ok = drop_list(
167            list => 'My list'
168            aliases => '/etc/mail/mylist',
169     );
170    
171    Returns false if list doesn't exist.
172    
173    =cut
174    
175    sub drop_list {
176            my $self = shift;
177    
178            my $args = {@_};
179    
180            croak "need list to delete" unless ($args->{'list'});
181    
182            $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');
187    
188            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";
193    
194            return $lists->dbi_commit || croak "can't commit";
195    }
196    
197    
198  =head2 add_member_to_list  =head2 add_member_to_list
199    
200  Add new member to list  Add new member to list
# Line 227  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 343  sub delete_member_from_list { Line 384  sub delete_member_from_list {
384          my $this_user = $user->search( email => $args->{'email'} )->first || croak "can't find user: ".$args->{'email'};          my $this_user = $user->search( email => $args->{'email'} )->first || croak "can't find user: ".$args->{'email'};
385          my $this_list = $list->search( name => $args->{'list'} )->first || croak "can't find list: ".$args->{'list'};          my $this_list = $list->search( name => $args->{'list'} )->first || croak "can't find list: ".$args->{'list'};
386    
387          my $this_user_list = $user_list->search_where( list_id => $this_list->id, user_id => $this_list->id )->first || return;          my $this_user_list = $user_list->search_where( list_id => $this_list->id, user_id => $this_user->id )->first || return;
388    
389          $this_user_list->delete || croak "can't delete user from list\n";          $this_user_list->delete || croak "can't delete user from list\n";
390    
# Line 435  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 449  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 489  sub send_queued_messages { Line 539  sub send_queued_messages {
539                          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 )) {
540                                  print "SKIP $to_email message allready sent\n";                                  print "SKIP $to_email message allready sent\n";
541                          } else {                          } else {
542                                  print "=> $to_email\n";                                  print "=> $to_email ";
543    
544                                  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;
545                                  my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );                                  my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
# Line 515  sub send_queued_messages { Line 565  sub send_queued_messages {
565                                  $m_obj->header_set('X-Nos-Hash', $hash);                                  $m_obj->header_set('X-Nos-Hash', $hash);
566    
567                                  # really send e-mail                                  # really send e-mail
568                                    my $sent_status;
569    
570                                  if (@email_send_options) {                                  if (@email_send_options) {
571                                          send $email_send_driver => $m_obj->as_string, @email_send_options;                                          $sent_status = send $email_send_driver => $m_obj->as_string, @email_send_options;
572                                  } else {                                  } else {
573                                          send $email_send_driver => $m_obj->as_string;                                          $sent_status = send $email_send_driver => $m_obj->as_string;
574                                  }                                  }
575    
576                                  $sent->create({                                  croak "can't send e-mail: $sent_status\n\nOriginal e-mail follows:\n".$m_obj->as_string unless ($sent_status);
577                                          message_id => $m->message_id,                                  my @bad;
578                                          user_id => $u->user_id,                                  @bad = @{ $sent_status->prop('bad') } if (eval { $sent_status->can('prop') });
579                                          hash => $hash,                                  croak "failed sending to ",join(",",@bad) if (@bad);
580                                  });  
581                                  $sent->dbi_commit;                                  if ($sent_status) {
582    
583                                            $sent->create({
584                                                    message_id => $m->message_id,
585                                                    user_id => $u->user_id,
586                                                    hash => $hash,
587                                            });
588                                            $sent->dbi_commit;
589    
590                                            print " - $sent_status\n";
591    
592                                            $ok++;
593                                    } else {
594                                            warn "ERROR: $sent_status\n";
595                                    }
596    
597                                  if ($sleep) {                                  if ($sleep) {
598                                          warn "sleeping $sleep seconds\n";                                          warn "sleeping $sleep seconds\n";
# Line 539  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 637  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_message(
713            list => 'My list',
714            email => "john.doe@example.com",
715     );
716    
717    Each element in returned array will have following structure:
718    
719     {
720            id => 42,                       # unique ID of received message
721            list => 'My list',              # useful only of filtering by email
722            ext_id => 9999,                 # ext_id from message user
723            email => 'jdoe@example.com',    # e-mail of user
724            bounced => 0,                   # true value if message is bounce
725            date => '2005-08-24 18:57:24',  # date of recival in ISO format
726     }
727    
728    
729    =cut
730    
731    sub received_messages {
732            my $self = shift;
733    
734            my $arg = {@_} if (@_);
735    
736    #       croak "need list name or email" unless ($arg->{'list'} || $arg->{'email'});
737    
738            my $sql = qq{
739                            select
740                                    received.id as id,
741                                    lists.name as list,
742                                    users.ext_id as ext_id,
743                                    users.email as email,
744                                    bounced,received.date as date
745                            from received
746                            join lists on lists.id = list_id
747                            join users on users.id = user_id
748            };
749    
750            my $where;
751    
752            $where->{'lists.name'} = lc($arg->{'list'}) if ($arg->{'list'});
753            $where->{'users.email'} = lc($arg->{'email'}) if ($arg->{'email'});
754    
755            # hum, yammy one-liner
756            my($stmt, @bind)  = SQL::Abstract->new->where($where);
757    
758            my $dbh = $self->{'loader'}->find_class('received')->db_Main;
759    
760            my $sth = $dbh->prepare($sql . $stmt);
761            $sth->execute(@bind);
762            return $sth->fetchall_hash;
763    }
764    
765    
766  =head1 INTERNAL METHODS  =head1 INTERNAL METHODS
767    
768  Beware of dragons! You shouldn't need to call those methods directly.  Beware of dragons! You shouldn't need to call those methods directly.
769    
770    
771    =head2 _add_aliases
772    
773    Add or update alias in C</etc/aliases> (or equivalent) file for selected list
774    
775     my $ok = $nos->add_aliases(
776            list => 'My list',
777            email => 'my-list@example.com',
778            aliases => '/etc/mail/mylist',
779            archive => '/path/to/mbox/archive',
780    
781     );
782    
783    C<archive> parametar is optional.
784    
785    Return false on failure.
786    
787    =cut
788    
789    sub _add_aliases {
790            my $self = shift;
791    
792            my $arg = {@_};
793    
794            foreach my $o (qw/list email aliases/) {
795                    croak "need $o option" unless ($arg->{$o});
796            }
797    
798            my $aliases = $arg->{'aliases'};
799            my $email = $arg->{'email'};
800            my $list = $arg->{'list'};
801    
802            unless (-e $aliases) {
803                    warn "aliases file $aliases doesn't exist, creating empty\n";
804                    open(my $fh, '>', $aliases) || croak "can't create $aliases: $!";
805                    close($fh);
806                    chmod 0777, $aliases || warn "can't change permission to 0777";
807            }
808    
809            die "FATAL: aliases file $aliases is not writable\n" unless (-w $aliases);
810    
811            my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
812    
813            my $target = '';
814    
815            if (my $archive = $arg->{'archive'}) {
816                    $target .= "$archive, ";
817    
818                    if (! -e $archive) {
819                            warn "please make sure that file $archive is writable for your e-mail user (defaulting to bad 777 permission for now)";
820    
821                            open(my $fh, '>', $archive) || croak "can't create archive file $archive: $!";
822                            close($fh);
823                            chmod 0777, $archive || croak "can't chmod archive file $archive to 0777: $!";
824                    }
825            }
826    
827            # resolve my path to absolute one
828            my $self_path = abs_path($0);
829            $self_path =~ s#/[^/]+$##;
830            $self_path =~ s#/t/*$#/#;
831    
832            $target .= qq#| cd $self_path && ./sender.pl --inbox="$list"#;
833    
834            if ($a->exists($email)) {
835                    $a->update($email, $target) or croak "can't update alias ".$a->error_check;
836            } else {
837                    $a->append($email, $target) or croak "can't add alias ".$a->error_check;
838            }
839    
840            #$a->write($aliases) or croak "can't save aliases $aliases ".$a->error_check;
841    
842            return 1;
843    }
844    
845  =head2 _add_list  =head2 _add_list
846    
847  Create new list  Create new list
# Line 650  Create new list Line 850  Create new list
850          list => 'My list',          list => 'My list',
851          from => 'Outgoing from comment',          from => 'Outgoing from comment',
852          email => 'my-list@example.com',          email => 'my-list@example.com',
853            aliases => '/etc/mail/mylist',
854   );   );
855    
856  Returns C<Class::DBI> object for created list.  Returns C<Class::DBI> object for created list.
# Line 668  sub _add_list { Line 869  sub _add_list {
869    
870          my $name = lc($arg->{'list'}) || confess "can't add list without name";          my $name = lc($arg->{'list'}) || confess "can't add list without name";
871          my $email = lc($arg->{'email'}) || confess "can't add list without e-mail";          my $email = lc($arg->{'email'}) || confess "can't add list without e-mail";
872            my $aliases = lc($arg->{'aliases'}) || confess "can't add list without path to aliases file";
873    
874          my $from_addr = $arg->{'from'};          my $from_addr = $arg->{'from'};
875    
876          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
877    
878            $self->_add_aliases(
879                    list => $name,
880                    email => $email,
881                    aliases => $aliases,
882            ) || warn "can't add alias $email for list $name";
883    
884          my $l = $lists->find_or_create({          my $l = $lists->find_or_create({
885                  name => $name,                  name => $name,
886                  email => $email,                  email => $email,
# Line 691  sub _add_list { Line 900  sub _add_list {
900  }  }
901    
902    
903    
904  =head2 _get_list  =head2 _get_list
905    
906  Get list C<Class::DBI> object.  Get list C<Class::DBI> object.
# Line 711  sub _get_list { Line 921  sub _get_list {
921          return $lists->search({ name => lc($name) })->first;          return $lists->search({ name => lc($name) })->first;
922  }  }
923    
924    
925    =head2 _remove_alias
926    
927    Remove list alias
928    
929     my $ok = $nos->_remove_alias(
930            email => 'mylist@example.com',
931            aliases => '/etc/mail/mylist',
932     );
933    
934    Returns true if list is removed or false if list doesn't exist. Dies in case of error.
935    
936    =cut
937    
938    sub _remove_alias {
939            my $self = shift;
940    
941            my $arg = {@_};
942    
943            my $email = lc($arg->{'email'}) || confess "can't remove alias without email";
944            my $aliases = lc($arg->{'aliases'}) || confess "can't remove alias without list";
945    
946            my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
947    
948            if ($a->exists($email)) {
949                    $a->delete($email) || croak "can't remove alias $email";
950            } else {
951                    return 0;
952            }
953    
954            return 1;
955    
956    }
957    
958  ###  ###
959  ### SOAP  ### SOAP
960  ###  ###
# Line 735  methods below). Line 979  methods below).
979    
980  my $nos;  my $nos;
981    
982    
983    =head2 new
984    
985    Create new SOAP object
986    
987     my $soap = new Nos::SOAP(
988            dsn => 'dbi:Pg:dbname=notices',
989            user => 'dpavlin',
990            passwd => '',
991            debug => 1,
992            verbose => 1,
993            hash_len => 8,
994            aliases => '/etc/aliases',
995     );
996    
997    If you are writing SOAP server (like C<soap.cgi> example), you will need to
998    call this method once to make new instance of Nos::SOAP and specify C<dsn>
999    and options for it.
1000    
1001    =cut
1002    
1003  sub new {  sub new {
1004          my $class = shift;          my $class = shift;
1005          my $self = {@_};          my $self = {@_};
1006    
1007            croak "need aliases parametar" unless ($self->{'aliases'});
1008    
1009          bless($self, $class);          bless($self, $class);
1010    
1011          $nos = new Nos( @_ ) || die "can't create Nos object";          $nos = new Nos( @_ ) || die "can't create Nos object";
# Line 746  sub new { Line 1014  sub new {
1014  }  }
1015    
1016    
1017  =head2 NewList  =head2 CreateList
1018    
1019   $message_id = NewList(   $message_id = CreateList(
1020          list => 'My list',          list => 'My list',
1021          from => 'Name of my list',          from => 'Name of my list',
1022          email => 'my-list@example.com'          email => 'my-list@example.com'
# Line 756  sub new { Line 1024  sub new {
1024    
1025  =cut  =cut
1026    
1027  sub NewList {  sub CreateList {
1028          my $self = shift;          my $self = shift;
1029    
1030            my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
1031    
1032          if ($_[0] !~ m/^HASH/) {          if ($_[0] !~ m/^HASH/) {
1033                  return $nos->new_list(                  return $nos->create_list(
1034                          list => $_[0], from => $_[1], email => $_[2],                          list => $_[0], from => $_[1], email => $_[2],
1035                            aliases => $aliases,
1036                  );                  );
1037          } else {          } else {
1038                  return $nos->new_list( %{ shift @_ } );                  return $nos->create_list( %{ shift @_ }, aliases => $aliases );
1039          }          }
1040  }  }
1041    
1042    
1043    =head2 DropList
1044    
1045     $ok = DropList(
1046            list => 'My list',
1047     );
1048    
1049    =cut
1050    
1051    sub DropList {
1052            my $self = shift;
1053    
1054            my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
1055    
1056            if ($_[0] !~ m/^HASH/) {
1057                    return $nos->drop_list(
1058                            list => $_[0],
1059                            aliases => $aliases,
1060                    );
1061            } else {
1062                    return $nos->drop_list( %{ shift @_ }, aliases => $aliases );
1063            }
1064    }
1065    
1066  =head2 AddMemberToList  =head2 AddMemberToList
1067    
1068   $member_id = AddMemberToList(   $member_id = AddMemberToList(
# Line 814  sub ListMembers { Line 1108  sub ListMembers {
1108                  $list_name = $_[0]->{'list'};                  $list_name = $_[0]->{'list'};
1109          }          }
1110    
1111          return $nos->list_members( list => $list_name );          return [ $nos->list_members( list => $list_name ) ];
1112  }  }
1113    
1114    
1115    =head2 DeleteMemberFromList
1116    
1117     $member_id = DeleteMemberFromList(
1118            list => 'My list',
1119            email => 'e-mail@example.com',
1120     );
1121    
1122    =cut
1123    
1124    sub DeleteMemberFromList {
1125            my $self = shift;
1126    
1127            if ($_[0] !~ m/^HASH/) {
1128                    return $nos->delete_member_from_list(
1129                            list => $_[0], email => $_[1],
1130                    );
1131            } else {
1132                    return $nos->delete_member_from_list( %{ shift @_ } );
1133            }
1134    }
1135    
1136    
1137  =head2 AddMessageToList  =head2 AddMessageToList
1138    
1139   $message_id = AddMessageToList(   $message_id = AddMessageToList(
# Line 838  sub AddMessageToList { Line 1155  sub AddMessageToList {
1155          }          }
1156  }  }
1157    
1158    =head1 UNIMPLEMENTED FUNCTIONS
1159    
1160    This is a stub for documentation of unimplemented functions.
1161    
1162    =head2 MessagesReceived
1163    
1164     my @result = MessagesReceived(
1165            list => 'My list',
1166            email => 'jdoe@example.com',
1167     );
1168    
1169    You can specify just C<list> or C<email> or any combination of those.
1170    
1171    For format of returned array element see C<received_messages>.
1172    
1173    =head2 MessagesReceivedByDate
1174    
1175    =head2 MessagesReceivedByDateWithContent
1176    
1177    =head2 ReceivedMessasgeContent
1178    
1179    Return content of received message.
1180    
1181     my $mail_body = ReceivedMessageContent( id => 42 );
1182    
1183    =cut
1184    
1185    
1186    
1187    
1188  ###  ###
1189    
1190    =head1 NOTE ON ARRAYS IN SOAP
1191    
1192    Returning arrays from SOAP calls is somewhat fuzzy (at least to me). It
1193    seems that SOAP::Lite client thinks that it has array with one element which
1194    is array of hashes with data.
1195    
1196  =head1 EXPORT  =head1 EXPORT
1197    
1198  Nothing.  Nothing.
Legend:
Removed from v.60  
changed lines
  Added in v.77
  ViewVC Help
Powered by ViewVC 1.1.26