/[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 89 - (hide annotations)
Mon Dec 18 18:55:43 2006 UTC (17 years, 2 months ago) by dpavlin
File size: 29369 byte(s)
added backward-compatibility option full_hostname_in_aliases which
is depriciated now because postalias isn't happy about it, but
tests require it, require explicit version of some modules
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 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     );
467 dpavlin 20
468 dpavlin 47 Second option is driver which will be used for e-mail delivery. If not
469     specified, C<IO> driver will be used which will dump e-mail to C<STDERR>.
470    
471     Other valid drivers are:
472    
473     =over 10
474    
475     =item smtp
476    
477     Send e-mail using SMTP server at 127.0.0.1
478    
479     =back
480    
481 dpavlin 75 Any other driver name will try to use C<Email::Send::that_driver> module.
482    
483 dpavlin 49 Default sleep wait between two messages is 3 seconds.
484    
485 dpavlin 75 This method will return number of succesfully sent messages.
486    
487 dpavlin 21 =cut
488 dpavlin 20
489 dpavlin 22 sub send_queued_messages {
490 dpavlin 21 my $self = shift;
491 dpavlin 20
492 dpavlin 49 my $arg = {@_};
493 dpavlin 20
494 dpavlin 52 my $list_name = lc($arg->{'list'}) || '';
495 dpavlin 49 my $driver = $arg->{'driver'} || '';
496     my $sleep = $arg->{'sleep'};
497     $sleep ||= 3 unless defined($sleep);
498 dpavlin 47
499 dpavlin 75 # number of messages sent o.k.
500     my $ok = 0;
501    
502 dpavlin 49 my $email_send_driver = 'Email::Send::IO';
503     my @email_send_options;
504    
505 dpavlin 47 if (lc($driver) eq 'smtp') {
506     $email_send_driver = 'Email::Send::SMTP';
507     @email_send_options = ['127.0.0.1'];
508 dpavlin 75 } elsif ($driver && $driver ne '') {
509     $email_send_driver = 'Email::Send::' . $driver;
510 dpavlin 52 } else {
511     warn "dumping all messages to STDERR\n";
512 dpavlin 47 }
513    
514 dpavlin 22 my $lists = $self->{'loader'}->find_class('lists');
515     my $queue = $self->{'loader'}->find_class('queue');
516     my $user_list = $self->{'loader'}->find_class('user_list');
517     my $sent = $self->{'loader'}->find_class('sent');
518 dpavlin 20
519 dpavlin 22 my $my_q;
520     if ($list_name ne '') {
521     my $l_id = $lists->search_like( name => $list_name )->first ||
522     croak "can't find list $list_name";
523     $my_q = $queue->search_like( list_id => $l_id ) ||
524     croak "can't find list $list_name";
525     } else {
526     $my_q = $queue->retrieve_all;
527     }
528 dpavlin 20
529 dpavlin 22 while (my $m = $my_q->next) {
530     next if ($m->all_sent);
531 dpavlin 20
532 dpavlin 22 print "sending message ",$m->message_id," enqueued on ",$m->date," to list ",$m->list_id->name,"\n";
533     my $msg = $m->message_id->message;
534 dpavlin 20
535 dpavlin 22 foreach my $u ($user_list->search(list_id => $m->list_id)) {
536 dpavlin 20
537 dpavlin 29 my $to_email = $u->user_id->email;
538    
539 dpavlin 32 my ($from,$domain) = split(/@/, $u->list_id->email, 2);
540    
541 dpavlin 22 if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {
542 dpavlin 29 print "SKIP $to_email message allready sent\n";
543 dpavlin 22 } else {
544 dpavlin 65 print "=> $to_email ";
545 dpavlin 20
546 dpavlin 32 my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;
547 dpavlin 36 my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
548 dpavlin 32
549 dpavlin 29 my $hash = $auth->generate_hash( $to_email );
550 dpavlin 20
551 dpavlin 47 my $from_addr;
552 dpavlin 49 my $from_email_only = $from . "+" . $hash . ( $domain ? '@' . $domain : '');
553 dpavlin 48
554 dpavlin 47 $from_addr .= '"' . $u->list_id->from_addr . '" ' if ($u->list_id->from_addr);
555     $from_addr .= '<' . $from_email_only . '>';
556     my $to = '"' . $u->user_id->name . '" <' . $to_email . '>';
557 dpavlin 29
558 dpavlin 32 my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
559 dpavlin 29
560 dpavlin 49 $m_obj->header_set('Return-Path', $from_email_only) || croak "can't set Return-Path: header";
561 dpavlin 86 #$m_obj->header_set('Sender', $from_email_only) || croak "can't set Sender: header";
562 dpavlin 49 $m_obj->header_set('Errors-To', $from_email_only) || croak "can't set Errors-To: header";
563 dpavlin 47 $m_obj->header_set('From', $from_addr) || croak "can't set From: header";
564 dpavlin 32 $m_obj->header_set('To', $to) || croak "can't set To: header";
565 dpavlin 29
566 dpavlin 38 $m_obj->header_set('X-Nos-Version', $VERSION);
567     $m_obj->header_set('X-Nos-Hash', $hash);
568    
569 dpavlin 47 # really send e-mail
570 dpavlin 65 my $sent_status;
571    
572 dpavlin 47 if (@email_send_options) {
573 dpavlin 65 $sent_status = send $email_send_driver => $m_obj->as_string, @email_send_options;
574 dpavlin 47 } else {
575 dpavlin 65 $sent_status = send $email_send_driver => $m_obj->as_string;
576 dpavlin 47 }
577 dpavlin 22
578 dpavlin 65 croak "can't send e-mail: $sent_status\n\nOriginal e-mail follows:\n".$m_obj->as_string unless ($sent_status);
579 dpavlin 75 my @bad;
580     @bad = @{ $sent_status->prop('bad') } if (eval { $sent_status->can('prop') });
581 dpavlin 65 croak "failed sending to ",join(",",@bad) if (@bad);
582 dpavlin 49
583 dpavlin 65 if ($sent_status) {
584    
585     $sent->create({
586     message_id => $m->message_id,
587     user_id => $u->user_id,
588     hash => $hash,
589     });
590     $sent->dbi_commit;
591    
592     print " - $sent_status\n";
593    
594 dpavlin 75 $ok++;
595 dpavlin 65 } else {
596     warn "ERROR: $sent_status\n";
597     }
598    
599 dpavlin 49 if ($sleep) {
600     warn "sleeping $sleep seconds\n";
601     sleep($sleep);
602     }
603 dpavlin 22 }
604     }
605     $m->all_sent(1);
606     $m->update;
607     $m->dbi_commit;
608     }
609    
610 dpavlin 75 return $ok;
611    
612 dpavlin 20 }
613    
614 dpavlin 29 =head2 inbox_message
615    
616     Receive single message for list's inbox.
617    
618 dpavlin 36 my $ok = $nos->inbox_message(
619     list => 'My list',
620     message => $message,
621     );
622 dpavlin 29
623 dpavlin 60 This method is used by C<sender.pl> when receiving e-mail messages.
624    
625 dpavlin 29 =cut
626    
627     sub inbox_message {
628     my $self = shift;
629    
630 dpavlin 36 my $arg = {@_};
631 dpavlin 29
632 dpavlin 36 return unless ($arg->{'message'});
633     croak "need list name" unless ($arg->{'list'});
634 dpavlin 29
635 dpavlin 52 $arg->{'list'} = lc($arg->{'list'});
636    
637 dpavlin 37 my $this_list = $self->_get_list($arg->{'list'}) || croak "can't find list ".$arg->{'list'}."\n";
638    
639 dpavlin 36 my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message";
640    
641     my $to = $m->header('To') || die "can't find To: address in incomming message\n";
642    
643 dpavlin 48 my $return_path = $m->header('Return-Path') || '';
644    
645 dpavlin 36 my @addrs = Email::Address->parse( $to );
646    
647     die "can't parse To: $to address\n" unless (@addrs);
648    
649     my $hl = $self->{'hash_len'} || confess "no hash_len?";
650    
651     my $hash;
652    
653     foreach my $a (@addrs) {
654 dpavlin 52 if ($a->address =~ m/\+([a-f0-9]{$hl})@/i) {
655 dpavlin 36 $hash = $1;
656     last;
657     }
658     }
659    
660 dpavlin 50 #warn "can't find hash in e-mail $to\n" unless ($hash);
661 dpavlin 36
662     my $sent = $self->{'loader'}->find_class('sent');
663    
664     # will use null if no matching message_id is found
665 dpavlin 50 my $sent_msg;
666     $sent_msg = $sent->search( hash => $hash )->first if ($hash);
667 dpavlin 36
668 dpavlin 37 my ($message_id, $user_id) = (undef, undef); # init with NULL
669 dpavlin 36
670 dpavlin 37 if ($sent_msg) {
671     $message_id = $sent_msg->message_id || carp "no message_id";
672     $user_id = $sent_msg->user_id || carp "no user_id";
673 dpavlin 47 } else {
674 dpavlin 50 #warn "can't find sender with hash $hash\n";
675     my $users = $self->{'loader'}->find_class('users');
676     my $from = $m->header('From');
677     $from = $1 if ($from =~ m/<(.*)>/);
678 dpavlin 52 my $this_user = $users->search( email => lc($from) )->first;
679 dpavlin 50 $user_id = $this_user->id if ($this_user);
680 dpavlin 37 }
681    
682    
683     my $is_bounce = 0;
684    
685 dpavlin 49 if ($return_path eq '<>' || $return_path eq '') {
686 dpavlin 47 no warnings;
687     my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
688     $arg->{'message'}, { report_non_bounces=>1 },
689     ) };
690 dpavlin 50 #warn "can't check if this message is bounce!" if ($@);
691 dpavlin 47
692     $is_bounce++ if ($bounce && $bounce->is_bounce);
693     }
694 dpavlin 37
695     my $received = $self->{'loader'}->find_class('received');
696    
697     my $this_received = $received->find_or_create({
698     user_id => $user_id,
699     list_id => $this_list->id,
700     message_id => $message_id,
701     message => $arg->{'message'},
702     bounced => $is_bounce,
703     }) || croak "can't insert received message";
704    
705     $this_received->dbi_commit;
706    
707 dpavlin 49 # print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
708 dpavlin 29 }
709    
710 dpavlin 75 =head2 received_messages
711 dpavlin 29
712 dpavlin 75 Returns all received messages for given list or user.
713    
714 dpavlin 80 my @received = $nos->received_messages(
715 dpavlin 75 list => 'My list',
716     email => "john.doe@example.com",
717 dpavlin 80 from_date => '2005-01-01 10:15:00',
718     to_date => '2005-01-01 12:00:00',
719     message => 0,
720 dpavlin 75 );
721    
722 dpavlin 80 If don't specify C<list> or C<email> it will return all received messages.
723     Results will be sorted by received date, oldest first.
724    
725     Other optional parametars include:
726    
727     =over 10
728    
729     =item from_date
730    
731     Date (in ISO format) for lower limit of dates received
732    
733     =item to_date
734    
735     Return just messages older than this date
736    
737     =item message
738    
739     Include whole received message in result. This will probably make result
740     array very large. Use with care.
741    
742     =back
743    
744 dpavlin 81 Date ranges are inclusive, so results will include messages sent on
745     particular date specified with C<date_from> or C<date_to>.
746    
747 dpavlin 76 Each element in returned array will have following structure:
748 dpavlin 75
749 dpavlin 80 my $row = {
750 dpavlin 76 id => 42, # unique ID of received message
751 dpavlin 78 list => 'My list', # useful if filtering by email
752     ext_id => 9999, # ext_id from message sender
753     email => 'jdoe@example.com', # e-mail of message sender
754     bounced => 0, # true if message is bounce
755     date => '2005-08-24 18:57:24', # date of receival in ISO format
756 dpavlin 76 }
757    
758 dpavlin 80 If you specified C<message> option, this hash will also have C<message> key
759     which will contain whole received message.
760 dpavlin 76
761 dpavlin 75 =cut
762    
763     sub received_messages {
764     my $self = shift;
765    
766 dpavlin 77 my $arg = {@_} if (@_);
767 dpavlin 75
768 dpavlin 77 # croak "need list name or email" unless ($arg->{'list'} || $arg->{'email'});
769 dpavlin 75
770 dpavlin 77 my $sql = qq{
771     select
772     received.id as id,
773     lists.name as list,
774     users.ext_id as ext_id,
775     users.email as email,
776 dpavlin 80 };
777     $sql .= qq{ message,} if ($arg->{'message'});
778     $sql .= qq{
779 dpavlin 77 bounced,received.date as date
780     from received
781     join lists on lists.id = list_id
782     join users on users.id = user_id
783     };
784 dpavlin 75
785 dpavlin 81 my $order = qq{ order by date asc };
786 dpavlin 80
787 dpavlin 77 my $where;
788 dpavlin 75
789 dpavlin 77 $where->{'lists.name'} = lc($arg->{'list'}) if ($arg->{'list'});
790     $where->{'users.email'} = lc($arg->{'email'}) if ($arg->{'email'});
791 dpavlin 80 $where->{'received.date'} = { '>=', $arg->{'date_from'} } if ($arg->{'date_from'});
792     $where->{'received.date'} = { '<=', $arg->{'date_to'} } if ($arg->{'date_to'});
793 dpavlin 77
794     # hum, yammy one-liner
795     my($stmt, @bind) = SQL::Abstract->new->where($where);
796    
797     my $dbh = $self->{'loader'}->find_class('received')->db_Main;
798    
799 dpavlin 80 my $sth = $dbh->prepare($sql . $stmt . $order);
800 dpavlin 77 $sth->execute(@bind);
801 dpavlin 76 return $sth->fetchall_hash;
802 dpavlin 75 }
803    
804    
805 dpavlin 30 =head1 INTERNAL METHODS
806    
807     Beware of dragons! You shouldn't need to call those methods directly.
808    
809 dpavlin 66
810     =head2 _add_aliases
811    
812 dpavlin 71 Add or update alias in C</etc/aliases> (or equivalent) file for selected list
813 dpavlin 66
814     my $ok = $nos->add_aliases(
815     list => 'My list',
816     email => 'my-list@example.com',
817     aliases => '/etc/mail/mylist',
818     archive => '/path/to/mbox/archive',
819    
820     );
821    
822     C<archive> parametar is optional.
823    
824     Return false on failure.
825    
826     =cut
827    
828     sub _add_aliases {
829     my $self = shift;
830    
831     my $arg = {@_};
832    
833 dpavlin 68 foreach my $o (qw/list email aliases/) {
834     croak "need $o option" unless ($arg->{$o});
835     }
836 dpavlin 66
837 dpavlin 68 my $aliases = $arg->{'aliases'};
838     my $email = $arg->{'email'};
839     my $list = $arg->{'list'};
840 dpavlin 66
841     unless (-e $aliases) {
842     warn "aliases file $aliases doesn't exist, creating empty\n";
843     open(my $fh, '>', $aliases) || croak "can't create $aliases: $!";
844     close($fh);
845 dpavlin 67 chmod 0777, $aliases || warn "can't change permission to 0777";
846 dpavlin 66 }
847    
848 dpavlin 71 die "FATAL: aliases file $aliases is not writable\n" unless (-w $aliases);
849    
850 dpavlin 66 my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
851    
852     my $target = '';
853    
854     if (my $archive = $arg->{'archive'}) {
855     $target .= "$archive, ";
856    
857     if (! -e $archive) {
858     warn "please make sure that file $archive is writable for your e-mail user (defaulting to bad 777 permission for now)";
859    
860     open(my $fh, '>', $archive) || croak "can't create archive file $archive: $!";
861     close($fh);
862     chmod 0777, $archive || croak "can't chmod archive file $archive to 0777: $!";
863     }
864     }
865    
866     # resolve my path to absolute one
867     my $self_path = abs_path($0);
868     $self_path =~ s#/[^/]+$##;
869     $self_path =~ s#/t/*$#/#;
870    
871 dpavlin 82 $target .= qq#"| cd $self_path && ./sender.pl --inbox='$list'"#;
872 dpavlin 66
873 dpavlin 82 # remove hostname from email to make Postfix's postalias happy
874 dpavlin 89 $email =~ s/@.+// if (not $self->{full_hostname_in_aliases});
875 dpavlin 82
876 dpavlin 68 if ($a->exists($email)) {
877     $a->update($email, $target) or croak "can't update alias ".$a->error_check;
878     } else {
879     $a->append($email, $target) or croak "can't add alias ".$a->error_check;
880 dpavlin 66 }
881    
882 dpavlin 89 # $a->write($aliases) or croak "can't save aliases $aliases ".$a->error_check;
883 dpavlin 70
884 dpavlin 66 return 1;
885     }
886    
887 dpavlin 30 =head2 _add_list
888    
889     Create new list
890    
891     my $list_obj = $nos->_add_list(
892     list => 'My list',
893 dpavlin 47 from => 'Outgoing from comment',
894 dpavlin 30 email => 'my-list@example.com',
895 dpavlin 66 aliases => '/etc/mail/mylist',
896 dpavlin 30 );
897    
898     Returns C<Class::DBI> object for created list.
899    
900 dpavlin 38 C<email> address can be with domain or without it if your
901     MTA appends it. There is no checking for validity of your
902     list e-mail. Flexibility comes with resposibility, so please
903     feed correct (and configured) return addresses.
904    
905 dpavlin 30 =cut
906    
907     sub _add_list {
908     my $self = shift;
909    
910     my $arg = {@_};
911    
912 dpavlin 52 my $name = lc($arg->{'list'}) || confess "can't add list without name";
913     my $email = lc($arg->{'email'}) || confess "can't add list without e-mail";
914 dpavlin 66 my $aliases = lc($arg->{'aliases'}) || confess "can't add list without path to aliases file";
915    
916 dpavlin 47 my $from_addr = $arg->{'from'};
917 dpavlin 30
918     my $lists = $self->{'loader'}->find_class('lists');
919    
920 dpavlin 66 $self->_add_aliases(
921     list => $name,
922     email => $email,
923     aliases => $aliases,
924 dpavlin 68 ) || warn "can't add alias $email for list $name";
925 dpavlin 66
926 dpavlin 30 my $l = $lists->find_or_create({
927     name => $name,
928     email => $email,
929     });
930 dpavlin 47
931 dpavlin 30 croak "can't add list $name\n" unless ($l);
932    
933 dpavlin 47 if ($from_addr && $l->from_addr ne $from_addr) {
934     $l->from_addr($from_addr);
935     $l->update;
936     }
937    
938 dpavlin 30 $l->dbi_commit;
939    
940     return $l;
941    
942     }
943    
944    
945 dpavlin 66
946 dpavlin 30 =head2 _get_list
947    
948     Get list C<Class::DBI> object.
949    
950     my $list_obj = $nos->check_list('My list');
951    
952     Returns false on failure.
953    
954     =cut
955    
956     sub _get_list {
957     my $self = shift;
958    
959     my $name = shift || return;
960    
961 dpavlin 31 my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";
962 dpavlin 30
963 dpavlin 52 return $lists->search({ name => lc($name) })->first;
964 dpavlin 30 }
965    
966 dpavlin 70
967     =head2 _remove_alias
968    
969     Remove list alias
970    
971     my $ok = $nos->_remove_alias(
972     email => 'mylist@example.com',
973     aliases => '/etc/mail/mylist',
974     );
975    
976     Returns true if list is removed or false if list doesn't exist. Dies in case of error.
977    
978     =cut
979    
980     sub _remove_alias {
981     my $self = shift;
982    
983     my $arg = {@_};
984    
985     my $email = lc($arg->{'email'}) || confess "can't remove alias without email";
986     my $aliases = lc($arg->{'aliases'}) || confess "can't remove alias without list";
987    
988     my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
989    
990     if ($a->exists($email)) {
991     $a->delete($email) || croak "can't remove alias $email";
992     } else {
993     return 0;
994     }
995    
996     return 1;
997    
998     }
999    
1000 dpavlin 39 ###
1001     ### SOAP
1002     ###
1003 dpavlin 30
1004 dpavlin 39 package Nos::SOAP;
1005    
1006 dpavlin 43 use Carp;
1007    
1008 dpavlin 39 =head1 SOAP methods
1009    
1010     This methods are thin wrappers to provide SOAP calls. They are grouped in
1011     C<Nos::SOAP> package which is in same F<Nos.pm> module file.
1012    
1013     Usually, you want to use named variables in your SOAP calls if at all
1014     possible.
1015    
1016     However, if you have broken SOAP library (like PHP SOAP class from PEAR)
1017     you will want to use positional arguments (in same order as documented for
1018     methods below).
1019    
1020     =cut
1021    
1022     my $nos;
1023    
1024 dpavlin 66
1025     =head2 new
1026    
1027     Create new SOAP object
1028    
1029     my $soap = new Nos::SOAP(
1030     dsn => 'dbi:Pg:dbname=notices',
1031     user => 'dpavlin',
1032     passwd => '',
1033     debug => 1,
1034     verbose => 1,
1035     hash_len => 8,
1036     aliases => '/etc/aliases',
1037     );
1038    
1039 dpavlin 75 If you are writing SOAP server (like C<soap.cgi> example), you will need to
1040     call this method once to make new instance of Nos::SOAP and specify C<dsn>
1041     and options for it.
1042    
1043 dpavlin 66 =cut
1044    
1045 dpavlin 39 sub new {
1046     my $class = shift;
1047     my $self = {@_};
1048 dpavlin 66
1049     croak "need aliases parametar" unless ($self->{'aliases'});
1050    
1051 dpavlin 39 bless($self, $class);
1052    
1053     $nos = new Nos( @_ ) || die "can't create Nos object";
1054    
1055     $self ? return $self : return undef;
1056     }
1057    
1058    
1059 dpavlin 72 =head2 CreateList
1060 dpavlin 39
1061 dpavlin 72 $message_id = CreateList(
1062 dpavlin 39 list => 'My list',
1063 dpavlin 56 from => 'Name of my list',
1064 dpavlin 39 email => 'my-list@example.com'
1065     );
1066    
1067     =cut
1068    
1069 dpavlin 72 sub CreateList {
1070 dpavlin 39 my $self = shift;
1071    
1072 dpavlin 68 my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
1073 dpavlin 66
1074 dpavlin 39 if ($_[0] !~ m/^HASH/) {
1075 dpavlin 72 return $nos->create_list(
1076 dpavlin 56 list => $_[0], from => $_[1], email => $_[2],
1077 dpavlin 66 aliases => $aliases,
1078 dpavlin 39 );
1079     } else {
1080 dpavlin 72 return $nos->create_list( %{ shift @_ }, aliases => $aliases );
1081 dpavlin 39 }
1082     }
1083    
1084 dpavlin 43
1085 dpavlin 72 =head2 DropList
1086 dpavlin 63
1087 dpavlin 72 $ok = DropList(
1088 dpavlin 63 list => 'My list',
1089     );
1090    
1091     =cut
1092    
1093 dpavlin 72 sub DropList {
1094 dpavlin 63 my $self = shift;
1095    
1096 dpavlin 70 my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
1097    
1098 dpavlin 63 if ($_[0] !~ m/^HASH/) {
1099 dpavlin 72 return $nos->drop_list(
1100 dpavlin 63 list => $_[0],
1101 dpavlin 70 aliases => $aliases,
1102 dpavlin 63 );
1103     } else {
1104 dpavlin 72 return $nos->drop_list( %{ shift @_ }, aliases => $aliases );
1105 dpavlin 63 }
1106     }
1107    
1108 dpavlin 39 =head2 AddMemberToList
1109    
1110     $member_id = AddMemberToList(
1111 dpavlin 43 list => 'My list',
1112     email => 'e-mail@example.com',
1113 dpavlin 58 name => 'Full Name',
1114     ext_id => 42,
1115 dpavlin 39 );
1116    
1117     =cut
1118    
1119     sub AddMemberToList {
1120     my $self = shift;
1121    
1122     if ($_[0] !~ m/^HASH/) {
1123     return $nos->add_member_to_list(
1124 dpavlin 84 list => $_[0], email => $_[1], name => $_[2], ext_id => $_[3],
1125 dpavlin 39 );
1126     } else {
1127     return $nos->add_member_to_list( %{ shift @_ } );
1128     }
1129     }
1130    
1131 dpavlin 43
1132     =head2 ListMembers
1133    
1134     my @members = ListMembers(
1135     list => 'My list',
1136     );
1137    
1138     Returns array of hashes with user informations, see C<list_members>.
1139    
1140     =cut
1141    
1142     sub ListMembers {
1143     my $self = shift;
1144    
1145     my $list_name;
1146    
1147     if ($_[0] !~ m/^HASH/) {
1148     $list_name = shift;
1149     } else {
1150     $list_name = $_[0]->{'list'};
1151     }
1152    
1153 dpavlin 62 return [ $nos->list_members( list => $list_name ) ];
1154 dpavlin 43 }
1155    
1156 dpavlin 62
1157     =head2 DeleteMemberFromList
1158    
1159     $member_id = DeleteMemberFromList(
1160     list => 'My list',
1161     email => 'e-mail@example.com',
1162     );
1163    
1164     =cut
1165    
1166     sub DeleteMemberFromList {
1167     my $self = shift;
1168    
1169     if ($_[0] !~ m/^HASH/) {
1170     return $nos->delete_member_from_list(
1171     list => $_[0], email => $_[1],
1172     );
1173     } else {
1174     return $nos->delete_member_from_list( %{ shift @_ } );
1175     }
1176     }
1177    
1178    
1179 dpavlin 39 =head2 AddMessageToList
1180    
1181     $message_id = AddMessageToList(
1182     list => 'My list',
1183     message => 'From: My list...'
1184     );
1185    
1186     =cut
1187    
1188     sub AddMessageToList {
1189     my $self = shift;
1190    
1191     if ($_[0] !~ m/^HASH/) {
1192     return $nos->add_message_to_list(
1193     list => $_[0], message => $_[1],
1194     );
1195     } else {
1196     return $nos->add_message_to_list( %{ shift @_ } );
1197     }
1198     }
1199    
1200 dpavlin 78 =head2 MessagesReceived
1201 dpavlin 39
1202 dpavlin 78 Return statistics about received messages.
1203 dpavlin 74
1204     my @result = MessagesReceived(
1205     list => 'My list',
1206     email => 'jdoe@example.com',
1207 dpavlin 80 from_date => '2005-01-01 10:15:00',
1208     to_date => '2005-01-01 12:00:00',
1209     message => 0,
1210 dpavlin 74 );
1211    
1212 dpavlin 80 You must specify C<list> or C<email> or any combination of those two. Other
1213     parametars are optional.
1214 dpavlin 74
1215 dpavlin 76 For format of returned array element see C<received_messages>.
1216 dpavlin 74
1217 dpavlin 78 =cut
1218    
1219     sub MessagesReceived {
1220     my $self = shift;
1221    
1222     if ($_[0] !~ m/^HASH/) {
1223 dpavlin 79 die "need at least list or email" unless (scalar @_ < 2);
1224 dpavlin 85 return \@{ $nos->received_messages(
1225 dpavlin 78 list => $_[0], email => $_[1],
1226 dpavlin 80 from_date => $_[2], to_date => $_[3],
1227     message => $_[4]
1228 dpavlin 85 ) };
1229 dpavlin 78 } else {
1230 dpavlin 79 my $arg = shift;
1231     die "need list or email argument" unless ($arg->{'list'} || $arg->{'email'});
1232 dpavlin 85 return \@{ $nos->received_messages( %{ $arg } ) };
1233 dpavlin 78 }
1234     }
1235    
1236     ###
1237    
1238 dpavlin 74 =head1 NOTE ON ARRAYS IN SOAP
1239    
1240     Returning arrays from SOAP calls is somewhat fuzzy (at least to me). It
1241     seems that SOAP::Lite client thinks that it has array with one element which
1242     is array of hashes with data.
1243    
1244 dpavlin 25 =head1 EXPORT
1245 dpavlin 20
1246 dpavlin 27 Nothing.
1247 dpavlin 20
1248     =head1 SEE ALSO
1249    
1250     mailman, ezmlm, sympa, L<Mail::Salsa>
1251    
1252 dpavlin 25
1253 dpavlin 20 =head1 AUTHOR
1254    
1255     Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
1256    
1257 dpavlin 25
1258 dpavlin 20 =head1 COPYRIGHT AND LICENSE
1259    
1260     Copyright (C) 2005 by Dobrica Pavlinusic
1261    
1262     This library is free software; you can redistribute it and/or modify
1263     it under the same terms as Perl itself, either Perl version 5.8.4 or,
1264     at your option, any later version of Perl 5 you may have available.
1265    
1266    
1267     =cut
1268 dpavlin 39
1269     1;

  ViewVC Help
Powered by ViewVC 1.1.26