/[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 23 by dpavlin, Sun May 15 22:12:31 2005 UTC revision 43 by dpavlin, Wed May 18 12:29:35 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.1';  our $VERSION = '0.3';
20    
21  use Class::DBI::Loader;  use Class::DBI::Loader;
22  use Email::Valid;  use Email::Valid;
23  use Email::Send;  use Email::Send;
24  use Carp;  use Carp;
25    use Email::Auth::AddressHash;
26    use Email::Simple;
27    use Email::Address;
28    use Mail::DeliveryStatus::BounceParser;
29    use Data::Dumper;
30    
31  =head1 NAME  =head1 NAME
32    
# Line 48  Create new instance specifing database, Line 53  Create new instance specifing database,
53          passwd => '',          passwd => '',
54          debug => 1,          debug => 1,
55          verbose => 1,          verbose => 1,
56            hash_len => 8,
57   );   );
58    
59    Parametar C<hash_len> defines length of hash which will be added to each
60    outgoing e-mail message to ensure that replies can be linked with sent e-mails.
61    
62  =cut  =cut
63    
64  sub new {  sub new {
# Line 70  sub new { Line 79  sub new {
79                  relationships   => 1,                  relationships   => 1,
80          ) || croak "can't init Class::DBI::Loader";          ) || croak "can't init Class::DBI::Loader";
81    
82            $self->{'hash_len'} ||= 8;
83    
84          $self ? return $self : return undef;          $self ? return $self : return undef;
85  }  }
86    
87    
88    =head2 new_list
89    
90    Create new list. Required arguments are name of C<list> and
91    C<email> address.
92    
93     $nos->new_list(
94            list => 'My list',
95            email => 'my-list@example.com',
96     );
97    
98    Returns ID of newly created list.
99    
100    Calls internally L<_add_list>, see details there.
101    
102    =cut
103    
104    sub new_list {
105            my $self = shift;
106    
107            my $arg = {@_};
108    
109            confess "need list name" unless ($arg->{'list'});
110            confess "need list email" unless ($arg->{'list'});
111    
112            my $l = $self->_get_list($arg->{'list'}) ||
113                    $self->_add_list( @_ ) ||
114                    return undef;
115    
116            return $l->id;
117    }
118    
119    
120  =head2 add_member_to_list  =head2 add_member_to_list
121    
122  Add new member to list  Add new member to list
# Line 85  Add new member to list Line 129  Add new member to list
129    
130  C<name> parametar is optional.  C<name> parametar is optional.
131    
132  Return true if user is added.  Return member ID if user is added.
133    
134  =cut  =cut
135    
# Line 94  sub add_member_to_list { Line 138  sub add_member_to_list {
138    
139          my $arg = {@_};          my $arg = {@_};
140    
141          my $email = $arg->{'email'} || confess "can't add user without e-mail";          my $email = $arg->{'email'} || croak "can't add user without e-mail";
142          my $name = $arg->{'name'} || '';          my $name = $arg->{'name'} || '';
143          confess "need list name" unless ($arg->{'list'});          my $list_name = $arg->{'list'} || croak "need list name";
144    
145            my $list = $self->_get_list($list_name) || croak "list $list_name doesn't exist";
146    
147          if (! Email::Valid->address($email)) {          if (! Email::Valid->address($email)) {
148                  warn "SKIPPING $name <$email>";                  carp "SKIPPING $name <$email>\n";
149                  return 0;                  return 0;
150          }          }
151    
152          print "# $name <$email>\n";          carp "# $name <$email>\n" if ($self->{'verbose'});
153    
         my $lists = $self->{'loader'}->find_class('lists');  
154          my $users = $self->{'loader'}->find_class('users');          my $users = $self->{'loader'}->find_class('users');
155          my $user_list = $self->{'loader'}->find_class('user_list');          my $user_list = $self->{'loader'}->find_class('user_list');
156    
         my $list = $lists->find_or_create({  
                 name => $arg->{'list'},  
         }) || croak "can't add list ",$arg->{'list'},"\n";  
           
157          my $this_user = $users->find_or_create({          my $this_user = $users->find_or_create({
158                  email => $email,                  email => $email,
                 full_name => $name,  
159          }) || croak "can't find or create member\n";          }) || croak "can't find or create member\n";
160    
161            if ($name && $this_user->full_name ne $name) {
162                    $this_user->full_name($name || '');
163                    $this_user->update;
164            }
165    
166          my $user_on_list = $user_list->find_or_create({          my $user_on_list = $user_list->find_or_create({
167                  user_id => $this_user->id,                  user_id => $this_user->id,
168                  list_id => $list->id,                  list_id => $list->id,
# Line 127  sub add_member_to_list { Line 172  sub add_member_to_list {
172          $this_user->dbi_commit;          $this_user->dbi_commit;
173          $user_on_list->dbi_commit;          $user_on_list->dbi_commit;
174    
175          return 1;          return $this_user->id;
176    }
177    
178    =head2 list_members
179    
180     my @members = list_members(
181            list => 'My list',
182     );
183    
184    Returns array of hashes with user informations like this:
185    
186     $member = {
187            full_name => 'Dobrica Pavlinusic',
188            email => 'dpavlin@rot13.org
189     }
190    
191    =cut
192    
193    sub list_members {
194            my $self = shift;
195    
196            my $args = {@_};
197    
198            my $list_name = $args->{'list'} || confess "need list name";
199    
200            my $lists = $self->{'loader'}->find_class('lists');
201            my $user_list = $self->{'loader'}->find_class('user_list');
202    
203            my $this_list = $lists->search( name => $list_name )->first || croak "can't find list $list_name\n";
204    
205            my @results;
206    
207            foreach my $user_on_list ($user_list->search(list_id => $this_list->id)) {
208                    my $row = {
209                            full_name => $user_on_list->user_id->full_name,
210                            email => $user_on_list->user_id->email,
211                    };
212    
213                    push @results, $row;
214            }
215    
216            return @results;
217    
218    }
219    
220    
221    =head2 add_message_to_list
222    
223    Adds message to one list's queue for later sending.
224    
225     $nos->add_message_to_list(
226            list => 'My list',
227            message => 'Subject: welcome to list
228    
229     This is example message
230     ',
231     );    
232    
233    On success returns ID of newly created (or existing) message.
234    
235    Only required header in e-mail is C<Subject:>. C<From:> and C<To:> headers
236    will be automatically generated, but if you want to use own headers, just
237    include them in messages.
238    
239    =cut
240    
241    sub add_message_to_list {
242            my $self = shift;
243    
244            my $args = {@_};
245    
246            my $list_name = $args->{'list'} || confess "need list name";
247            my $message_text = $args->{'message'} || croak "need message";
248    
249            my $m = Email::Simple->new($message_text) || croak "can't parse message";
250    
251            unless( $m->header('Subject') ) {
252                    warn "message doesn't have Subject header\n";
253                    return;
254            }
255    
256            my $lists = $self->{'loader'}->find_class('lists');
257    
258            my $this_list = $lists->search(
259                    name => $list_name,
260            )->first || croak "can't find list $list_name";
261    
262            my $messages = $self->{'loader'}->find_class('messages');
263    
264            my $this_message = $messages->find_or_create({
265                    message => $message_text
266            }) || croak "can't insert message";
267    
268            $this_message->dbi_commit() || croak "can't add message";
269    
270            my $queue = $self->{'loader'}->find_class('queue');
271    
272            $queue->find_or_create({
273                    message_id => $this_message->id,
274                    list_id => $this_list->id,
275            }) || croak "can't add message ",$this_message->id," to list ",$this_list->id, ": ",$this_list->name;
276    
277            $queue->dbi_commit || croak "can't add message to list ",$this_list->name;
278    
279            return $this_message->id;
280  }  }
281    
282    
283  =head2 send_queued_messages  =head2 send_queued_messages
284    
285  Send queued messages or just ones for selected list  Send queued messages or just ones for selected list
286    
287   $noc->send_queued_messages("my list");   $nos->send_queued_messages("My list");
288    
289  =cut  =cut
290    
# Line 166  sub send_queued_messages { Line 316  sub send_queued_messages {
316    
317                  foreach my $u ($user_list->search(list_id => $m->list_id)) {                  foreach my $u ($user_list->search(list_id => $m->list_id)) {
318    
319                            my $to_email = $u->user_id->email;
320    
321                            my ($from,$domain) = split(/@/, $u->list_id->email, 2);
322    
323                          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 )) {
324                                  print "SKIP ",$u->user_id->email," message allready sent\n";                                  print "SKIP $to_email message allready sent\n";
325                          } else {                          } else {
326                                  print "\t",$u->user_id->email,"\n";                                  print "=> $to_email\n";
327    
328                                    my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;
329                                    my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
330    
331                                    my $hash = $auth->generate_hash( $to_email );
332    
333                                  my $hdr = "From: " . $u->list_id->name . " <" . $u->list_id->email . ">\n" .                                  my $from = $u->list_id->name . " <" . $from . "+" . $hash . ( $domain ? "@" . $domain : '' ). ">";
334                                          "To: " . $u->user_id->full_name . " <". $u->user_id->email. ">\n";                                  my $to = $u->user_id->full_name . " <$to_email>";
335    
336                                    my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
337    
338                                    $m_obj->header_set('From', $from) || croak "can't set From: header";
339                                    $m_obj->header_set('To', $to) || croak "can't set To: header";
340    
341                                    $m_obj->header_set('X-Nos-Version', $VERSION);
342                                    $m_obj->header_set('X-Nos-Hash', $hash);
343    
344                                  # FIXME do real sending :-)                                  # FIXME do real sending :-)
345                                  send IO => "$hdr\n$msg";                                  send IO => $m_obj->as_string;
346    
347                                  $sent->create({                                  $sent->create({
348                                          message_id => $m->message_id,                                          message_id => $m->message_id,
349                                          user_id => $u->user_id,                                          user_id => $u->user_id,
350                                            hash => $hash,
351                                  });                                  });
352                                  $sent->dbi_commit;                                  $sent->dbi_commit;
353                          }                          }
# Line 191  sub send_queued_messages { Line 359  sub send_queued_messages {
359    
360  }  }
361    
362  =head2 EXPORT  =head2 inbox_message
363    
364    Receive single message for list's inbox.
365    
366     my $ok = $nos->inbox_message(
367            list => 'My list',
368            message => $message,
369     );
370    
371    =cut
372    
373    sub inbox_message {
374            my $self = shift;
375    
376            my $arg = {@_};
377    
378            return unless ($arg->{'message'});
379            croak "need list name" unless ($arg->{'list'});
380    
381            my $this_list = $self->_get_list($arg->{'list'}) || croak "can't find list ".$arg->{'list'}."\n";
382    
383            my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message";
384    
385            my $to = $m->header('To') || die "can't find To: address in incomming message\n";
386    
387            my @addrs = Email::Address->parse( $to );
388    
389            die "can't parse To: $to address\n" unless (@addrs);
390    
391            my $hl = $self->{'hash_len'} || confess "no hash_len?";
392    
393            my $hash;
394    
395            foreach my $a (@addrs) {
396                    if ($a->address =~ m/\+([a-f0-9]{$hl})@/) {
397                            $hash = $1;
398                            last;
399                    }
400            }
401    
402            croak "can't find hash in e-mail $to\n" unless ($hash);
403    
404            my $sent = $self->{'loader'}->find_class('sent');
405    
406            # will use null if no matching message_id is found
407            my $sent_msg = $sent->search( hash => $hash )->first;
408    
409            my ($message_id, $user_id) = (undef, undef);    # init with NULL
410    
411            if ($sent_msg) {
412                    $message_id = $sent_msg->message_id || carp "no message_id";
413                    $user_id = $sent_msg->user_id || carp "no user_id";
414            }
415    
416    
417            my $is_bounce = 0;
418    
419            my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
420                    $arg->{'message'}, { report_non_bounces=>1 },
421            ) };
422            carp "can't check if this message is bounce!" if ($@);
423    
424            $is_bounce++ if ($bounce && $bounce->is_bounce);
425    
426            my $received = $self->{'loader'}->find_class('received');
427    
428            my $this_received = $received->find_or_create({
429                    user_id => $user_id,
430                    list_id => $this_list->id,
431                    message_id => $message_id,
432                    message => $arg->{'message'},
433                    bounced => $is_bounce,
434            }) || croak "can't insert received message";
435    
436  None by default.          $this_received->dbi_commit;
437    
438            print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
439    
440    
441            warn "inbox is not yet implemented";
442    }
443    
444    
445    =head1 INTERNAL METHODS
446    
447    Beware of dragons! You shouldn't need to call those methods directly.
448    
449    =head2 _add_list
450    
451    Create new list
452    
453     my $list_obj = $nos->_add_list(
454            list => 'My list',
455            email => 'my-list@example.com',
456     );
457    
458    Returns C<Class::DBI> object for created list.
459    
460    C<email> address can be with domain or without it if your
461    MTA appends it. There is no checking for validity of your
462    list e-mail. Flexibility comes with resposibility, so please
463    feed correct (and configured) return addresses.
464    
465    =cut
466    
467    sub _add_list {
468            my $self = shift;
469    
470            my $arg = {@_};
471    
472            my $name = $arg->{'list'} || confess "can't add list without name";
473            my $email = $arg->{'email'} || confess "can't add list without e-mail";
474    
475            my $lists = $self->{'loader'}->find_class('lists');
476    
477            my $l = $lists->find_or_create({
478                    name => $name,
479                    email => $email,
480            });
481            
482            croak "can't add list $name\n" unless ($l);
483    
484            $l->dbi_commit;
485    
486            return $l;
487    
488    }
489    
490    
491    =head2 _get_list
492    
493    Get list C<Class::DBI> object.
494    
495     my $list_obj = $nos->check_list('My list');
496    
497    Returns false on failure.
498    
499    =cut
500    
501    sub _get_list {
502            my $self = shift;
503    
504            my $name = shift || return;
505    
506            my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";
507    
508            return $lists->search({ name => $name })->first;
509    }
510    
511    ###
512    ### SOAP
513    ###
514    
515    package Nos::SOAP;
516    
517    use Carp;
518    
519    =head1 SOAP methods
520    
521    This methods are thin wrappers to provide SOAP calls. They are grouped in
522    C<Nos::SOAP> package which is in same F<Nos.pm> module file.
523    
524    Usually, you want to use named variables in your SOAP calls if at all
525    possible.
526    
527    However, if you have broken SOAP library (like PHP SOAP class from PEAR)
528    you will want to use positional arguments (in same order as documented for
529    methods below).
530    
531    =cut
532    
533    my $nos;
534    
535    sub new {
536            my $class = shift;
537            my $self = {@_};
538            bless($self, $class);
539    
540            $nos = new Nos( @_ ) || die "can't create Nos object";
541    
542            $self ? return $self : return undef;
543    }
544    
545    
546    =head2 NewList
547    
548     $message_id = NewList(
549            list => 'My list',
550            email => 'my-list@example.com'
551     );
552    
553    =cut
554    
555    sub NewList {
556            my $self = shift;
557    
558            if ($_[0] !~ m/^HASH/) {
559                    return $nos->new_list(
560                            list => $_[0], email => $_[1],
561                    );
562            } else {
563                    return $nos->new_list( %{ shift @_ } );
564            }
565    }
566    
567    
568    =head2 AddMemberToList
569    
570     $member_id = AddMemberToList(
571            list => 'My list',
572            email => 'e-mail@example.com',
573            name => 'Full Name'
574     );
575    
576    =cut
577    
578    sub AddMemberToList {
579            my $self = shift;
580    
581            if ($_[0] !~ m/^HASH/) {
582                    return $nos->add_member_to_list(
583                            list => $_[0], email => $_[1], name => $_[2],
584                    );
585            } else {
586                    return $nos->add_member_to_list( %{ shift @_ } );
587            }
588    }
589    
590    
591    =head2 ListMembers
592    
593     my @members = ListMembers(
594            list => 'My list',
595     );
596    
597    Returns array of hashes with user informations, see C<list_members>.
598    
599    =cut
600    
601    sub ListMembers {
602            my $self = shift;
603    
604            my $list_name;
605    
606            if ($_[0] !~ m/^HASH/) {
607                    $list_name = shift;
608            } else {
609                    $list_name = $_[0]->{'list'};
610            }
611    
612            return $nos->list_members( list => $list_name );
613    }
614    
615    =head2 AddMessageToList
616    
617     $message_id = AddMessageToList(
618            list => 'My list',
619            message => 'From: My list...'
620     );
621    
622    =cut
623    
624    sub AddMessageToList {
625            my $self = shift;
626    
627            if ($_[0] !~ m/^HASH/) {
628                    return $nos->add_message_to_list(
629                            list => $_[0], message => $_[1],
630                    );
631            } else {
632                    return $nos->add_message_to_list( %{ shift @_ } );
633            }
634    }
635    
636    
637    ###
638    
639    =head1 EXPORT
640    
641    Nothing.
642    
643  =head1 SEE ALSO  =head1 SEE ALSO
644    
645  mailman, ezmlm, sympa, L<Mail::Salsa>  mailman, ezmlm, sympa, L<Mail::Salsa>
646    
647    
648  =head1 AUTHOR  =head1 AUTHOR
649    
650  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
651    
652    
653  =head1 COPYRIGHT AND LICENSE  =head1 COPYRIGHT AND LICENSE
654    
655  Copyright (C) 2005 by Dobrica Pavlinusic  Copyright (C) 2005 by Dobrica Pavlinusic
# Line 213  at your option, any later version of Per Line 660  at your option, any later version of Per
660    
661    
662  =cut  =cut
663    
664    1;
Legend:
Removed from v.23  
changed lines
  Added in v.43
  ViewVC Help
Powered by ViewVC 1.1.26