/[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

Annotation of /trunk/Nos.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 93 - (hide annotations)
Tue Dec 19 15:04:05 2006 UTC (17 years, 2 months ago) by dpavlin
File size: 30200 byte(s)
added verbose to send_queued_messages so that SOAP call (SendTest, used for tests) doesn't
produce any output (and thus confuse SOAP CGI server)
1 dpavlin 20 package Nos;
2    
3     use 5.008;
4     use strict;
5     use warnings;
6    
7     require Exporter;
8    
9     our @ISA = qw(Exporter);
10    
11     our %EXPORT_TAGS = ( 'all' => [ qw(
12     ) ] );
13    
14     our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
15    
16     our @EXPORT = qw(
17     );
18    
19 dpavlin 93 our $VERSION = '0.9';
20 dpavlin 20
21     use Class::DBI::Loader;
22     use Email::Valid;
23     use Email::Send;
24     use Carp;
25 dpavlin 29 use Email::Auth::AddressHash;
26     use Email::Simple;
27 dpavlin 36 use Email::Address;
28 dpavlin 37 use Mail::DeliveryStatus::BounceParser;
29 dpavlin 59 use Class::DBI::AbstractSearch;
30 dpavlin 77 use SQL::Abstract;
31 dpavlin 66 use Mail::Alias;
32     use Cwd qw(abs_path);
33 dpavlin 20
34 dpavlin 47
35 dpavlin 20 =head1 NAME
36    
37     Nos - Notice Sender core module
38    
39     =head1 SYNOPSIS
40    
41     use Nos;
42     my $nos = new Nos();
43    
44     =head1 DESCRIPTION
45    
46 dpavlin 60 Notice sender is mail handler. It is not MTA, since it doesn't know how to
47     receive e-mails or send them directly to other hosts. It is not mail list
48     manager because it requires programming to add list members and send
49     messages. You can think of it as mechanisam for off-loading your e-mail
50     sending to remote server using SOAP service.
51 dpavlin 20
52 dpavlin 60 It's concept is based around B<lists>. Each list can have zero or more
53     B<members>. Each list can have zero or more B<messages>.
54    
55     Here comes a twist: each outgoing message will have unique e-mail generated,
56     so Notice Sender will be able to link received replies (or bounces) with
57     outgoing messages.
58    
59     It doesn't do much more than that. It B<can't> create MIME encoded e-mail,
60     send attachments, handle 8-bit characters in headers (which have to be
61     encoded) or anything else.
62    
63     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
65     reasonable rate (so that it doesn't flood your e-mail infrastructure) and
66 dpavlin 74 keep track replies.
67 dpavlin 60
68 dpavlin 74 It is best used to send small number of messages to more-or-less fixed
69 dpavlin 60 list of recipients while allowing individual responses to be examined.
70     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
72     which can be used to track some unique identifier from remote system for
73     particular user.
74    
75     It comes with command-line utility C<sender.pl> which can be used to perform
76 dpavlin 74 all available operation from scripts (see C<sender.pl --man>).
77 dpavlin 60 This command is also useful for debugging while writing client SOAP
78     application.
79    
80 dpavlin 20 =head1 METHODS
81    
82     =head2 new
83    
84     Create new instance specifing database, user, password and options.
85    
86     my $nos = new Nos(
87     dsn => 'dbi:Pg:dbname=notices',
88     user => 'dpavlin',
89     passwd => '',
90     debug => 1,
91     verbose => 1,
92 dpavlin 36 hash_len => 8,
93 dpavlin 89 full_hostname_in_aliases => 0,
94 dpavlin 20 );
95    
96 dpavlin 38 Parametar C<hash_len> defines length of hash which will be added to each
97     outgoing e-mail message to ensure that replies can be linked with sent e-mails.
98 dpavlin 36
99 dpavlin 89 C<full_hostname_in_aliases> will turn on old behaviour (not supported by Postfix
100     postalias) to include full hostname in aliases file.
101    
102    
103 dpavlin 20 =cut
104    
105     sub new {
106 dpavlin 89 my $class = shift;
107     my $self = {@_};
108 dpavlin 20 bless($self, $class);
109    
110 dpavlin 22 croak "need at least dsn" unless ($self->{'dsn'});
111    
112 dpavlin 20 $self->{'loader'} = Class::DBI::Loader->new(
113     debug => $self->{'debug'},
114     dsn => $self->{'dsn'},
115     user => $self->{'user'},
116     password => $self->{'passwd'},
117     namespace => "Nos",
118 dpavlin 59 additional_classes => qw/Class::DBI::AbstractSearch/,
119 dpavlin 20 # additional_base_classes => qw/My::Stuff/,
120     relationships => 1,
121 dpavlin 22 ) || croak "can't init Class::DBI::Loader";
122 dpavlin 20
123 dpavlin 36 $self->{'hash_len'} ||= 8;
124    
125 dpavlin 20 $self ? return $self : return undef;
126     }
127    
128 dpavlin 30
129 dpavlin 72 =head2 create_list
130 dpavlin 33
131 dpavlin 67 Create new list. Required arguments are name of C<list>, C<email> address
132     and path to C<aliases> file.
133 dpavlin 33
134 dpavlin 72 $nos->create_list(
135 dpavlin 38 list => 'My list',
136 dpavlin 47 from => 'Outgoing from comment',
137 dpavlin 33 email => 'my-list@example.com',
138 dpavlin 67 aliases => '/etc/mail/mylist',
139     archive => '/path/to/mbox/archive',
140 dpavlin 33 );
141    
142     Returns ID of newly created list.
143    
144 dpavlin 60 Calls internally C<_add_list>, see details there.
145 dpavlin 38
146 dpavlin 33 =cut
147    
148 dpavlin 72 sub create_list {
149 dpavlin 33 my $self = shift;
150    
151     my $arg = {@_};
152    
153     confess "need list name" unless ($arg->{'list'});
154 dpavlin 52 confess "need list email" unless ($arg->{'email'});
155 dpavlin 33
156 dpavlin 52 $arg->{'list'} = lc($arg->{'list'});
157     $arg->{'email'} = lc($arg->{'email'});
158    
159 dpavlin 33 my $l = $self->_get_list($arg->{'list'}) ||
160     $self->_add_list( @_ ) ||
161     return undef;
162    
163     return $l->id;
164     }
165    
166    
167 dpavlin 72 =head2 drop_list
168 dpavlin 63
169     Delete list from database.
170    
171 dpavlin 72 my $ok = drop_list(
172 dpavlin 63 list => 'My list'
173 dpavlin 70 aliases => '/etc/mail/mylist',
174 dpavlin 63 );
175    
176     Returns false if list doesn't exist.
177    
178     =cut
179    
180 dpavlin 72 sub drop_list {
181 dpavlin 63 my $self = shift;
182    
183     my $args = {@_};
184    
185     croak "need list to delete" unless ($args->{'list'});
186    
187     $args->{'list'} = lc($args->{'list'});
188    
189 dpavlin 70 my $aliases = $args->{'aliases'} || croak "need path to aliases file";
190    
191 dpavlin 63 my $lists = $self->{'loader'}->find_class('lists');
192    
193     my $this_list = $lists->search( name => $args->{'list'} )->first || return;
194    
195 dpavlin 70 $self->_remove_alias( email => $this_list->email, aliases => $aliases);
196    
197 dpavlin 63 $this_list->delete || croak "can't delete list\n";
198    
199     return $lists->dbi_commit || croak "can't commit";
200     }
201    
202    
203 dpavlin 23 =head2 add_member_to_list
204    
205     Add new member to list
206    
207     $nos->add_member_to_list(
208     list => "My list",
209     email => "john.doe@example.com",
210     name => "John A. Doe",
211 dpavlin 56 ext_id => 42,
212 dpavlin 23 );
213    
214 dpavlin 56 C<name> and C<ext_id> parametars are optional.
215 dpavlin 23
216 dpavlin 27 Return member ID if user is added.
217 dpavlin 23
218     =cut
219    
220     sub add_member_to_list {
221     my $self = shift;
222    
223     my $arg = {@_};
224    
225 dpavlin 52 my $email = lc($arg->{'email'}) || croak "can't add user without e-mail";
226 dpavlin 23 my $name = $arg->{'name'} || '';
227 dpavlin 52 my $list_name = lc($arg->{'list'}) || croak "need list name";
228 dpavlin 56 my $ext_id = $arg->{'ext_id'};
229 dpavlin 23
230 dpavlin 30 my $list = $self->_get_list($list_name) || croak "list $list_name doesn't exist";
231    
232 dpavlin 23 if (! Email::Valid->address($email)) {
233 dpavlin 33 carp "SKIPPING $name <$email>\n";
234 dpavlin 23 return 0;
235     }
236    
237 dpavlin 29 carp "# $name <$email>\n" if ($self->{'verbose'});
238 dpavlin 23
239     my $users = $self->{'loader'}->find_class('users');
240     my $user_list = $self->{'loader'}->find_class('user_list');
241    
242     my $this_user = $users->find_or_create({
243     email => $email,
244     }) || croak "can't find or create member\n";
245    
246 dpavlin 45 if ($name && $this_user->name ne $name) {
247     $this_user->name($name || '');
248 dpavlin 33 $this_user->update;
249     }
250    
251 dpavlin 56 if (defined($ext_id) && ($this_user->ext_id || '') ne $ext_id) {
252     $this_user->ext_id($ext_id);
253     $this_user->update;
254     }
255    
256 dpavlin 23 my $user_on_list = $user_list->find_or_create({
257     user_id => $this_user->id,
258     list_id => $list->id,
259     }) || croak "can't add user to list";
260    
261     $list->dbi_commit;
262     $this_user->dbi_commit;
263     $user_on_list->dbi_commit;
264    
265 dpavlin 27 return $this_user->id;
266 dpavlin 23 }
267    
268 dpavlin 43 =head2 list_members
269    
270 dpavlin 45 List all members of some list.
271    
272 dpavlin 43 my @members = list_members(
273     list => 'My list',
274     );
275    
276 dpavlin 74 Returns array of hashes with user information like this:
277 dpavlin 43
278     $member = {
279 dpavlin 45 name => 'Dobrica Pavlinusic',
280 dpavlin 43 email => 'dpavlin@rot13.org
281     }
282    
283 dpavlin 56 If list is not found, returns false. If there is C<ext_id> in user data,
284 dpavlin 60 it will also be returned.
285 dpavlin 45
286 dpavlin 43 =cut
287    
288     sub list_members {
289     my $self = shift;
290    
291     my $args = {@_};
292    
293 dpavlin 52 my $list_name = lc($args->{'list'}) || confess "need list name";
294 dpavlin 43
295     my $lists = $self->{'loader'}->find_class('lists');
296     my $user_list = $self->{'loader'}->find_class('user_list');
297    
298 dpavlin 45 my $this_list = $lists->search( name => $list_name )->first || return;
299 dpavlin 43
300     my @results;
301    
302     foreach my $user_on_list ($user_list->search(list_id => $this_list->id)) {
303     my $row = {
304 dpavlin 45 name => $user_on_list->user_id->name,
305 dpavlin 43 email => $user_on_list->user_id->email,
306     };
307    
308 dpavlin 56 my $ext_id = $user_on_list->user_id->ext_id;
309     $row->{'ext_id'} = $ext_id if (defined($ext_id));
310    
311 dpavlin 43 push @results, $row;
312     }
313    
314     return @results;
315    
316     }
317    
318    
319 dpavlin 45 =head2 delete_member
320    
321     Delete member from database.
322    
323     my $ok = delete_member(
324     name => 'Dobrica Pavlinusic'
325     );
326    
327     my $ok = delete_member(
328     email => 'dpavlin@rot13.org'
329     );
330    
331     Returns false if user doesn't exist.
332    
333 dpavlin 60 This function will delete member from all lists (by cascading delete), so it
334     shouldn't be used lightly.
335    
336 dpavlin 45 =cut
337    
338     sub delete_member {
339     my $self = shift;
340    
341     my $args = {@_};
342    
343     croak "need name or email of user to delete" unless ($args->{'name'} || $args->{'email'});
344    
345 dpavlin 52 $args->{'email'} = lc($args->{'email'}) if ($args->{'email'});
346    
347 dpavlin 45 my $key = 'name';
348     $key = 'email' if ($args->{'email'});
349    
350     my $users = $self->{'loader'}->find_class('users');
351    
352     my $this_user = $users->search( $key => $args->{$key} )->first || return;
353    
354     $this_user->delete || croak "can't delete user\n";
355    
356     return $users->dbi_commit || croak "can't commit";
357     }
358    
359 dpavlin 59 =head2 delete_member_from_list
360    
361     Delete member from particular list.
362    
363     my $ok = delete_member_from_list(
364     list => 'My list',
365     email => 'dpavlin@rot13.org',
366     );
367    
368     Returns false if user doesn't exist on that particular list.
369    
370     It will die if list or user doesn't exist. You have been warned (you might
371     want to eval this functon to prevent it from croaking).
372    
373     =cut
374    
375     sub delete_member_from_list {
376     my $self = shift;
377    
378     my $args = {@_};
379    
380     croak "need list name and email of user to delete" unless ($args->{'list'} && $args->{'email'});
381    
382     $args->{'list'} = lc($args->{'list'});
383     $args->{'email'} = lc($args->{'email'});
384    
385     my $user = $self->{'loader'}->find_class('users');
386     my $list = $self->{'loader'}->find_class('lists');
387     my $user_list = $self->{'loader'}->find_class('user_list');
388    
389     my $this_user = $user->search( email => $args->{'email'} )->first || croak "can't find user: ".$args->{'email'};
390     my $this_list = $list->search( name => $args->{'list'} )->first || croak "can't find list: ".$args->{'list'};
391    
392 dpavlin 62 my $this_user_list = $user_list->search_where( list_id => $this_list->id, user_id => $this_user->id )->first || return;
393 dpavlin 59
394     $this_user_list->delete || croak "can't delete user from list\n";
395    
396     return $user_list->dbi_commit || croak "can't commit";
397     }
398    
399 dpavlin 29 =head2 add_message_to_list
400 dpavlin 24
401     Adds message to one list's queue for later sending.
402    
403 dpavlin 29 $nos->add_message_to_list(
404 dpavlin 24 list => 'My list',
405 dpavlin 36 message => 'Subject: welcome to list
406 dpavlin 38
407 dpavlin 24 This is example message
408     ',
409     );
410    
411     On success returns ID of newly created (or existing) message.
412    
413 dpavlin 36 Only required header in e-mail is C<Subject:>. C<From:> and C<To:> headers
414     will be automatically generated, but if you want to use own headers, just
415     include them in messages.
416    
417 dpavlin 24 =cut
418    
419 dpavlin 29 sub add_message_to_list {
420 dpavlin 24 my $self = shift;
421    
422     my $args = {@_};
423    
424 dpavlin 52 my $list_name = lc($args->{'list'}) || confess "need list name";
425 dpavlin 24 my $message_text = $args->{'message'} || croak "need message";
426    
427 dpavlin 29 my $m = Email::Simple->new($message_text) || croak "can't parse message";
428    
429 dpavlin 87 warn "message doesn't have Subject header\n" unless( $m->header('Subject') );
430 dpavlin 29
431 dpavlin 24 my $lists = $self->{'loader'}->find_class('lists');
432    
433     my $this_list = $lists->search(
434     name => $list_name,
435     )->first || croak "can't find list $list_name";
436    
437     my $messages = $self->{'loader'}->find_class('messages');
438    
439     my $this_message = $messages->find_or_create({
440     message => $message_text
441     }) || croak "can't insert message";
442    
443     $this_message->dbi_commit() || croak "can't add message";
444    
445     my $queue = $self->{'loader'}->find_class('queue');
446    
447     $queue->find_or_create({
448     message_id => $this_message->id,
449     list_id => $this_list->id,
450     }) || croak "can't add message ",$this_message->id," to list ",$this_list->id, ": ",$this_list->name;
451    
452     $queue->dbi_commit || croak "can't add message to list ",$this_list->name;
453    
454     return $this_message->id;
455     }
456    
457    
458 dpavlin 22 =head2 send_queued_messages
459 dpavlin 20
460 dpavlin 22 Send queued messages or just ones for selected list
461 dpavlin 20
462 dpavlin 49 $nos->send_queued_messages(
463     list => 'My list',
464     driver => 'smtp',
465     sleep => 3,
466 dpavlin 93 verbose => 1,
467 dpavlin 49 );
468 dpavlin 20
469 dpavlin 47 Second option is driver which will be used for e-mail delivery. If not
470     specified, C<IO> driver will be used which will dump e-mail to C<STDERR>.
471    
472     Other valid drivers are:
473    
474     =over 10
475    
476     =item smtp
477    
478     Send e-mail using SMTP server at 127.0.0.1
479    
480 dpavlin 93 =item verbose
481    
482     Display diagnostic output to C<STDOUT> and C<STDERR>.
483    
484 dpavlin 47 =back
485    
486 dpavlin 75 Any other driver name will try to use C<Email::Send::that_driver> module.
487    
488 dpavlin 49 Default sleep wait between two messages is 3 seconds.
489    
490 dpavlin 75 This method will return number of succesfully sent messages.
491    
492 dpavlin 21 =cut
493 dpavlin 20
494 dpavlin 22 sub send_queued_messages {
495 dpavlin 21 my $self = shift;
496 dpavlin 20
497 dpavlin 49 my $arg = {@_};
498 dpavlin 20
499 dpavlin 52 my $list_name = lc($arg->{'list'}) || '';
500 dpavlin 49 my $driver = $arg->{'driver'} || '';
501     my $sleep = $arg->{'sleep'};
502 dpavlin 93 my $verbose = $arg->{verbose};
503 dpavlin 49 $sleep ||= 3 unless defined($sleep);
504 dpavlin 47
505 dpavlin 75 # number of messages sent o.k.
506     my $ok = 0;
507    
508 dpavlin 49 my $email_send_driver = 'Email::Send::IO';
509     my @email_send_options;
510    
511 dpavlin 47 if (lc($driver) eq 'smtp') {
512     $email_send_driver = 'Email::Send::SMTP';
513     @email_send_options = ['127.0.0.1'];
514 dpavlin 75 } elsif ($driver && $driver ne '') {
515     $email_send_driver = 'Email::Send::' . $driver;
516 dpavlin 52 } else {
517 dpavlin 93 warn "dumping all messages to STDERR\n" if ($verbose);
518 dpavlin 47 }
519    
520 dpavlin 22 my $lists = $self->{'loader'}->find_class('lists');
521     my $queue = $self->{'loader'}->find_class('queue');
522     my $user_list = $self->{'loader'}->find_class('user_list');
523     my $sent = $self->{'loader'}->find_class('sent');
524 dpavlin 20
525 dpavlin 22 my $my_q;
526     if ($list_name ne '') {
527     my $l_id = $lists->search_like( name => $list_name )->first ||
528     croak "can't find list $list_name";
529     $my_q = $queue->search_like( list_id => $l_id ) ||
530     croak "can't find list $list_name";
531     } else {
532     $my_q = $queue->retrieve_all;
533     }
534 dpavlin 20
535 dpavlin 22 while (my $m = $my_q->next) {
536     next if ($m->all_sent);
537 dpavlin 20
538 dpavlin 93 print "sending message ",$m->message_id," enqueued on ",$m->date," to list ",$m->list_id->name,"\n" if ($verbose);
539 dpavlin 22 my $msg = $m->message_id->message;
540 dpavlin 20
541 dpavlin 22 foreach my $u ($user_list->search(list_id => $m->list_id)) {
542 dpavlin 20
543 dpavlin 29 my $to_email = $u->user_id->email;
544    
545 dpavlin 32 my ($from,$domain) = split(/@/, $u->list_id->email, 2);
546    
547 dpavlin 22 if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {
548 dpavlin 93 print "SKIP $to_email message allready sent\n" if ($verbose);
549 dpavlin 22 } else {
550 dpavlin 93 print "=> $to_email " if ($verbose);
551 dpavlin 20
552 dpavlin 32 my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;
553 dpavlin 36 my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
554 dpavlin 32
555 dpavlin 29 my $hash = $auth->generate_hash( $to_email );
556 dpavlin 20
557 dpavlin 47 my $from_addr;
558 dpavlin 49 my $from_email_only = $from . "+" . $hash . ( $domain ? '@' . $domain : '');
559 dpavlin 48
560 dpavlin 47 $from_addr .= '"' . $u->list_id->from_addr . '" ' if ($u->list_id->from_addr);
561     $from_addr .= '<' . $from_email_only . '>';
562     my $to = '"' . $u->user_id->name . '" <' . $to_email . '>';
563 dpavlin 29
564 dpavlin 32 my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
565 dpavlin 29
566 dpavlin 49 $m_obj->header_set('Return-Path', $from_email_only) || croak "can't set Return-Path: header";
567 dpavlin 86 #$m_obj->header_set('Sender', $from_email_only) || croak "can't set Sender: header";
568 dpavlin 49 $m_obj->header_set('Errors-To', $from_email_only) || croak "can't set Errors-To: header";
569 dpavlin 47 $m_obj->header_set('From', $from_addr) || croak "can't set From: header";
570 dpavlin 32 $m_obj->header_set('To', $to) || croak "can't set To: header";
571 dpavlin 29
572 dpavlin 38 $m_obj->header_set('X-Nos-Version', $VERSION);
573     $m_obj->header_set('X-Nos-Hash', $hash);
574    
575 dpavlin 47 # really send e-mail
576 dpavlin 65 my $sent_status;
577    
578 dpavlin 47 if (@email_send_options) {
579 dpavlin 65 $sent_status = send $email_send_driver => $m_obj->as_string, @email_send_options;
580 dpavlin 47 } else {
581 dpavlin 65 $sent_status = send $email_send_driver => $m_obj->as_string;
582 dpavlin 47 }
583 dpavlin 22
584 dpavlin 65 croak "can't send e-mail: $sent_status\n\nOriginal e-mail follows:\n".$m_obj->as_string unless ($sent_status);
585 dpavlin 75 my @bad;
586     @bad = @{ $sent_status->prop('bad') } if (eval { $sent_status->can('prop') });
587 dpavlin 65 croak "failed sending to ",join(",",@bad) if (@bad);
588 dpavlin 49
589 dpavlin 65 if ($sent_status) {
590    
591     $sent->create({
592     message_id => $m->message_id,
593     user_id => $u->user_id,
594     hash => $hash,
595     });
596     $sent->dbi_commit;
597    
598 dpavlin 93 print " - $sent_status\n" if ($verbose);
599 dpavlin 65
600 dpavlin 75 $ok++;
601 dpavlin 65 } else {
602 dpavlin 93 warn "ERROR: $sent_status\n" if ($verbose);
603 dpavlin 65 }
604    
605 dpavlin 49 if ($sleep) {
606 dpavlin 93 warn "sleeping $sleep seconds\n" if ($verbose);
607 dpavlin 49 sleep($sleep);
608     }
609 dpavlin 22 }
610     }
611     $m->all_sent(1);
612     $m->update;
613     $m->dbi_commit;
614     }
615    
616 dpavlin 75 return $ok;
617    
618 dpavlin 20 }
619    
620 dpavlin 29 =head2 inbox_message
621    
622     Receive single message for list's inbox.
623    
624 dpavlin 36 my $ok = $nos->inbox_message(
625     list => 'My list',
626     message => $message,
627     );
628 dpavlin 29
629 dpavlin 60 This method is used by C<sender.pl> when receiving e-mail messages.
630    
631 dpavlin 29 =cut
632    
633     sub inbox_message {
634     my $self = shift;
635    
636 dpavlin 36 my $arg = {@_};
637 dpavlin 29
638 dpavlin 36 return unless ($arg->{'message'});
639     croak "need list name" unless ($arg->{'list'});
640 dpavlin 29
641 dpavlin 52 $arg->{'list'} = lc($arg->{'list'});
642    
643 dpavlin 37 my $this_list = $self->_get_list($arg->{'list'}) || croak "can't find list ".$arg->{'list'}."\n";
644    
645 dpavlin 36 my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message";
646    
647     my $to = $m->header('To') || die "can't find To: address in incomming message\n";
648    
649 dpavlin 48 my $return_path = $m->header('Return-Path') || '';
650    
651 dpavlin 36 my @addrs = Email::Address->parse( $to );
652    
653     die "can't parse To: $to address\n" unless (@addrs);
654    
655     my $hl = $self->{'hash_len'} || confess "no hash_len?";
656    
657     my $hash;
658    
659     foreach my $a (@addrs) {
660 dpavlin 52 if ($a->address =~ m/\+([a-f0-9]{$hl})@/i) {
661 dpavlin 36 $hash = $1;
662     last;
663     }
664     }
665    
666 dpavlin 50 #warn "can't find hash in e-mail $to\n" unless ($hash);
667 dpavlin 36
668     my $sent = $self->{'loader'}->find_class('sent');
669    
670     # will use null if no matching message_id is found
671 dpavlin 50 my $sent_msg;
672     $sent_msg = $sent->search( hash => $hash )->first if ($hash);
673 dpavlin 36
674 dpavlin 37 my ($message_id, $user_id) = (undef, undef); # init with NULL
675 dpavlin 36
676 dpavlin 37 if ($sent_msg) {
677     $message_id = $sent_msg->message_id || carp "no message_id";
678     $user_id = $sent_msg->user_id || carp "no user_id";
679 dpavlin 47 } else {
680 dpavlin 50 #warn "can't find sender with hash $hash\n";
681     my $users = $self->{'loader'}->find_class('users');
682     my $from = $m->header('From');
683     $from = $1 if ($from =~ m/<(.*)>/);
684 dpavlin 52 my $this_user = $users->search( email => lc($from) )->first;
685 dpavlin 50 $user_id = $this_user->id if ($this_user);
686 dpavlin 37 }
687    
688    
689     my $is_bounce = 0;
690    
691 dpavlin 49 if ($return_path eq '<>' || $return_path eq '') {
692 dpavlin 47 no warnings;
693     my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
694     $arg->{'message'}, { report_non_bounces=>1 },
695     ) };
696 dpavlin 50 #warn "can't check if this message is bounce!" if ($@);
697 dpavlin 47
698     $is_bounce++ if ($bounce && $bounce->is_bounce);
699     }
700 dpavlin 37
701     my $received = $self->{'loader'}->find_class('received');
702    
703     my $this_received = $received->find_or_create({
704     user_id => $user_id,
705     list_id => $this_list->id,
706     message_id => $message_id,
707     message => $arg->{'message'},
708     bounced => $is_bounce,
709     }) || croak "can't insert received message";
710    
711     $this_received->dbi_commit;
712    
713 dpavlin 49 # print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
714 dpavlin 29 }
715    
716 dpavlin 75 =head2 received_messages
717 dpavlin 29
718 dpavlin 75 Returns all received messages for given list or user.
719    
720 dpavlin 80 my @received = $nos->received_messages(
721 dpavlin 75 list => 'My list',
722     email => "john.doe@example.com",
723 dpavlin 80 from_date => '2005-01-01 10:15:00',
724     to_date => '2005-01-01 12:00:00',
725     message => 0,
726 dpavlin 75 );
727    
728 dpavlin 80 If don't specify C<list> or C<email> it will return all received messages.
729     Results will be sorted by received date, oldest first.
730    
731     Other optional parametars include:
732    
733     =over 10
734    
735     =item from_date
736    
737     Date (in ISO format) for lower limit of dates received
738    
739     =item to_date
740    
741     Return just messages older than this date
742    
743     =item message
744    
745     Include whole received message in result. This will probably make result
746     array very large. Use with care.
747    
748     =back
749    
750 dpavlin 81 Date ranges are inclusive, so results will include messages sent on
751     particular date specified with C<date_from> or C<date_to>.
752    
753 dpavlin 76 Each element in returned array will have following structure:
754 dpavlin 75
755 dpavlin 80 my $row = {
756 dpavlin 76 id => 42, # unique ID of received message
757 dpavlin 78 list => 'My list', # useful if filtering by email
758     ext_id => 9999, # ext_id from message sender
759     email => 'jdoe@example.com', # e-mail of message sender
760     bounced => 0, # true if message is bounce
761     date => '2005-08-24 18:57:24', # date of receival in ISO format
762 dpavlin 76 }
763    
764 dpavlin 80 If you specified C<message> option, this hash will also have C<message> key
765     which will contain whole received message.
766 dpavlin 76
767 dpavlin 75 =cut
768    
769     sub received_messages {
770     my $self = shift;
771    
772 dpavlin 77 my $arg = {@_} if (@_);
773 dpavlin 75
774 dpavlin 77 # croak "need list name or email" unless ($arg->{'list'} || $arg->{'email'});
775 dpavlin 75
776 dpavlin 77 my $sql = qq{
777     select
778     received.id as id,
779     lists.name as list,
780     users.ext_id as ext_id,
781     users.email as email,
782 dpavlin 80 };
783     $sql .= qq{ message,} if ($arg->{'message'});
784     $sql .= qq{
785 dpavlin 77 bounced,received.date as date
786     from received
787     join lists on lists.id = list_id
788     join users on users.id = user_id
789     };
790 dpavlin 75
791 dpavlin 81 my $order = qq{ order by date asc };
792 dpavlin 80
793 dpavlin 77 my $where;
794 dpavlin 75
795 dpavlin 77 $where->{'lists.name'} = lc($arg->{'list'}) if ($arg->{'list'});
796     $where->{'users.email'} = lc($arg->{'email'}) if ($arg->{'email'});
797 dpavlin 80 $where->{'received.date'} = { '>=', $arg->{'date_from'} } if ($arg->{'date_from'});
798     $where->{'received.date'} = { '<=', $arg->{'date_to'} } if ($arg->{'date_to'});
799 dpavlin 77
800     # hum, yammy one-liner
801     my($stmt, @bind) = SQL::Abstract->new->where($where);
802    
803     my $dbh = $self->{'loader'}->find_class('received')->db_Main;
804    
805 dpavlin 80 my $sth = $dbh->prepare($sql . $stmt . $order);
806 dpavlin 77 $sth->execute(@bind);
807 dpavlin 76 return $sth->fetchall_hash;
808 dpavlin 75 }
809    
810    
811 dpavlin 30 =head1 INTERNAL METHODS
812    
813     Beware of dragons! You shouldn't need to call those methods directly.
814    
815 dpavlin 66
816     =head2 _add_aliases
817    
818 dpavlin 71 Add or update alias in C</etc/aliases> (or equivalent) file for selected list
819 dpavlin 66
820     my $ok = $nos->add_aliases(
821     list => 'My list',
822     email => 'my-list@example.com',
823     aliases => '/etc/mail/mylist',
824     archive => '/path/to/mbox/archive',
825    
826     );
827    
828     C<archive> parametar is optional.
829    
830     Return false on failure.
831    
832     =cut
833    
834     sub _add_aliases {
835     my $self = shift;
836    
837     my $arg = {@_};
838    
839 dpavlin 68 foreach my $o (qw/list email aliases/) {
840     croak "need $o option" unless ($arg->{$o});
841     }
842 dpavlin 66
843 dpavlin 68 my $aliases = $arg->{'aliases'};
844     my $email = $arg->{'email'};
845     my $list = $arg->{'list'};
846 dpavlin 66
847     unless (-e $aliases) {
848     warn "aliases file $aliases doesn't exist, creating empty\n";
849     open(my $fh, '>', $aliases) || croak "can't create $aliases: $!";
850     close($fh);
851 dpavlin 67 chmod 0777, $aliases || warn "can't change permission to 0777";
852 dpavlin 66 }
853    
854 dpavlin 71 die "FATAL: aliases file $aliases is not writable\n" unless (-w $aliases);
855    
856 dpavlin 66 my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
857    
858     my $target = '';
859    
860     if (my $archive = $arg->{'archive'}) {
861     $target .= "$archive, ";
862    
863     if (! -e $archive) {
864     warn "please make sure that file $archive is writable for your e-mail user (defaulting to bad 777 permission for now)";
865    
866     open(my $fh, '>', $archive) || croak "can't create archive file $archive: $!";
867     close($fh);
868     chmod 0777, $archive || croak "can't chmod archive file $archive to 0777: $!";
869     }
870     }
871    
872     # resolve my path to absolute one
873     my $self_path = abs_path($0);
874     $self_path =~ s#/[^/]+$##;
875     $self_path =~ s#/t/*$#/#;
876    
877 dpavlin 82 $target .= qq#"| cd $self_path && ./sender.pl --inbox='$list'"#;
878 dpavlin 66
879 dpavlin 82 # remove hostname from email to make Postfix's postalias happy
880 dpavlin 89 $email =~ s/@.+// if (not $self->{full_hostname_in_aliases});
881 dpavlin 82
882 dpavlin 68 if ($a->exists($email)) {
883     $a->update($email, $target) or croak "can't update alias ".$a->error_check;
884     } else {
885     $a->append($email, $target) or croak "can't add alias ".$a->error_check;
886 dpavlin 66 }
887    
888 dpavlin 89 # $a->write($aliases) or croak "can't save aliases $aliases ".$a->error_check;
889 dpavlin 70
890 dpavlin 66 return 1;
891     }
892    
893 dpavlin 30 =head2 _add_list
894    
895     Create new list
896    
897     my $list_obj = $nos->_add_list(
898     list => 'My list',
899 dpavlin 47 from => 'Outgoing from comment',
900 dpavlin 30 email => 'my-list@example.com',
901 dpavlin 66 aliases => '/etc/mail/mylist',
902 dpavlin 30 );
903    
904     Returns C<Class::DBI> object for created list.
905    
906 dpavlin 38 C<email> address can be with domain or without it if your
907     MTA appends it. There is no checking for validity of your
908     list e-mail. Flexibility comes with resposibility, so please
909     feed correct (and configured) return addresses.
910    
911 dpavlin 30 =cut
912    
913     sub _add_list {
914     my $self = shift;
915    
916     my $arg = {@_};
917    
918 dpavlin 52 my $name = lc($arg->{'list'}) || confess "can't add list without name";
919     my $email = lc($arg->{'email'}) || confess "can't add list without e-mail";
920 dpavlin 66 my $aliases = lc($arg->{'aliases'}) || confess "can't add list without path to aliases file";
921    
922 dpavlin 47 my $from_addr = $arg->{'from'};
923 dpavlin 30
924     my $lists = $self->{'loader'}->find_class('lists');
925    
926 dpavlin 66 $self->_add_aliases(
927     list => $name,
928     email => $email,
929     aliases => $aliases,
930 dpavlin 68 ) || warn "can't add alias $email for list $name";
931 dpavlin 66
932 dpavlin 30 my $l = $lists->find_or_create({
933     name => $name,
934     email => $email,
935     });
936 dpavlin 47
937 dpavlin 30 croak "can't add list $name\n" unless ($l);
938    
939 dpavlin 47 if ($from_addr && $l->from_addr ne $from_addr) {
940     $l->from_addr($from_addr);
941     $l->update;
942     }
943    
944 dpavlin 30 $l->dbi_commit;
945    
946     return $l;
947    
948     }
949    
950    
951 dpavlin 66
952 dpavlin 30 =head2 _get_list
953    
954     Get list C<Class::DBI> object.
955    
956     my $list_obj = $nos->check_list('My list');
957    
958     Returns false on failure.
959    
960     =cut
961    
962     sub _get_list {
963     my $self = shift;
964    
965     my $name = shift || return;
966    
967 dpavlin 31 my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";
968 dpavlin 30
969 dpavlin 52 return $lists->search({ name => lc($name) })->first;
970 dpavlin 30 }
971    
972 dpavlin 70
973     =head2 _remove_alias
974    
975     Remove list alias
976    
977     my $ok = $nos->_remove_alias(
978     email => 'mylist@example.com',
979     aliases => '/etc/mail/mylist',
980     );
981    
982     Returns true if list is removed or false if list doesn't exist. Dies in case of error.
983    
984     =cut
985    
986     sub _remove_alias {
987     my $self = shift;
988    
989     my $arg = {@_};
990    
991     my $email = lc($arg->{'email'}) || confess "can't remove alias without email";
992     my $aliases = lc($arg->{'aliases'}) || confess "can't remove alias without list";
993    
994     my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
995    
996     if ($a->exists($email)) {
997     $a->delete($email) || croak "can't remove alias $email";
998     } else {
999     return 0;
1000     }
1001    
1002     return 1;
1003    
1004     }
1005    
1006 dpavlin 39 ###
1007     ### SOAP
1008     ###
1009 dpavlin 30
1010 dpavlin 39 package Nos::SOAP;
1011    
1012 dpavlin 43 use Carp;
1013    
1014 dpavlin 39 =head1 SOAP methods
1015    
1016     This methods are thin wrappers to provide SOAP calls. They are grouped in
1017     C<Nos::SOAP> package which is in same F<Nos.pm> module file.
1018    
1019     Usually, you want to use named variables in your SOAP calls if at all
1020     possible.
1021    
1022     However, if you have broken SOAP library (like PHP SOAP class from PEAR)
1023     you will want to use positional arguments (in same order as documented for
1024     methods below).
1025    
1026     =cut
1027    
1028     my $nos;
1029    
1030 dpavlin 66
1031     =head2 new
1032    
1033     Create new SOAP object
1034    
1035     my $soap = new Nos::SOAP(
1036     dsn => 'dbi:Pg:dbname=notices',
1037     user => 'dpavlin',
1038     passwd => '',
1039     debug => 1,
1040     verbose => 1,
1041     hash_len => 8,
1042     aliases => '/etc/aliases',
1043     );
1044    
1045 dpavlin 75 If you are writing SOAP server (like C<soap.cgi> example), you will need to
1046     call this method once to make new instance of Nos::SOAP and specify C<dsn>
1047     and options for it.
1048    
1049 dpavlin 66 =cut
1050    
1051 dpavlin 39 sub new {
1052 dpavlin 90 my $class = shift;
1053     my $self = {@_};
1054 dpavlin 66
1055     croak "need aliases parametar" unless ($self->{'aliases'});
1056    
1057 dpavlin 39 bless($self, $class);
1058    
1059     $nos = new Nos( @_ ) || die "can't create Nos object";
1060    
1061     $self ? return $self : return undef;
1062     }
1063    
1064    
1065 dpavlin 72 =head2 CreateList
1066 dpavlin 39
1067 dpavlin 72 $message_id = CreateList(
1068 dpavlin 39 list => 'My list',
1069 dpavlin 56 from => 'Name of my list',
1070 dpavlin 39 email => 'my-list@example.com'
1071     );
1072    
1073     =cut
1074    
1075 dpavlin 72 sub CreateList {
1076 dpavlin 39 my $self = shift;
1077    
1078 dpavlin 68 my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
1079 dpavlin 66
1080 dpavlin 39 if ($_[0] !~ m/^HASH/) {
1081 dpavlin 72 return $nos->create_list(
1082 dpavlin 56 list => $_[0], from => $_[1], email => $_[2],
1083 dpavlin 66 aliases => $aliases,
1084 dpavlin 39 );
1085     } else {
1086 dpavlin 72 return $nos->create_list( %{ shift @_ }, aliases => $aliases );
1087 dpavlin 39 }
1088     }
1089    
1090 dpavlin 43
1091 dpavlin 72 =head2 DropList
1092 dpavlin 63
1093 dpavlin 72 $ok = DropList(
1094 dpavlin 63 list => 'My list',
1095     );
1096    
1097     =cut
1098    
1099 dpavlin 72 sub DropList {
1100 dpavlin 63 my $self = shift;
1101    
1102 dpavlin 70 my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
1103    
1104 dpavlin 63 if ($_[0] !~ m/^HASH/) {
1105 dpavlin 72 return $nos->drop_list(
1106 dpavlin 63 list => $_[0],
1107 dpavlin 70 aliases => $aliases,
1108 dpavlin 63 );
1109     } else {
1110 dpavlin 72 return $nos->drop_list( %{ shift @_ }, aliases => $aliases );
1111 dpavlin 63 }
1112     }
1113    
1114 dpavlin 39 =head2 AddMemberToList
1115    
1116     $member_id = AddMemberToList(
1117 dpavlin 43 list => 'My list',
1118     email => 'e-mail@example.com',
1119 dpavlin 58 name => 'Full Name',
1120     ext_id => 42,
1121 dpavlin 39 );
1122    
1123     =cut
1124    
1125     sub AddMemberToList {
1126     my $self = shift;
1127    
1128     if ($_[0] !~ m/^HASH/) {
1129     return $nos->add_member_to_list(
1130 dpavlin 84 list => $_[0], email => $_[1], name => $_[2], ext_id => $_[3],
1131 dpavlin 39 );
1132     } else {
1133     return $nos->add_member_to_list( %{ shift @_ } );
1134     }
1135     }
1136    
1137 dpavlin 43
1138     =head2 ListMembers
1139    
1140     my @members = ListMembers(
1141     list => 'My list',
1142     );
1143    
1144     Returns array of hashes with user informations, see C<list_members>.
1145    
1146     =cut
1147    
1148     sub ListMembers {
1149     my $self = shift;
1150    
1151     my $list_name;
1152    
1153     if ($_[0] !~ m/^HASH/) {
1154     $list_name = shift;
1155     } else {
1156     $list_name = $_[0]->{'list'};
1157     }
1158    
1159 dpavlin 62 return [ $nos->list_members( list => $list_name ) ];
1160 dpavlin 43 }
1161    
1162 dpavlin 62
1163     =head2 DeleteMemberFromList
1164    
1165     $member_id = DeleteMemberFromList(
1166     list => 'My list',
1167     email => 'e-mail@example.com',
1168     );
1169    
1170     =cut
1171    
1172     sub DeleteMemberFromList {
1173     my $self = shift;
1174    
1175     if ($_[0] !~ m/^HASH/) {
1176     return $nos->delete_member_from_list(
1177     list => $_[0], email => $_[1],
1178     );
1179     } else {
1180     return $nos->delete_member_from_list( %{ shift @_ } );
1181     }
1182     }
1183    
1184    
1185 dpavlin 39 =head2 AddMessageToList
1186    
1187     $message_id = AddMessageToList(
1188     list => 'My list',
1189     message => 'From: My list...'
1190     );
1191    
1192     =cut
1193    
1194     sub AddMessageToList {
1195     my $self = shift;
1196    
1197     if ($_[0] !~ m/^HASH/) {
1198     return $nos->add_message_to_list(
1199     list => $_[0], message => $_[1],
1200     );
1201     } else {
1202     return $nos->add_message_to_list( %{ shift @_ } );
1203     }
1204     }
1205    
1206 dpavlin 78 =head2 MessagesReceived
1207 dpavlin 39
1208 dpavlin 78 Return statistics about received messages.
1209 dpavlin 74
1210     my @result = MessagesReceived(
1211     list => 'My list',
1212     email => 'jdoe@example.com',
1213 dpavlin 80 from_date => '2005-01-01 10:15:00',
1214     to_date => '2005-01-01 12:00:00',
1215     message => 0,
1216 dpavlin 74 );
1217    
1218 dpavlin 80 You must specify C<list> or C<email> or any combination of those two. Other
1219     parametars are optional.
1220 dpavlin 74
1221 dpavlin 76 For format of returned array element see C<received_messages>.
1222 dpavlin 74
1223 dpavlin 78 =cut
1224    
1225     sub MessagesReceived {
1226     my $self = shift;
1227    
1228     if ($_[0] !~ m/^HASH/) {
1229 dpavlin 79 die "need at least list or email" unless (scalar @_ < 2);
1230 dpavlin 85 return \@{ $nos->received_messages(
1231 dpavlin 78 list => $_[0], email => $_[1],
1232 dpavlin 80 from_date => $_[2], to_date => $_[3],
1233     message => $_[4]
1234 dpavlin 85 ) };
1235 dpavlin 78 } else {
1236 dpavlin 79 my $arg = shift;
1237     die "need list or email argument" unless ($arg->{'list'} || $arg->{'email'});
1238 dpavlin 85 return \@{ $nos->received_messages( %{ $arg } ) };
1239 dpavlin 78 }
1240     }
1241    
1242 dpavlin 93 =head2 SendTest
1243 dpavlin 78
1244 dpavlin 93 Internal function which does e-mail sending using C<Email::Send::Test> driver.
1245 dpavlin 74
1246 dpavlin 93 my $sent = SendTest( list => 'My list' );
1247 dpavlin 74
1248 dpavlin 93 Returns number of messages sent
1249 dpavlin 90
1250 dpavlin 93 =cut
1251 dpavlin 90
1252 dpavlin 93 sub SendTest {
1253     my $self = shift;
1254     my $args = shift;
1255     die "list name required" unless ($args->{list});
1256 dpavlin 90
1257 dpavlin 93 require Email::Send::Test;
1258 dpavlin 90
1259 dpavlin 93 my $nr_sent = $nos->send_queued_messages(
1260     list => $args->{list},
1261     driver => 'Test',
1262     sleep => 0,
1263     verbose => 0,
1264     );
1265 dpavlin 90
1266 dpavlin 93 my @emails = Email::Send::Test->emails;
1267    
1268     open(my $tmp, ">/tmp/soap-debug");
1269     use Data::Dump qw/dump/;
1270     print $tmp "sent $nr_sent emails\n", dump(@emails);
1271     close($tmp);
1272    
1273     return $nr_sent;
1274 dpavlin 90 }
1275    
1276 dpavlin 93 ###
1277    
1278     =head1 NOTE ON ARRAYS IN SOAP
1279    
1280     Returning arrays from SOAP calls is somewhat fuzzy (at least to me). It
1281     seems that SOAP::Lite client thinks that it has array with one element which
1282     is array of hashes with data.
1283    
1284 dpavlin 25 =head1 EXPORT
1285 dpavlin 20
1286 dpavlin 27 Nothing.
1287 dpavlin 20
1288     =head1 SEE ALSO
1289    
1290     mailman, ezmlm, sympa, L<Mail::Salsa>
1291    
1292 dpavlin 25
1293 dpavlin 20 =head1 AUTHOR
1294    
1295     Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
1296    
1297 dpavlin 25
1298 dpavlin 20 =head1 COPYRIGHT AND LICENSE
1299    
1300     Copyright (C) 2005 by Dobrica Pavlinusic
1301    
1302     This library is free software; you can redistribute it and/or modify
1303     it under the same terms as Perl itself, either Perl version 5.8.4 or,
1304     at your option, any later version of Perl 5 you may have available.
1305    
1306    
1307     =cut
1308 dpavlin 39
1309     1;

  ViewVC Help
Powered by ViewVC 1.1.26