/[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 85 - (hide annotations)
Wed Aug 31 16:53:21 2005 UTC (18 years, 6 months ago) by dpavlin
File size: 29188 byte(s)
force return type of MessagesReceived to be array ref

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 82 $target .= qq#"| cd $self_path && ./sender.pl --inbox='$list'"#;
870 dpavlin 66
871 dpavlin 82 # remove hostname from email to make Postfix's postalias happy
872     $email =~ s/@.+//;
873    
874 dpavlin 68 if ($a->exists($email)) {
875     $a->update($email, $target) or croak "can't update alias ".$a->error_check;
876     } else {
877     $a->append($email, $target) or croak "can't add alias ".$a->error_check;
878 dpavlin 66 }
879    
880 dpavlin 70 #$a->write($aliases) or croak "can't save aliases $aliases ".$a->error_check;
881    
882 dpavlin 66 return 1;
883     }
884    
885 dpavlin 30 =head2 _add_list
886    
887     Create new list
888    
889     my $list_obj = $nos->_add_list(
890     list => 'My list',
891 dpavlin 47 from => 'Outgoing from comment',
892 dpavlin 30 email => 'my-list@example.com',
893 dpavlin 66 aliases => '/etc/mail/mylist',
894 dpavlin 30 );
895    
896     Returns C<Class::DBI> object for created list.
897    
898 dpavlin 38 C<email> address can be with domain or without it if your
899     MTA appends it. There is no checking for validity of your
900     list e-mail. Flexibility comes with resposibility, so please
901     feed correct (and configured) return addresses.
902    
903 dpavlin 30 =cut
904    
905     sub _add_list {
906     my $self = shift;
907    
908     my $arg = {@_};
909    
910 dpavlin 52 my $name = lc($arg->{'list'}) || confess "can't add list without name";
911     my $email = lc($arg->{'email'}) || confess "can't add list without e-mail";
912 dpavlin 66 my $aliases = lc($arg->{'aliases'}) || confess "can't add list without path to aliases file";
913    
914 dpavlin 47 my $from_addr = $arg->{'from'};
915 dpavlin 30
916     my $lists = $self->{'loader'}->find_class('lists');
917    
918 dpavlin 66 $self->_add_aliases(
919     list => $name,
920     email => $email,
921     aliases => $aliases,
922 dpavlin 68 ) || warn "can't add alias $email for list $name";
923 dpavlin 66
924 dpavlin 30 my $l = $lists->find_or_create({
925     name => $name,
926     email => $email,
927     });
928 dpavlin 47
929 dpavlin 30 croak "can't add list $name\n" unless ($l);
930    
931 dpavlin 47 if ($from_addr && $l->from_addr ne $from_addr) {
932     $l->from_addr($from_addr);
933     $l->update;
934     }
935    
936 dpavlin 30 $l->dbi_commit;
937    
938     return $l;
939    
940     }
941    
942    
943 dpavlin 66
944 dpavlin 30 =head2 _get_list
945    
946     Get list C<Class::DBI> object.
947    
948     my $list_obj = $nos->check_list('My list');
949    
950     Returns false on failure.
951    
952     =cut
953    
954     sub _get_list {
955     my $self = shift;
956    
957     my $name = shift || return;
958    
959 dpavlin 31 my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";
960 dpavlin 30
961 dpavlin 52 return $lists->search({ name => lc($name) })->first;
962 dpavlin 30 }
963    
964 dpavlin 70
965     =head2 _remove_alias
966    
967     Remove list alias
968    
969     my $ok = $nos->_remove_alias(
970     email => 'mylist@example.com',
971     aliases => '/etc/mail/mylist',
972     );
973    
974     Returns true if list is removed or false if list doesn't exist. Dies in case of error.
975    
976     =cut
977    
978     sub _remove_alias {
979     my $self = shift;
980    
981     my $arg = {@_};
982    
983     my $email = lc($arg->{'email'}) || confess "can't remove alias without email";
984     my $aliases = lc($arg->{'aliases'}) || confess "can't remove alias without list";
985    
986     my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
987    
988     if ($a->exists($email)) {
989     $a->delete($email) || croak "can't remove alias $email";
990     } else {
991     return 0;
992     }
993    
994     return 1;
995    
996     }
997    
998 dpavlin 39 ###
999     ### SOAP
1000     ###
1001 dpavlin 30
1002 dpavlin 39 package Nos::SOAP;
1003    
1004 dpavlin 43 use Carp;
1005    
1006 dpavlin 39 =head1 SOAP methods
1007    
1008     This methods are thin wrappers to provide SOAP calls. They are grouped in
1009     C<Nos::SOAP> package which is in same F<Nos.pm> module file.
1010    
1011     Usually, you want to use named variables in your SOAP calls if at all
1012     possible.
1013    
1014     However, if you have broken SOAP library (like PHP SOAP class from PEAR)
1015     you will want to use positional arguments (in same order as documented for
1016     methods below).
1017    
1018     =cut
1019    
1020     my $nos;
1021    
1022 dpavlin 66
1023     =head2 new
1024    
1025     Create new SOAP object
1026    
1027     my $soap = new Nos::SOAP(
1028     dsn => 'dbi:Pg:dbname=notices',
1029     user => 'dpavlin',
1030     passwd => '',
1031     debug => 1,
1032     verbose => 1,
1033     hash_len => 8,
1034     aliases => '/etc/aliases',
1035     );
1036    
1037 dpavlin 75 If you are writing SOAP server (like C<soap.cgi> example), you will need to
1038     call this method once to make new instance of Nos::SOAP and specify C<dsn>
1039     and options for it.
1040    
1041 dpavlin 66 =cut
1042    
1043 dpavlin 39 sub new {
1044     my $class = shift;
1045     my $self = {@_};
1046 dpavlin 66
1047     croak "need aliases parametar" unless ($self->{'aliases'});
1048    
1049 dpavlin 39 bless($self, $class);
1050    
1051     $nos = new Nos( @_ ) || die "can't create Nos object";
1052    
1053     $self ? return $self : return undef;
1054     }
1055    
1056    
1057 dpavlin 72 =head2 CreateList
1058 dpavlin 39
1059 dpavlin 72 $message_id = CreateList(
1060 dpavlin 39 list => 'My list',
1061 dpavlin 56 from => 'Name of my list',
1062 dpavlin 39 email => 'my-list@example.com'
1063     );
1064    
1065     =cut
1066    
1067 dpavlin 72 sub CreateList {
1068 dpavlin 39 my $self = shift;
1069    
1070 dpavlin 68 my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
1071 dpavlin 66
1072 dpavlin 39 if ($_[0] !~ m/^HASH/) {
1073 dpavlin 72 return $nos->create_list(
1074 dpavlin 56 list => $_[0], from => $_[1], email => $_[2],
1075 dpavlin 66 aliases => $aliases,
1076 dpavlin 39 );
1077     } else {
1078 dpavlin 72 return $nos->create_list( %{ shift @_ }, aliases => $aliases );
1079 dpavlin 39 }
1080     }
1081    
1082 dpavlin 43
1083 dpavlin 72 =head2 DropList
1084 dpavlin 63
1085 dpavlin 72 $ok = DropList(
1086 dpavlin 63 list => 'My list',
1087     );
1088    
1089     =cut
1090    
1091 dpavlin 72 sub DropList {
1092 dpavlin 63 my $self = shift;
1093    
1094 dpavlin 70 my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
1095    
1096 dpavlin 63 if ($_[0] !~ m/^HASH/) {
1097 dpavlin 72 return $nos->drop_list(
1098 dpavlin 63 list => $_[0],
1099 dpavlin 70 aliases => $aliases,
1100 dpavlin 63 );
1101     } else {
1102 dpavlin 72 return $nos->drop_list( %{ shift @_ }, aliases => $aliases );
1103 dpavlin 63 }
1104     }
1105    
1106 dpavlin 39 =head2 AddMemberToList
1107    
1108     $member_id = AddMemberToList(
1109 dpavlin 43 list => 'My list',
1110     email => 'e-mail@example.com',
1111 dpavlin 58 name => 'Full Name',
1112     ext_id => 42,
1113 dpavlin 39 );
1114    
1115     =cut
1116    
1117     sub AddMemberToList {
1118     my $self = shift;
1119    
1120     if ($_[0] !~ m/^HASH/) {
1121     return $nos->add_member_to_list(
1122 dpavlin 84 list => $_[0], email => $_[1], name => $_[2], ext_id => $_[3],
1123 dpavlin 39 );
1124     } else {
1125     return $nos->add_member_to_list( %{ shift @_ } );
1126     }
1127     }
1128    
1129 dpavlin 43
1130     =head2 ListMembers
1131    
1132     my @members = ListMembers(
1133     list => 'My list',
1134     );
1135    
1136     Returns array of hashes with user informations, see C<list_members>.
1137    
1138     =cut
1139    
1140     sub ListMembers {
1141     my $self = shift;
1142    
1143     my $list_name;
1144    
1145     if ($_[0] !~ m/^HASH/) {
1146     $list_name = shift;
1147     } else {
1148     $list_name = $_[0]->{'list'};
1149     }
1150    
1151 dpavlin 62 return [ $nos->list_members( list => $list_name ) ];
1152 dpavlin 43 }
1153    
1154 dpavlin 62
1155     =head2 DeleteMemberFromList
1156    
1157     $member_id = DeleteMemberFromList(
1158     list => 'My list',
1159     email => 'e-mail@example.com',
1160     );
1161    
1162     =cut
1163    
1164     sub DeleteMemberFromList {
1165     my $self = shift;
1166    
1167     if ($_[0] !~ m/^HASH/) {
1168     return $nos->delete_member_from_list(
1169     list => $_[0], email => $_[1],
1170     );
1171     } else {
1172     return $nos->delete_member_from_list( %{ shift @_ } );
1173     }
1174     }
1175    
1176    
1177 dpavlin 39 =head2 AddMessageToList
1178    
1179     $message_id = AddMessageToList(
1180     list => 'My list',
1181     message => 'From: My list...'
1182     );
1183    
1184     =cut
1185    
1186     sub AddMessageToList {
1187     my $self = shift;
1188    
1189     if ($_[0] !~ m/^HASH/) {
1190     return $nos->add_message_to_list(
1191     list => $_[0], message => $_[1],
1192     );
1193     } else {
1194     return $nos->add_message_to_list( %{ shift @_ } );
1195     }
1196     }
1197    
1198 dpavlin 78 =head2 MessagesReceived
1199 dpavlin 39
1200 dpavlin 78 Return statistics about received messages.
1201 dpavlin 74
1202     my @result = MessagesReceived(
1203     list => 'My list',
1204     email => 'jdoe@example.com',
1205 dpavlin 80 from_date => '2005-01-01 10:15:00',
1206     to_date => '2005-01-01 12:00:00',
1207     message => 0,
1208 dpavlin 74 );
1209    
1210 dpavlin 80 You must specify C<list> or C<email> or any combination of those two. Other
1211     parametars are optional.
1212 dpavlin 74
1213 dpavlin 76 For format of returned array element see C<received_messages>.
1214 dpavlin 74
1215 dpavlin 78 =cut
1216    
1217     sub MessagesReceived {
1218     my $self = shift;
1219    
1220     if ($_[0] !~ m/^HASH/) {
1221 dpavlin 79 die "need at least list or email" unless (scalar @_ < 2);
1222 dpavlin 85 return \@{ $nos->received_messages(
1223 dpavlin 78 list => $_[0], email => $_[1],
1224 dpavlin 80 from_date => $_[2], to_date => $_[3],
1225     message => $_[4]
1226 dpavlin 85 ) };
1227 dpavlin 78 } else {
1228 dpavlin 79 my $arg = shift;
1229     die "need list or email argument" unless ($arg->{'list'} || $arg->{'email'});
1230 dpavlin 85 return \@{ $nos->received_messages( %{ $arg } ) };
1231 dpavlin 78 }
1232     }
1233    
1234     ###
1235    
1236 dpavlin 74 =head1 NOTE ON ARRAYS IN SOAP
1237    
1238     Returning arrays from SOAP calls is somewhat fuzzy (at least to me). It
1239     seems that SOAP::Lite client thinks that it has array with one element which
1240     is array of hashes with data.
1241    
1242 dpavlin 25 =head1 EXPORT
1243 dpavlin 20
1244 dpavlin 27 Nothing.
1245 dpavlin 20
1246     =head1 SEE ALSO
1247    
1248     mailman, ezmlm, sympa, L<Mail::Salsa>
1249    
1250 dpavlin 25
1251 dpavlin 20 =head1 AUTHOR
1252    
1253     Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
1254    
1255 dpavlin 25
1256 dpavlin 20 =head1 COPYRIGHT AND LICENSE
1257    
1258     Copyright (C) 2005 by Dobrica Pavlinusic
1259    
1260     This library is free software; you can redistribute it and/or modify
1261     it under the same terms as Perl itself, either Perl version 5.8.4 or,
1262     at your option, any later version of Perl 5 you may have available.
1263    
1264    
1265     =cut
1266 dpavlin 39
1267     1;

  ViewVC Help
Powered by ViewVC 1.1.26