/[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 87 - (hide annotations)
Thu Sep 21 10:49:00 2006 UTC (17 years, 5 months ago) by dpavlin
File size: 29172 byte(s)
missing Subject: doesn't prevent adding message to queue

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

  ViewVC Help
Powered by ViewVC 1.1.26