/[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 22 by dpavlin, Sun May 15 21:52:56 2005 UTC revision 45 by dpavlin, Wed May 18 13:12:54 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.4';
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
121    
122    Add new member to list
123    
124     $nos->add_member_to_list(
125            list => "My list",
126            email => "john.doe@example.com",
127            name => "John A. Doe",
128     );
129    
130    C<name> parametar is optional.
131    
132    Return member ID if user is added.
133    
134    =cut
135    
136    sub add_member_to_list {
137            my $self = shift;
138    
139            my $arg = {@_};
140    
141            my $email = $arg->{'email'} || croak "can't add user without e-mail";
142            my $name = $arg->{'name'} || '';
143            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)) {
148                    carp "SKIPPING $name <$email>\n";
149                    return 0;
150            }
151    
152            carp "# $name <$email>\n" if ($self->{'verbose'});
153    
154            my $users = $self->{'loader'}->find_class('users');
155            my $user_list = $self->{'loader'}->find_class('user_list');
156    
157            my $this_user = $users->find_or_create({
158                    email => $email,
159            }) || croak "can't find or create member\n";
160    
161            if ($name && $this_user->name ne $name) {
162                    $this_user->name($name || '');
163                    $this_user->update;
164            }
165    
166            my $user_on_list = $user_list->find_or_create({
167                    user_id => $this_user->id,
168                    list_id => $list->id,
169            }) || croak "can't add user to list";
170    
171            $list->dbi_commit;
172            $this_user->dbi_commit;
173            $user_on_list->dbi_commit;
174    
175            return $this_user->id;
176    }
177    
178    =head2 list_members
179    
180    List all members of some list.
181    
182     my @members = list_members(
183            list => 'My list',
184     );
185    
186    Returns array of hashes with user informations like this:
187    
188     $member = {
189            name => 'Dobrica Pavlinusic',
190            email => 'dpavlin@rot13.org
191     }
192    
193    If list is not found, returns false.
194    
195    =cut
196    
197    sub list_members {
198            my $self = shift;
199    
200            my $args = {@_};
201    
202            my $list_name = $args->{'list'} || confess "need list name";
203    
204            my $lists = $self->{'loader'}->find_class('lists');
205            my $user_list = $self->{'loader'}->find_class('user_list');
206    
207            my $this_list = $lists->search( name => $list_name )->first || return;
208    
209            my @results;
210    
211            foreach my $user_on_list ($user_list->search(list_id => $this_list->id)) {
212                    my $row = {
213                            name => $user_on_list->user_id->name,
214                            email => $user_on_list->user_id->email,
215                    };
216    
217                    push @results, $row;
218            }
219    
220            return @results;
221    
222    }
223    
224    
225    =head2 delete_member
226    
227    Delete member from database.
228    
229     my $ok = delete_member(
230            name => 'Dobrica Pavlinusic'
231     );
232    
233     my $ok = delete_member(
234            email => 'dpavlin@rot13.org'
235     );
236    
237    Returns false if user doesn't exist.
238    
239    =cut
240    
241    sub delete_member {
242            my $self = shift;
243    
244            my $args = {@_};
245    
246            croak "need name or email of user to delete" unless ($args->{'name'} || $args->{'email'});
247    
248            my $key = 'name';
249            $key = 'email' if ($args->{'email'});
250    
251            my $users = $self->{'loader'}->find_class('users');
252    
253            my $this_user = $users->search( $key => $args->{$key} )->first || return;
254    
255    print Dumper($this_user);
256    
257            $this_user->delete || croak "can't delete user\n";
258    
259            return $users->dbi_commit || croak "can't commit";
260    }
261    
262    =head2 add_message_to_list
263    
264    Adds message to one list's queue for later sending.
265    
266     $nos->add_message_to_list(
267            list => 'My list',
268            message => 'Subject: welcome to list
269    
270     This is example message
271     ',
272     );    
273    
274    On success returns ID of newly created (or existing) message.
275    
276    Only required header in e-mail is C<Subject:>. C<From:> and C<To:> headers
277    will be automatically generated, but if you want to use own headers, just
278    include them in messages.
279    
280    =cut
281    
282    sub add_message_to_list {
283            my $self = shift;
284    
285            my $args = {@_};
286    
287            my $list_name = $args->{'list'} || confess "need list name";
288            my $message_text = $args->{'message'} || croak "need message";
289    
290            my $m = Email::Simple->new($message_text) || croak "can't parse message";
291    
292            unless( $m->header('Subject') ) {
293                    warn "message doesn't have Subject header\n";
294                    return;
295            }
296    
297            my $lists = $self->{'loader'}->find_class('lists');
298    
299            my $this_list = $lists->search(
300                    name => $list_name,
301            )->first || croak "can't find list $list_name";
302    
303            my $messages = $self->{'loader'}->find_class('messages');
304    
305            my $this_message = $messages->find_or_create({
306                    message => $message_text
307            }) || croak "can't insert message";
308    
309            $this_message->dbi_commit() || croak "can't add message";
310    
311            my $queue = $self->{'loader'}->find_class('queue');
312    
313            $queue->find_or_create({
314                    message_id => $this_message->id,
315                    list_id => $this_list->id,
316            }) || croak "can't add message ",$this_message->id," to list ",$this_list->id, ": ",$this_list->name;
317    
318            $queue->dbi_commit || croak "can't add message to list ",$this_list->name;
319    
320            return $this_message->id;
321    }
322    
323    
324  =head2 send_queued_messages  =head2 send_queued_messages
325    
326  Send queued messages or just ones for selected list  Send queued messages or just ones for selected list
327    
328   $noc->send_queued_messages("my list");   $nos->send_queued_messages("My list");
329    
330  =cut  =cut
331    
# Line 109  sub send_queued_messages { Line 357  sub send_queued_messages {
357    
358                  foreach my $u ($user_list->search(list_id => $m->list_id)) {                  foreach my $u ($user_list->search(list_id => $m->list_id)) {
359    
360                            my $to_email = $u->user_id->email;
361    
362                            my ($from,$domain) = split(/@/, $u->list_id->email, 2);
363    
364                          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 )) {
365                                  print "SKIP ",$u->user_id->email," message allready sent\n";                                  print "SKIP $to_email message allready sent\n";
366                          } else {                          } else {
367                                  print "\t",$u->user_id->email,"\n";                                  print "=> $to_email\n";
368    
369                                    my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;
370                                    my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
371    
372                                  my $hdr = "From: " . $u->list_id->name . " <" . $u->list_id->email . ">\n" .                                  my $hash = $auth->generate_hash( $to_email );
373                                          "To: " . $u->user_id->full_name . " <". $u->user_id->email. ">\n";  
374                                    my $from = $u->list_id->name . " <" . $from . "+" . $hash . ( $domain ? "@" . $domain : '' ). ">";
375                                    my $to = $u->user_id->name . " <$to_email>";
376    
377                                    my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
378    
379                                    $m_obj->header_set('From', $from) || croak "can't set From: header";
380                                    $m_obj->header_set('To', $to) || croak "can't set To: header";
381    
382                                    $m_obj->header_set('X-Nos-Version', $VERSION);
383                                    $m_obj->header_set('X-Nos-Hash', $hash);
384    
385                                  # FIXME do real sending :-)                                  # FIXME do real sending :-)
386                                  send IO => "$hdr\n$msg";                                  send IO => $m_obj->as_string;
387    
388                                  $sent->create({                                  $sent->create({
389                                          message_id => $m->message_id,                                          message_id => $m->message_id,
390                                          user_id => $u->user_id,                                          user_id => $u->user_id,
391                                            hash => $hash,
392                                  });                                  });
393                                  $sent->dbi_commit;                                  $sent->dbi_commit;
394                          }                          }
# Line 134  sub send_queued_messages { Line 400  sub send_queued_messages {
400    
401  }  }
402    
403  =head2 EXPORT  =head2 inbox_message
404    
405    Receive single message for list's inbox.
406    
407     my $ok = $nos->inbox_message(
408            list => 'My list',
409            message => $message,
410     );
411    
412    =cut
413    
414    sub inbox_message {
415            my $self = shift;
416    
417            my $arg = {@_};
418    
419            return unless ($arg->{'message'});
420            croak "need list name" unless ($arg->{'list'});
421    
422            my $this_list = $self->_get_list($arg->{'list'}) || croak "can't find list ".$arg->{'list'}."\n";
423    
424            my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message";
425    
426            my $to = $m->header('To') || die "can't find To: address in incomming message\n";
427    
428            my @addrs = Email::Address->parse( $to );
429    
430            die "can't parse To: $to address\n" unless (@addrs);
431    
432            my $hl = $self->{'hash_len'} || confess "no hash_len?";
433    
434            my $hash;
435    
436            foreach my $a (@addrs) {
437                    if ($a->address =~ m/\+([a-f0-9]{$hl})@/) {
438                            $hash = $1;
439                            last;
440                    }
441            }
442    
443            croak "can't find hash in e-mail $to\n" unless ($hash);
444    
445            my $sent = $self->{'loader'}->find_class('sent');
446    
447            # will use null if no matching message_id is found
448            my $sent_msg = $sent->search( hash => $hash )->first;
449    
450            my ($message_id, $user_id) = (undef, undef);    # init with NULL
451    
452            if ($sent_msg) {
453                    $message_id = $sent_msg->message_id || carp "no message_id";
454                    $user_id = $sent_msg->user_id || carp "no user_id";
455            }
456    
457    
458            my $is_bounce = 0;
459    
460            my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
461                    $arg->{'message'}, { report_non_bounces=>1 },
462            ) };
463            carp "can't check if this message is bounce!" if ($@);
464    
465            $is_bounce++ if ($bounce && $bounce->is_bounce);
466    
467            my $received = $self->{'loader'}->find_class('received');
468    
469            my $this_received = $received->find_or_create({
470                    user_id => $user_id,
471                    list_id => $this_list->id,
472                    message_id => $message_id,
473                    message => $arg->{'message'},
474                    bounced => $is_bounce,
475            }) || croak "can't insert received message";
476    
477            $this_received->dbi_commit;
478    
479            print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
480    
481    
482            warn "inbox is not yet implemented";
483    }
484    
485    
486    =head1 INTERNAL METHODS
487    
488    Beware of dragons! You shouldn't need to call those methods directly.
489    
490    =head2 _add_list
491    
492    Create new list
493    
494     my $list_obj = $nos->_add_list(
495            list => 'My list',
496            email => 'my-list@example.com',
497     );
498    
499    Returns C<Class::DBI> object for created list.
500    
501    C<email> address can be with domain or without it if your
502    MTA appends it. There is no checking for validity of your
503    list e-mail. Flexibility comes with resposibility, so please
504    feed correct (and configured) return addresses.
505    
506    =cut
507    
508    sub _add_list {
509            my $self = shift;
510    
511            my $arg = {@_};
512    
513            my $name = $arg->{'list'} || confess "can't add list without name";
514            my $email = $arg->{'email'} || confess "can't add list without e-mail";
515    
516            my $lists = $self->{'loader'}->find_class('lists');
517    
518            my $l = $lists->find_or_create({
519                    name => $name,
520                    email => $email,
521            });
522            
523            croak "can't add list $name\n" unless ($l);
524    
525            $l->dbi_commit;
526    
527            return $l;
528    
529    }
530    
531    
532    =head2 _get_list
533    
534    Get list C<Class::DBI> object.
535    
536     my $list_obj = $nos->check_list('My list');
537    
538    Returns false on failure.
539    
540    =cut
541    
542    sub _get_list {
543            my $self = shift;
544    
545            my $name = shift || return;
546    
547            my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";
548    
549            return $lists->search({ name => $name })->first;
550    }
551    
552    ###
553    ### SOAP
554    ###
555    
556    package Nos::SOAP;
557    
558    use Carp;
559    
560    =head1 SOAP methods
561    
562    This methods are thin wrappers to provide SOAP calls. They are grouped in
563    C<Nos::SOAP> package which is in same F<Nos.pm> module file.
564    
565    Usually, you want to use named variables in your SOAP calls if at all
566    possible.
567    
568    However, if you have broken SOAP library (like PHP SOAP class from PEAR)
569    you will want to use positional arguments (in same order as documented for
570    methods below).
571    
572    =cut
573    
574    my $nos;
575    
576    sub new {
577            my $class = shift;
578            my $self = {@_};
579            bless($self, $class);
580    
581            $nos = new Nos( @_ ) || die "can't create Nos object";
582    
583            $self ? return $self : return undef;
584    }
585    
586    
587    =head2 NewList
588    
589     $message_id = NewList(
590            list => 'My list',
591            email => 'my-list@example.com'
592     );
593    
594    =cut
595    
596    sub NewList {
597            my $self = shift;
598    
599            if ($_[0] !~ m/^HASH/) {
600                    return $nos->new_list(
601                            list => $_[0], email => $_[1],
602                    );
603            } else {
604                    return $nos->new_list( %{ shift @_ } );
605            }
606    }
607    
608    
609    =head2 AddMemberToList
610    
611     $member_id = AddMemberToList(
612            list => 'My list',
613            email => 'e-mail@example.com',
614            name => 'Full Name'
615     );
616    
617    =cut
618    
619    sub AddMemberToList {
620            my $self = shift;
621    
622            if ($_[0] !~ m/^HASH/) {
623                    return $nos->add_member_to_list(
624                            list => $_[0], email => $_[1], name => $_[2],
625                    );
626            } else {
627                    return $nos->add_member_to_list( %{ shift @_ } );
628            }
629    }
630    
631    
632    =head2 ListMembers
633    
634     my @members = ListMembers(
635            list => 'My list',
636     );
637    
638    Returns array of hashes with user informations, see C<list_members>.
639    
640    =cut
641    
642    sub ListMembers {
643            my $self = shift;
644    
645            my $list_name;
646    
647            if ($_[0] !~ m/^HASH/) {
648                    $list_name = shift;
649            } else {
650                    $list_name = $_[0]->{'list'};
651            }
652    
653            return $nos->list_members( list => $list_name );
654    }
655    
656  None by default.  =head2 AddMessageToList
657    
658     $message_id = AddMessageToList(
659            list => 'My list',
660            message => 'From: My list...'
661     );
662    
663    =cut
664    
665    sub AddMessageToList {
666            my $self = shift;
667    
668            if ($_[0] !~ m/^HASH/) {
669                    return $nos->add_message_to_list(
670                            list => $_[0], message => $_[1],
671                    );
672            } else {
673                    return $nos->add_message_to_list( %{ shift @_ } );
674            }
675    }
676    
677    
678    ###
679    
680    =head1 EXPORT
681    
682    Nothing.
683    
684  =head1 SEE ALSO  =head1 SEE ALSO
685    
686  mailman, ezmlm, sympa, L<Mail::Salsa>  mailman, ezmlm, sympa, L<Mail::Salsa>
687    
688    
689  =head1 AUTHOR  =head1 AUTHOR
690    
691  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
692    
693    
694  =head1 COPYRIGHT AND LICENSE  =head1 COPYRIGHT AND LICENSE
695    
696  Copyright (C) 2005 by Dobrica Pavlinusic  Copyright (C) 2005 by Dobrica Pavlinusic
# Line 156  at your option, any later version of Per Line 701  at your option, any later version of Per
701    
702    
703  =cut  =cut
704    
705    1;
Legend:
Removed from v.22  
changed lines
  Added in v.45
  ViewVC Help
Powered by ViewVC 1.1.26