/[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 21 by dpavlin, Sun May 15 21:35:15 2005 UTC revision 38 by dpavlin, Tue May 17 21:37:06 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 57  sub new { Line 66  sub new {
66          my $self = {@_};          my $self = {@_};
67          bless($self, $class);          bless($self, $class);
68    
69            croak "need at least dsn" unless ($self->{'dsn'});
70    
71          $self->{'loader'} = Class::DBI::Loader->new(          $self->{'loader'} = Class::DBI::Loader->new(
72                  debug           => $self->{'debug'},                  debug           => $self->{'debug'},
73                  dsn             => $self->{'dsn'},                  dsn             => $self->{'dsn'},
# Line 66  sub new { Line 77  sub new {
77  #               additional_classes      => qw/Class::DBI::AbstractSearch/,  #               additional_classes      => qw/Class::DBI::AbstractSearch/,
78  #               additional_base_classes => qw/My::Stuff/,  #               additional_base_classes => qw/My::Stuff/,
79                  relationships   => 1,                  relationships   => 1,
80          );          ) || 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    
 =head2 update_list_email  
87    
88  Update list e-mail address  =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->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({
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 add_message_to_list
179    
180    Adds message to one list's queue for later sending.
181    
182     $nos->add_message_to_list(
183            list => 'My list',
184            message => 'Subject: welcome to list
185    
186     This is example message
187     ',
188     );    
189    
190   $noc->update_list_email($list, 'foobar@example.com');  On success returns ID of newly created (or existing) message.
191    
192    Only required header in e-mail is C<Subject:>. C<From:> and C<To:> headers
193    will be automatically generated, but if you want to use own headers, just
194    include them in messages.
195    
196  =cut  =cut
197    
198  sub update_list_email {  sub add_message_to_list {
199          my $self = shift;          my $self = shift;
200    
201            my $args = {@_};
202    
203            my $list_name = $args->{'list'} || confess "need list name";
204            my $message_text = $args->{'message'} || croak "need message";
205    
206            my $m = Email::Simple->new($message_text) || croak "can't parse message";
207    
208            unless( $m->header('Subject') ) {
209                    warn "message doesn't have Subject header\n";
210                    return;
211            }
212    
213            my $lists = $self->{'loader'}->find_class('lists');
214    
215            my $this_list = $lists->search(
216                    name => $list_name,
217            )->first || croak "can't find list $list_name";
218    
219            my $messages = $self->{'loader'}->find_class('messages');
220    
221            my $this_message = $messages->find_or_create({
222                    message => $message_text
223            }) || croak "can't insert message";
224    
225            $this_message->dbi_commit() || croak "can't add message";
226    
227            my $queue = $self->{'loader'}->find_class('queue');
228    
229            $queue->find_or_create({
230                    message_id => $this_message->id,
231                    list_id => $this_list->id,
232            }) || croak "can't add message ",$this_message->id," to list ",$this_list->id, ": ",$this_list->name;
233    
234            $queue->dbi_commit || croak "can't add message to list ",$this_list->name;
235    
236            return $this_message->id;
237  }  }
238    
 =head2 send  
239    
240  Send a message using configured mailer.  =head2 send_queued_messages
241    
242   $nos->send("message with headers");  Send queued messages or just ones for selected list
243    
244     $nos->send_queued_messages("My list");
245    
246  =cut  =cut
247    
248  sub send_email {  sub send_queued_messages {
249          my $self = shift;          my $self = shift;
250    
251          my $message = shift || return;          my $list_name = shift;
252    
253            my $lists = $self->{'loader'}->find_class('lists');
254            my $queue = $self->{'loader'}->find_class('queue');
255            my $user_list = $self->{'loader'}->find_class('user_list');
256            my $sent = $self->{'loader'}->find_class('sent');
257    
258            my $my_q;
259            if ($list_name ne '') {
260                    my $l_id = $lists->search_like( name => $list_name )->first ||
261                            croak "can't find list $list_name";
262                    $my_q = $queue->search_like( list_id => $l_id ) ||
263                            croak "can't find list $list_name";
264            } else {
265                    $my_q = $queue->retrieve_all;
266            }
267    
268            while (my $m = $my_q->next) {
269                    next if ($m->all_sent);
270    
271                    print "sending message ",$m->message_id," enqueued on ",$m->date," to list ",$m->list_id->name,"\n";
272                    my $msg = $m->message_id->message;
273    
274                    foreach my $u ($user_list->search(list_id => $m->list_id)) {
275    
276                            my $to_email = $u->user_id->email;
277    
278                            my ($from,$domain) = split(/@/, $u->list_id->email, 2);
279    
280                            if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {
281                                    print "SKIP $to_email message allready sent\n";
282                            } else {
283                                    print "=> $to_email\n";
284    
285                                    my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;
286                                    my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
287    
288                                    my $hash = $auth->generate_hash( $to_email );
289    
290                                    my $from = $u->list_id->name . " <" . $from . "+" . $hash . ( $domain ? "@" . $domain : '' ). ">";
291                                    my $to = $u->user_id->full_name . " <$to_email>";
292    
293                                    my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
294    
295                                    $m_obj->header_set('From', $from) || croak "can't set From: header";
296                                    $m_obj->header_set('To', $to) || croak "can't set To: header";
297    
298                                    $m_obj->header_set('X-Nos-Version', $VERSION);
299                                    $m_obj->header_set('X-Nos-Hash', $hash);
300    
301                                    # FIXME do real sending :-)
302                                    send IO => $m_obj->as_string;
303    
304                                    $sent->create({
305                                            message_id => $m->message_id,
306                                            user_id => $u->user_id,
307                                            hash => $hash,
308                                    });
309                                    $sent->dbi_commit;
310                            }
311                    }
312                    $m->all_sent(1);
313                    $m->update;
314                    $m->dbi_commit;
315            }
316    
         send IO => $message;  
317  }  }
318    
319  =head2 EXPORT  =head2 inbox_message
320    
321    Receive single message for list's inbox.
322    
323     my $ok = $nos->inbox_message(
324            list => 'My list',
325            message => $message,
326     );
327    
328    =cut
329    
330  None by default.  sub inbox_message {
331            my $self = shift;
332    
333            my $arg = {@_};
334    
335            return unless ($arg->{'message'});
336            croak "need list name" unless ($arg->{'list'});
337    
338            my $this_list = $self->_get_list($arg->{'list'}) || croak "can't find list ".$arg->{'list'}."\n";
339    
340            my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message";
341    
342            my $to = $m->header('To') || die "can't find To: address in incomming message\n";
343    
344            my @addrs = Email::Address->parse( $to );
345    
346            die "can't parse To: $to address\n" unless (@addrs);
347    
348            my $hl = $self->{'hash_len'} || confess "no hash_len?";
349    
350            my $hash;
351    
352            foreach my $a (@addrs) {
353                    if ($a->address =~ m/\+([a-f0-9]{$hl})@/) {
354                            $hash = $1;
355                            last;
356                    }
357            }
358    
359            croak "can't find hash in e-mail $to\n" unless ($hash);
360    
361            my $sent = $self->{'loader'}->find_class('sent');
362    
363            # will use null if no matching message_id is found
364            my $sent_msg = $sent->search( hash => $hash )->first;
365    
366            my ($message_id, $user_id) = (undef, undef);    # init with NULL
367    
368            if ($sent_msg) {
369                    $message_id = $sent_msg->message_id || carp "no message_id";
370                    $user_id = $sent_msg->user_id || carp "no user_id";
371            }
372    
373    print "message_id: ",($message_id || "not found"),"\n";
374    
375            my $is_bounce = 0;
376    
377            my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
378                    $arg->{'message'}, { report_non_bounces=>1 },
379            ) };
380            carp "can't check if this message is bounce!" if ($@);
381    
382            $is_bounce++ if ($bounce && $bounce->is_bounce);
383    
384            my $received = $self->{'loader'}->find_class('received');
385    
386            my $this_received = $received->find_or_create({
387                    user_id => $user_id,
388                    list_id => $this_list->id,
389                    message_id => $message_id,
390                    message => $arg->{'message'},
391                    bounced => $is_bounce,
392            }) || croak "can't insert received message";
393    
394            $this_received->dbi_commit;
395    
396            warn "inbox is not yet implemented";
397    }
398    
399    
400    =head1 INTERNAL METHODS
401    
402    Beware of dragons! You shouldn't need to call those methods directly.
403    
404    =head2 _add_list
405    
406    Create new list
407    
408     my $list_obj = $nos->_add_list(
409            list => 'My list',
410            email => 'my-list@example.com',
411     );
412    
413    Returns C<Class::DBI> object for created list.
414    
415    C<email> address can be with domain or without it if your
416    MTA appends it. There is no checking for validity of your
417    list e-mail. Flexibility comes with resposibility, so please
418    feed correct (and configured) return addresses.
419    
420    =cut
421    
422    sub _add_list {
423            my $self = shift;
424    
425            my $arg = {@_};
426    
427            my $name = $arg->{'list'} || confess "can't add list without name";
428            my $email = $arg->{'email'} || confess "can't add list without e-mail";
429    
430            my $lists = $self->{'loader'}->find_class('lists');
431    
432            my $l = $lists->find_or_create({
433                    name => $name,
434                    email => $email,
435            });
436            
437            croak "can't add list $name\n" unless ($l);
438    
439            $l->dbi_commit;
440    
441            return $l;
442    
443    }
444    
445    
446    =head2 _get_list
447    
448    Get list C<Class::DBI> object.
449    
450     my $list_obj = $nos->check_list('My list');
451    
452    Returns false on failure.
453    
454    =cut
455    
456    sub _get_list {
457            my $self = shift;
458    
459            my $name = shift || return;
460    
461            my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";
462    
463            return $lists->search({ name => $name })->first;
464    }
465    
466    
467    =head1 EXPORT
468    
469    Nothing.
470    
471  =head1 SEE ALSO  =head1 SEE ALSO
472    
473  mailman, ezmlm, sympa, L<Mail::Salsa>  mailman, ezmlm, sympa, L<Mail::Salsa>
474    
475    
476  =head1 AUTHOR  =head1 AUTHOR
477    
478  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
479    
480    
481  =head1 COPYRIGHT AND LICENSE  =head1 COPYRIGHT AND LICENSE
482    
483  Copyright (C) 2005 by Dobrica Pavlinusic  Copyright (C) 2005 by Dobrica Pavlinusic
Legend:
Removed from v.21  
changed lines
  Added in v.38
  ViewVC Help
Powered by ViewVC 1.1.26