/[notice-sender]/jifty-dbi/lib/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 /jifty-dbi/lib/Nos.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

trunk/Nos.pm revision 76 by dpavlin, Wed Aug 24 22:11:00 2005 UTC jifty-dbi/lib/Nos.pm revision 92 by dpavlin, Tue Dec 19 10:32:18 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_00';
20    
 use Class::DBI::Loader;  
21  use Email::Valid;  use Email::Valid;
22  use Email::Send;  use Email::Send;
23  use Carp;  use Carp;
# Line 26  use Email::Auth::AddressHash; Line 25  use Email::Auth::AddressHash;
25  use Email::Simple;  use Email::Simple;
26  use Email::Address;  use Email::Address;
27  use Mail::DeliveryStatus::BounceParser;  use Mail::DeliveryStatus::BounceParser;
 use Class::DBI::AbstractSearch;  
28  use Mail::Alias;  use Mail::Alias;
29  use Cwd qw(abs_path);  use Cwd qw(abs_path);
30    
31    use Jifty::DBI::Handle;
32    use lib 'lib';
33    use Nos::Lists;
34    
35    
36  =head1 NAME  =head1 NAME
37    
# Line 89  Create new instance specifing database, Line 91  Create new instance specifing database,
91          debug => 1,          debug => 1,
92          verbose => 1,          verbose => 1,
93          hash_len => 8,          hash_len => 8,
94            full_hostname_in_aliases => 0,
95   );   );
96    
97  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
98  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.
99    
100    C<full_hostname_in_aliases> will turn on old behaviour (not supported by Postfix
101    postalias) to include full hostname in aliases file.
102    
103    
104  =cut  =cut
105    
106  sub new {  sub new {
107          my $class = shift;          my $class = shift;
108          my $self = {@_};          my $self = {@_};
109          bless($self, $class);          bless($self, $class);
110    
111          croak "need at least dsn" unless ($self->{'dsn'});          croak "need at least dsn" unless ($self->{dsn});
112    
113            my (undef,$driver,$dbname) = split(/:/, $self->{dsn});
114            $dbname =~ s!^dbname=!!;
115    
116            $self->{h} = Jifty::DBI::Handle->new();
117            $self->{h}->connect(
118                    driver   => $driver,
119                    database => $dbname,
120                    host     => 'localhost',
121                    user     => $self->{user},
122                    password => $self->{passwd},
123            );
124    
125          $self->{'loader'} = Class::DBI::Loader->new(          $self->{'loader'} = Class::DBI::Loader->new(
126                  debug           => $self->{'debug'},                  debug           => $self->{'debug'},
127                  dsn             => $self->{'dsn'},                  dsn                     => $self->{'dsn'},
128                  user            => $self->{'user'},                  user            => $self->{'user'},
129                  password        => $self->{'passwd'},                  password        => $self->{'passwd'},
130                  namespace       => "Nos",                  namespace       => "Nos",
# Line 116  sub new { Line 135  sub new {
135    
136          $self->{'hash_len'} ||= 8;          $self->{'hash_len'} ||= 8;
137    
         $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  
                 },  
         );  
   
138          $self ? return $self : return undef;          $self ? return $self : return undef;
139  }  }
140    
# Line 434  sub add_message_to_list { Line 439  sub add_message_to_list {
439    
440          my $m = Email::Simple->new($message_text) || croak "can't parse message";          my $m = Email::Simple->new($message_text) || croak "can't parse message";
441    
442          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;  
         }  
443    
444          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
445    
# Line 569  sub send_queued_messages { Line 571  sub send_queued_messages {
571                                  my $m_obj = Email::Simple->new($msg) || croak "can't parse message";                                  my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
572    
573                                  $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";
574                                  $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";
575                                  $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";
576                                  $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";
577                                  $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 722  sub inbox_message { Line 724  sub inbox_message {
724    
725  Returns all received messages for given list or user.  Returns all received messages for given list or user.
726    
727   my @received = $nos->received_message(   my @received = $nos->received_messages(
728          list => 'My list',          list => 'My list',
729          email => "john.doe@example.com",          email => "john.doe@example.com",
730            from_date => '2005-01-01 10:15:00',
731            to_date => '2005-01-01 12:00:00',
732            message => 0,
733   );   );
734    
735    If don't specify C<list> or C<email> it will return all received messages.
736    Results will be sorted by received date, oldest first.
737    
738    Other optional parametars include:
739    
740    =over 10
741    
742    =item from_date
743    
744    Date (in ISO format) for lower limit of dates received
745    
746    =item to_date
747    
748    Return just messages older than this date
749    
750    =item message
751    
752    Include whole received message in result. This will probably make result
753    array very large. Use with care.
754    
755    =back
756    
757    Date ranges are inclusive, so results will include messages sent on
758    particular date specified with C<date_from> or C<date_to>.
759    
760  Each element in returned array will have following structure:  Each element in returned array will have following structure:
761    
762   {   my $row = {
763          id => 42,                       # unique ID of received message          id => 42,                       # unique ID of received message
764          list => 'My list',              # useful only of filtering by email          list => 'My list',              # useful if filtering by email
765          ext_id => 9999,                 # ext_id from message user          ext_id => 9999,                 # ext_id from message sender
766          email => 'jdoe@example.com',    # e-mail of user          email => 'jdoe@example.com',    # e-mail of message sender
767          bounced => 0,                   # true value if message is bounce          bounced => 0,                   # true if message is bounce
768          date => '2005-08-24 18:57:24',  # date of recival in ISO format          date => '2005-08-24 18:57:24',  # date of receival in ISO format
769   }   }
770    
771    If you specified C<message> option, this hash will also have C<message> key
772    which will contain whole received message.
773    
774  =cut  =cut
775    
776  sub received_messages {  sub received_messages {
777          my $self = shift;          my $self = shift;
778    
779          my $arg = {@_};          my $arg = {@_} if (@_);
780    
781          croak "need list name or email" unless ($arg->{'list'} || $arg->{'email'});  #       croak "need list name or email" unless ($arg->{'list'} || $arg->{'email'});
782    
783          $arg->{'list'} = lc($arg->{'list'});          my $sql = qq{
784          $arg->{'email'} = lc($arg->{'email'});                          select
785                                    received.id as id,
786                                    lists.name as list,
787                                    users.ext_id as ext_id,
788                                    users.email as email,
789            };
790            $sql .= qq{             message,} if ($arg->{'message'});
791            $sql .= qq{
792                                    bounced,received.date as date
793                            from received
794                            join lists on lists.id = list_id
795                            join users on users.id = user_id
796            };
797    
798            my $order = qq{ order by date asc };
799    
800            my $where;
801    
802          my @out;          $where->{'lists.name'} = lc($arg->{'list'}) if ($arg->{'list'});
803            $where->{'users.email'} = lc($arg->{'email'}) if ($arg->{'email'});
804            $where->{'received.date'} = { '>=', $arg->{'date_from'} } if ($arg->{'date_from'});
805            $where->{'received.date'} = { '<=', $arg->{'date_to'} } if ($arg->{'date_to'});
806    
807          my $sth = $self->{'loader'}->find_class('received')->sql_received;          # hum, yammy one-liner
808          $sth->execute();          my($stmt, @bind)  = SQL::Abstract->new->where($where);
809    
810            my $dbh = $self->{'loader'}->find_class('received')->db_Main;
811    
812            my $sth = $dbh->prepare($sql . $stmt . $order);
813            $sth->execute(@bind);
814          return $sth->fetchall_hash;          return $sth->fetchall_hash;
815  }  }
816    
# Line 825  sub _add_aliases { Line 881  sub _add_aliases {
881          $self_path =~ s#/[^/]+$##;          $self_path =~ s#/[^/]+$##;
882          $self_path =~ s#/t/*$#/#;          $self_path =~ s#/t/*$#/#;
883    
884          $target .= qq#| cd $self_path && ./sender.pl --inbox="$list"#;          $target .= qq#"| cd $self_path && ./sender.pl --inbox='$list'"#;
885    
886            # remove hostname from email to make Postfix's postalias happy
887            $email =~ s/@.+// if (not $self->{full_hostname_in_aliases});
888    
889          if ($a->exists($email)) {          if ($a->exists($email)) {
890                  $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 833  sub _add_aliases { Line 892  sub _add_aliases {
892                  $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;
893          }          }
894    
895          #$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;
896    
897          return 1;          return 1;
898  }  }
# Line 858  feed correct (and configured) return add Line 917  feed correct (and configured) return add
917    
918  =cut  =cut
919    
920    sub find_or_create {
921            my $self = shift;
922            my $obj = shift;
923            my %args = {@_};
924    
925            my ( $id, $msg ) = $obj->load_by_cols(%args);
926        unless ( $obj->{values}->{id} ) {
927                    warn "find_or_CREATE(",dump( \%args ), ")";
928                    return $obj->create(%args);
929            }
930    
931            warn "FIND_or_create(",dump( \%args ), ") = $id";
932            return $id;
933    }
934    
935    
936  sub _add_list {  sub _add_list {
937          my $self = shift;          my $self = shift;
938    
# Line 869  sub _add_list { Line 944  sub _add_list {
944    
945          my $from_addr = $arg->{'from'};          my $from_addr = $arg->{'from'};
946    
947          my $lists = $self->{'loader'}->find_class('lists');          my $lists = Nos::Lists->new( handle => $self->{h} );
948    
949          $self->_add_aliases(          $self->_add_aliases(
950                  list => $name,                  list => $name,
# Line 877  sub _add_list { Line 952  sub _add_list {
952                  aliases => $aliases,                  aliases => $aliases,
953          ) || warn "can't add alias $email for list $name";          ) || warn "can't add alias $email for list $name";
954    
955          my $l = $lists->find_or_create({          my $l = $self->find_or_create($lists, {
956                  name => $name,                  name => $name,
957                  email => $email,                  email => $email,
958          });          });
# Line 997  and options for it. Line 1072  and options for it.
1072  =cut  =cut
1073    
1074  sub new {  sub new {
1075          my $class = shift;          my $class = shift;
1076          my $self = {@_};          my $self = {@_};
1077    
1078          croak "need aliases parametar" unless ($self->{'aliases'});          croak "need aliases parametar" unless ($self->{'aliases'});
1079    
# Line 1075  sub AddMemberToList { Line 1150  sub AddMemberToList {
1150    
1151          if ($_[0] !~ m/^HASH/) {          if ($_[0] !~ m/^HASH/) {
1152                  return $nos->add_member_to_list(                  return $nos->add_member_to_list(
1153                          list => $_[0], email => $_[1], name => $_[2], ext_id => $_[4],                          list => $_[0], email => $_[1], name => $_[2], ext_id => $_[3],
1154                  );                  );
1155          } else {          } else {
1156                  return $nos->add_member_to_list( %{ shift @_ } );                  return $nos->add_member_to_list( %{ shift @_ } );
# Line 1151  sub AddMessageToList { Line 1226  sub AddMessageToList {
1226          }          }
1227  }  }
1228    
 =head1 UNIMPLEMENTED FUNCTIONS  
   
 This is a stub for documentation of unimplemented functions.  
   
1229  =head2 MessagesReceived  =head2 MessagesReceived
1230    
1231    Return statistics about received messages.
1232    
1233   my @result = MessagesReceived(   my @result = MessagesReceived(
1234          list => 'My list',          list => 'My list',
1235          email => 'jdoe@example.com',          email => 'jdoe@example.com',
1236            from_date => '2005-01-01 10:15:00',
1237            to_date => '2005-01-01 12:00:00',
1238            message => 0,
1239   );   );
1240    
1241  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
1242    parametars are optional.
1243    
1244  For format of returned array element see C<received_messages>.  For format of returned array element see C<received_messages>.
1245    
 =head2 MessagesReceivedByDate  
   
 =head2 MessagesReceivedByDateWithContent  
   
 =head2 ReceivedMessasgeContent  
   
 Return content of received message.  
   
  my $mail_body = ReceivedMessageContent( id => 42 );  
   
1246  =cut  =cut
1247    
1248    sub MessagesReceived {
1249            my $self = shift;
1250    
1251            if ($_[0] !~ m/^HASH/) {
1252                    die "need at least list or email" unless (scalar @_ < 2);
1253                    return \@{ $nos->received_messages(
1254                            list => $_[0], email => $_[1],
1255                            from_date => $_[2], to_date => $_[3],
1256                            message => $_[4]
1257                    ) };
1258            } else {
1259                    my $arg = shift;
1260                    die "need list or email argument" unless ($arg->{'list'} || $arg->{'email'});
1261                    return \@{ $nos->received_messages( %{ $arg } ) };
1262            }
1263    }
1264    
1265  ###  ###
1266    
# Line 1189  Returning arrays from SOAP calls is some Line 1270  Returning arrays from SOAP calls is some
1270  seems that SOAP::Lite client thinks that it has array with one element which  seems that SOAP::Lite client thinks that it has array with one element which
1271  is array of hashes with data.  is array of hashes with data.
1272    
1273    =head1 PRIVATE METHODS
1274    
1275    Documented here because tests use them
1276    
1277    =head2 _nos_object
1278    
1279      my $nos = $nos->_nos_object;
1280    
1281    =cut
1282    
1283    sub _nos_object {
1284            return $nos;
1285    }
1286    
1287  =head1 EXPORT  =head1 EXPORT
1288    
1289  Nothing.  Nothing.
Legend:
Removed from v.76  
changed lines
  Added in v.92
  ViewVC Help
Powered by ViewVC 1.1.26