/[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 81 - (hide annotations)
Fri Aug 26 06:13:44 2005 UTC (18 years, 6 months ago) by dpavlin
File size: 29084 byte(s)
fix ordering by date, fix tests and notice about dates beeing inclusive

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 32 unless( $m->header('Subject') ) {
425     warn "message doesn't have Subject header\n";
426     return;
427     }
428 dpavlin 29
429 dpavlin 24 my $lists = $self->{'loader'}->find_class('lists');
430    
431     my $this_list = $lists->search(
432     name => $list_name,
433     )->first || croak "can't find list $list_name";
434    
435     my $messages = $self->{'loader'}->find_class('messages');
436    
437     my $this_message = $messages->find_or_create({
438     message => $message_text
439     }) || croak "can't insert message";
440    
441     $this_message->dbi_commit() || croak "can't add message";
442    
443     my $queue = $self->{'loader'}->find_class('queue');
444    
445     $queue->find_or_create({
446     message_id => $this_message->id,
447     list_id => $this_list->id,
448     }) || croak "can't add message ",$this_message->id," to list ",$this_list->id, ": ",$this_list->name;
449    
450     $queue->dbi_commit || croak "can't add message to list ",$this_list->name;
451    
452     return $this_message->id;
453     }
454    
455    
456 dpavlin 22 =head2 send_queued_messages
457 dpavlin 20
458 dpavlin 22 Send queued messages or just ones for selected list
459 dpavlin 20
460 dpavlin 49 $nos->send_queued_messages(
461     list => 'My list',
462     driver => 'smtp',
463     sleep => 3,
464     );
465 dpavlin 20
466 dpavlin 47 Second option is driver which will be used for e-mail delivery. If not
467     specified, C<IO> driver will be used which will dump e-mail to C<STDERR>.
468    
469     Other valid drivers are:
470    
471     =over 10
472    
473     =item smtp
474    
475     Send e-mail using SMTP server at 127.0.0.1
476    
477     =back
478    
479 dpavlin 75 Any other driver name will try to use C<Email::Send::that_driver> module.
480    
481 dpavlin 49 Default sleep wait between two messages is 3 seconds.
482    
483 dpavlin 75 This method will return number of succesfully sent messages.
484    
485 dpavlin 21 =cut
486 dpavlin 20
487 dpavlin 22 sub send_queued_messages {
488 dpavlin 21 my $self = shift;
489 dpavlin 20
490 dpavlin 49 my $arg = {@_};
491 dpavlin 20
492 dpavlin 52 my $list_name = lc($arg->{'list'}) || '';
493 dpavlin 49 my $driver = $arg->{'driver'} || '';
494     my $sleep = $arg->{'sleep'};
495     $sleep ||= 3 unless defined($sleep);
496 dpavlin 47
497 dpavlin 75 # number of messages sent o.k.
498     my $ok = 0;
499    
500 dpavlin 49 my $email_send_driver = 'Email::Send::IO';
501     my @email_send_options;
502    
503 dpavlin 47 if (lc($driver) eq 'smtp') {
504     $email_send_driver = 'Email::Send::SMTP';
505     @email_send_options = ['127.0.0.1'];
506 dpavlin 75 } elsif ($driver && $driver ne '') {
507     $email_send_driver = 'Email::Send::' . $driver;
508 dpavlin 52 } else {
509     warn "dumping all messages to STDERR\n";
510 dpavlin 47 }
511    
512 dpavlin 22 my $lists = $self->{'loader'}->find_class('lists');
513     my $queue = $self->{'loader'}->find_class('queue');
514     my $user_list = $self->{'loader'}->find_class('user_list');
515     my $sent = $self->{'loader'}->find_class('sent');
516 dpavlin 20
517 dpavlin 22 my $my_q;
518     if ($list_name ne '') {
519     my $l_id = $lists->search_like( name => $list_name )->first ||
520     croak "can't find list $list_name";
521     $my_q = $queue->search_like( list_id => $l_id ) ||
522     croak "can't find list $list_name";
523     } else {
524     $my_q = $queue->retrieve_all;
525     }
526 dpavlin 20
527 dpavlin 22 while (my $m = $my_q->next) {
528     next if ($m->all_sent);
529 dpavlin 20
530 dpavlin 22 print "sending message ",$m->message_id," enqueued on ",$m->date," to list ",$m->list_id->name,"\n";
531     my $msg = $m->message_id->message;
532 dpavlin 20
533 dpavlin 22 foreach my $u ($user_list->search(list_id => $m->list_id)) {
534 dpavlin 20
535 dpavlin 29 my $to_email = $u->user_id->email;
536    
537 dpavlin 32 my ($from,$domain) = split(/@/, $u->list_id->email, 2);
538    
539 dpavlin 22 if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {
540 dpavlin 29 print "SKIP $to_email message allready sent\n";
541 dpavlin 22 } else {
542 dpavlin 65 print "=> $to_email ";
543 dpavlin 20
544 dpavlin 32 my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;
545 dpavlin 36 my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
546 dpavlin 32
547 dpavlin 29 my $hash = $auth->generate_hash( $to_email );
548 dpavlin 20
549 dpavlin 47 my $from_addr;
550 dpavlin 49 my $from_email_only = $from . "+" . $hash . ( $domain ? '@' . $domain : '');
551 dpavlin 48
552 dpavlin 47 $from_addr .= '"' . $u->list_id->from_addr . '" ' if ($u->list_id->from_addr);
553     $from_addr .= '<' . $from_email_only . '>';
554     my $to = '"' . $u->user_id->name . '" <' . $to_email . '>';
555 dpavlin 29
556 dpavlin 32 my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
557 dpavlin 29
558 dpavlin 49 $m_obj->header_set('Return-Path', $from_email_only) || croak "can't set Return-Path: header";
559     $m_obj->header_set('Sender', $from_email_only) || croak "can't set Sender: header";
560     $m_obj->header_set('Errors-To', $from_email_only) || croak "can't set Errors-To: header";
561 dpavlin 47 $m_obj->header_set('From', $from_addr) || croak "can't set From: header";
562 dpavlin 32 $m_obj->header_set('To', $to) || croak "can't set To: header";
563 dpavlin 29
564 dpavlin 38 $m_obj->header_set('X-Nos-Version', $VERSION);
565     $m_obj->header_set('X-Nos-Hash', $hash);
566    
567 dpavlin 47 # really send e-mail
568 dpavlin 65 my $sent_status;
569    
570 dpavlin 47 if (@email_send_options) {
571 dpavlin 65 $sent_status = send $email_send_driver => $m_obj->as_string, @email_send_options;
572 dpavlin 47 } else {
573 dpavlin 65 $sent_status = send $email_send_driver => $m_obj->as_string;
574 dpavlin 47 }
575 dpavlin 22
576 dpavlin 65 croak "can't send e-mail: $sent_status\n\nOriginal e-mail follows:\n".$m_obj->as_string unless ($sent_status);
577 dpavlin 75 my @bad;
578     @bad = @{ $sent_status->prop('bad') } if (eval { $sent_status->can('prop') });
579 dpavlin 65 croak "failed sending to ",join(",",@bad) if (@bad);
580 dpavlin 49
581 dpavlin 65 if ($sent_status) {
582    
583     $sent->create({
584     message_id => $m->message_id,
585     user_id => $u->user_id,
586     hash => $hash,
587     });
588     $sent->dbi_commit;
589    
590     print " - $sent_status\n";
591    
592 dpavlin 75 $ok++;
593 dpavlin 65 } else {
594     warn "ERROR: $sent_status\n";
595     }
596    
597 dpavlin 49 if ($sleep) {
598     warn "sleeping $sleep seconds\n";
599     sleep($sleep);
600     }
601 dpavlin 22 }
602     }
603     $m->all_sent(1);
604     $m->update;
605     $m->dbi_commit;
606     }
607    
608 dpavlin 75 return $ok;
609    
610 dpavlin 20 }
611    
612 dpavlin 29 =head2 inbox_message
613    
614     Receive single message for list's inbox.
615    
616 dpavlin 36 my $ok = $nos->inbox_message(
617     list => 'My list',
618     message => $message,
619     );
620 dpavlin 29
621 dpavlin 60 This method is used by C<sender.pl> when receiving e-mail messages.
622    
623 dpavlin 29 =cut
624    
625     sub inbox_message {
626     my $self = shift;
627    
628 dpavlin 36 my $arg = {@_};
629 dpavlin 29
630 dpavlin 36 return unless ($arg->{'message'});
631     croak "need list name" unless ($arg->{'list'});
632 dpavlin 29
633 dpavlin 52 $arg->{'list'} = lc($arg->{'list'});
634    
635 dpavlin 37 my $this_list = $self->_get_list($arg->{'list'}) || croak "can't find list ".$arg->{'list'}."\n";
636    
637 dpavlin 36 my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message";
638    
639     my $to = $m->header('To') || die "can't find To: address in incomming message\n";
640    
641 dpavlin 48 my $return_path = $m->header('Return-Path') || '';
642    
643 dpavlin 36 my @addrs = Email::Address->parse( $to );
644    
645     die "can't parse To: $to address\n" unless (@addrs);
646    
647     my $hl = $self->{'hash_len'} || confess "no hash_len?";
648    
649     my $hash;
650    
651     foreach my $a (@addrs) {
652 dpavlin 52 if ($a->address =~ m/\+([a-f0-9]{$hl})@/i) {
653 dpavlin 36 $hash = $1;
654     last;
655     }
656     }
657    
658 dpavlin 50 #warn "can't find hash in e-mail $to\n" unless ($hash);
659 dpavlin 36
660     my $sent = $self->{'loader'}->find_class('sent');
661    
662     # will use null if no matching message_id is found
663 dpavlin 50 my $sent_msg;
664     $sent_msg = $sent->search( hash => $hash )->first if ($hash);
665 dpavlin 36
666 dpavlin 37 my ($message_id, $user_id) = (undef, undef); # init with NULL
667 dpavlin 36
668 dpavlin 37 if ($sent_msg) {
669     $message_id = $sent_msg->message_id || carp "no message_id";
670     $user_id = $sent_msg->user_id || carp "no user_id";
671 dpavlin 47 } else {
672 dpavlin 50 #warn "can't find sender with hash $hash\n";
673     my $users = $self->{'loader'}->find_class('users');
674     my $from = $m->header('From');
675     $from = $1 if ($from =~ m/<(.*)>/);
676 dpavlin 52 my $this_user = $users->search( email => lc($from) )->first;
677 dpavlin 50 $user_id = $this_user->id if ($this_user);
678 dpavlin 37 }
679    
680    
681     my $is_bounce = 0;
682    
683 dpavlin 49 if ($return_path eq '<>' || $return_path eq '') {
684 dpavlin 47 no warnings;
685     my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
686     $arg->{'message'}, { report_non_bounces=>1 },
687     ) };
688 dpavlin 50 #warn "can't check if this message is bounce!" if ($@);
689 dpavlin 47
690     $is_bounce++ if ($bounce && $bounce->is_bounce);
691     }
692 dpavlin 37
693     my $received = $self->{'loader'}->find_class('received');
694    
695     my $this_received = $received->find_or_create({
696     user_id => $user_id,
697     list_id => $this_list->id,
698     message_id => $message_id,
699     message => $arg->{'message'},
700     bounced => $is_bounce,
701     }) || croak "can't insert received message";
702    
703     $this_received->dbi_commit;
704    
705 dpavlin 49 # print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
706 dpavlin 29 }
707    
708 dpavlin 75 =head2 received_messages
709 dpavlin 29
710 dpavlin 75 Returns all received messages for given list or user.
711    
712 dpavlin 80 my @received = $nos->received_messages(
713 dpavlin 75 list => 'My list',
714     email => "john.doe@example.com",
715 dpavlin 80 from_date => '2005-01-01 10:15:00',
716     to_date => '2005-01-01 12:00:00',
717     message => 0,
718 dpavlin 75 );
719    
720 dpavlin 80 If don't specify C<list> or C<email> it will return all received messages.
721     Results will be sorted by received date, oldest first.
722    
723     Other optional parametars include:
724    
725     =over 10
726    
727     =item from_date
728    
729     Date (in ISO format) for lower limit of dates received
730    
731     =item to_date
732    
733     Return just messages older than this date
734    
735     =item message
736    
737     Include whole received message in result. This will probably make result
738     array very large. Use with care.
739    
740     =back
741    
742 dpavlin 81 Date ranges are inclusive, so results will include messages sent on
743     particular date specified with C<date_from> or C<date_to>.
744    
745 dpavlin 76 Each element in returned array will have following structure:
746 dpavlin 75
747 dpavlin 80 my $row = {
748 dpavlin 76 id => 42, # unique ID of received message
749 dpavlin 78 list => 'My list', # useful if filtering by email
750     ext_id => 9999, # ext_id from message sender
751     email => 'jdoe@example.com', # e-mail of message sender
752     bounced => 0, # true if message is bounce
753     date => '2005-08-24 18:57:24', # date of receival in ISO format
754 dpavlin 76 }
755    
756 dpavlin 80 If you specified C<message> option, this hash will also have C<message> key
757     which will contain whole received message.
758 dpavlin 76
759 dpavlin 75 =cut
760    
761     sub received_messages {
762     my $self = shift;
763    
764 dpavlin 77 my $arg = {@_} if (@_);
765 dpavlin 75
766 dpavlin 77 # croak "need list name or email" unless ($arg->{'list'} || $arg->{'email'});
767 dpavlin 75
768 dpavlin 77 my $sql = qq{
769     select
770     received.id as id,
771     lists.name as list,
772     users.ext_id as ext_id,
773     users.email as email,
774 dpavlin 80 };
775     $sql .= qq{ message,} if ($arg->{'message'});
776     $sql .= qq{
777 dpavlin 77 bounced,received.date as date
778     from received
779     join lists on lists.id = list_id
780     join users on users.id = user_id
781     };
782 dpavlin 75
783 dpavlin 81 my $order = qq{ order by date asc };
784 dpavlin 80
785 dpavlin 77 my $where;
786 dpavlin 75
787 dpavlin 77 $where->{'lists.name'} = lc($arg->{'list'}) if ($arg->{'list'});
788     $where->{'users.email'} = lc($arg->{'email'}) if ($arg->{'email'});
789 dpavlin 80 $where->{'received.date'} = { '>=', $arg->{'date_from'} } if ($arg->{'date_from'});
790     $where->{'received.date'} = { '<=', $arg->{'date_to'} } if ($arg->{'date_to'});
791 dpavlin 77
792     # hum, yammy one-liner
793     my($stmt, @bind) = SQL::Abstract->new->where($where);
794    
795     my $dbh = $self->{'loader'}->find_class('received')->db_Main;
796    
797 dpavlin 80 my $sth = $dbh->prepare($sql . $stmt . $order);
798 dpavlin 77 $sth->execute(@bind);
799 dpavlin 76 return $sth->fetchall_hash;
800 dpavlin 75 }
801    
802    
803 dpavlin 30 =head1 INTERNAL METHODS
804    
805     Beware of dragons! You shouldn't need to call those methods directly.
806    
807 dpavlin 66
808     =head2 _add_aliases
809    
810 dpavlin 71 Add or update alias in C</etc/aliases> (or equivalent) file for selected list
811 dpavlin 66
812     my $ok = $nos->add_aliases(
813     list => 'My list',
814     email => 'my-list@example.com',
815     aliases => '/etc/mail/mylist',
816     archive => '/path/to/mbox/archive',
817    
818     );
819    
820     C<archive> parametar is optional.
821    
822     Return false on failure.
823    
824     =cut
825    
826     sub _add_aliases {
827     my $self = shift;
828    
829     my $arg = {@_};
830    
831 dpavlin 68 foreach my $o (qw/list email aliases/) {
832     croak "need $o option" unless ($arg->{$o});
833     }
834 dpavlin 66
835 dpavlin 68 my $aliases = $arg->{'aliases'};
836     my $email = $arg->{'email'};
837     my $list = $arg->{'list'};
838 dpavlin 66
839     unless (-e $aliases) {
840     warn "aliases file $aliases doesn't exist, creating empty\n";
841     open(my $fh, '>', $aliases) || croak "can't create $aliases: $!";
842     close($fh);
843 dpavlin 67 chmod 0777, $aliases || warn "can't change permission to 0777";
844 dpavlin 66 }
845    
846 dpavlin 71 die "FATAL: aliases file $aliases is not writable\n" unless (-w $aliases);
847    
848 dpavlin 66 my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
849    
850     my $target = '';
851    
852     if (my $archive = $arg->{'archive'}) {
853     $target .= "$archive, ";
854    
855     if (! -e $archive) {
856     warn "please make sure that file $archive is writable for your e-mail user (defaulting to bad 777 permission for now)";
857    
858     open(my $fh, '>', $archive) || croak "can't create archive file $archive: $!";
859     close($fh);
860     chmod 0777, $archive || croak "can't chmod archive file $archive to 0777: $!";
861     }
862     }
863    
864     # resolve my path to absolute one
865     my $self_path = abs_path($0);
866     $self_path =~ s#/[^/]+$##;
867     $self_path =~ s#/t/*$#/#;
868    
869 dpavlin 68 $target .= qq#| cd $self_path && ./sender.pl --inbox="$list"#;
870 dpavlin 66
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 58 list => $_[0], email => $_[1], name => $_[2], ext_id => $_[4],
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 78 return $nos->received_messages(
1220     list => $_[0], email => $_[1],
1221 dpavlin 80 from_date => $_[2], to_date => $_[3],
1222     message => $_[4]
1223 dpavlin 78 );
1224     } else {
1225 dpavlin 79 my $arg = shift;
1226     die "need list or email argument" unless ($arg->{'list'} || $arg->{'email'});
1227 dpavlin 78 return $nos->received_messages( $arg );
1228     }
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