/[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 80 - (hide annotations)
Fri Aug 26 05:38:00 2005 UTC (18 years, 6 months ago) by dpavlin
File size: 29254 byte(s)
implemented date rangers and whole message content for received_messages,
need to fix tests

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 76 Each element in returned array will have following structure:
743 dpavlin 75
744 dpavlin 80 my $row = {
745 dpavlin 76 id => 42, # unique ID of received message
746 dpavlin 78 list => 'My list', # useful if filtering by email
747     ext_id => 9999, # ext_id from message sender
748     email => 'jdoe@example.com', # e-mail of message sender
749     bounced => 0, # true if message is bounce
750     date => '2005-08-24 18:57:24', # date of receival in ISO format
751 dpavlin 76 }
752    
753 dpavlin 80 If you specified C<message> option, this hash will also have C<message> key
754     which will contain whole received message.
755 dpavlin 76
756 dpavlin 75 =cut
757    
758     sub received_messages {
759     my $self = shift;
760    
761 dpavlin 77 my $arg = {@_} if (@_);
762 dpavlin 75
763 dpavlin 77 # croak "need list name or email" unless ($arg->{'list'} || $arg->{'email'});
764 dpavlin 75
765 dpavlin 77 my $sql = qq{
766     select
767     received.id as id,
768     lists.name as list,
769     users.ext_id as ext_id,
770     users.email as email,
771 dpavlin 80 };
772     $sql .= qq{ message,} if ($arg->{'message'});
773     $sql .= qq{
774 dpavlin 77 bounced,received.date as date
775     from received
776     join lists on lists.id = list_id
777     join users on users.id = user_id
778     };
779 dpavlin 75
780 dpavlin 80 my $order = qq{ order by date desc };
781    
782 dpavlin 77 my $where;
783 dpavlin 75
784 dpavlin 77 $where->{'lists.name'} = lc($arg->{'list'}) if ($arg->{'list'});
785     $where->{'users.email'} = lc($arg->{'email'}) if ($arg->{'email'});
786 dpavlin 80 $where->{'received.date'} = { '>=', $arg->{'date_from'} } if ($arg->{'date_from'});
787     $where->{'received.date'} = { '<=', $arg->{'date_to'} } if ($arg->{'date_to'});
788 dpavlin 77
789     # hum, yammy one-liner
790     my($stmt, @bind) = SQL::Abstract->new->where($where);
791    
792     my $dbh = $self->{'loader'}->find_class('received')->db_Main;
793    
794 dpavlin 80 my $sth = $dbh->prepare($sql . $stmt . $order);
795 dpavlin 77 $sth->execute(@bind);
796 dpavlin 76 return $sth->fetchall_hash;
797 dpavlin 75 }
798    
799    
800 dpavlin 30 =head1 INTERNAL METHODS
801    
802     Beware of dragons! You shouldn't need to call those methods directly.
803    
804 dpavlin 66
805     =head2 _add_aliases
806    
807 dpavlin 71 Add or update alias in C</etc/aliases> (or equivalent) file for selected list
808 dpavlin 66
809     my $ok = $nos->add_aliases(
810     list => 'My list',
811     email => 'my-list@example.com',
812     aliases => '/etc/mail/mylist',
813     archive => '/path/to/mbox/archive',
814    
815     );
816    
817     C<archive> parametar is optional.
818    
819     Return false on failure.
820    
821     =cut
822    
823     sub _add_aliases {
824     my $self = shift;
825    
826     my $arg = {@_};
827    
828 dpavlin 68 foreach my $o (qw/list email aliases/) {
829     croak "need $o option" unless ($arg->{$o});
830     }
831 dpavlin 66
832 dpavlin 68 my $aliases = $arg->{'aliases'};
833     my $email = $arg->{'email'};
834     my $list = $arg->{'list'};
835 dpavlin 66
836     unless (-e $aliases) {
837     warn "aliases file $aliases doesn't exist, creating empty\n";
838     open(my $fh, '>', $aliases) || croak "can't create $aliases: $!";
839     close($fh);
840 dpavlin 67 chmod 0777, $aliases || warn "can't change permission to 0777";
841 dpavlin 66 }
842    
843 dpavlin 71 die "FATAL: aliases file $aliases is not writable\n" unless (-w $aliases);
844    
845 dpavlin 66 my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
846    
847     my $target = '';
848    
849     if (my $archive = $arg->{'archive'}) {
850     $target .= "$archive, ";
851    
852     if (! -e $archive) {
853     warn "please make sure that file $archive is writable for your e-mail user (defaulting to bad 777 permission for now)";
854    
855     open(my $fh, '>', $archive) || croak "can't create archive file $archive: $!";
856     close($fh);
857     chmod 0777, $archive || croak "can't chmod archive file $archive to 0777: $!";
858     }
859     }
860    
861     # resolve my path to absolute one
862     my $self_path = abs_path($0);
863     $self_path =~ s#/[^/]+$##;
864     $self_path =~ s#/t/*$#/#;
865    
866 dpavlin 68 $target .= qq#| cd $self_path && ./sender.pl --inbox="$list"#;
867 dpavlin 66
868 dpavlin 68 if ($a->exists($email)) {
869     $a->update($email, $target) or croak "can't update alias ".$a->error_check;
870     } else {
871     $a->append($email, $target) or croak "can't add alias ".$a->error_check;
872 dpavlin 66 }
873    
874 dpavlin 70 #$a->write($aliases) or croak "can't save aliases $aliases ".$a->error_check;
875    
876 dpavlin 66 return 1;
877     }
878    
879 dpavlin 30 =head2 _add_list
880    
881     Create new list
882    
883     my $list_obj = $nos->_add_list(
884     list => 'My list',
885 dpavlin 47 from => 'Outgoing from comment',
886 dpavlin 30 email => 'my-list@example.com',
887 dpavlin 66 aliases => '/etc/mail/mylist',
888 dpavlin 30 );
889    
890     Returns C<Class::DBI> object for created list.
891    
892 dpavlin 38 C<email> address can be with domain or without it if your
893     MTA appends it. There is no checking for validity of your
894     list e-mail. Flexibility comes with resposibility, so please
895     feed correct (and configured) return addresses.
896    
897 dpavlin 30 =cut
898    
899     sub _add_list {
900     my $self = shift;
901    
902     my $arg = {@_};
903    
904 dpavlin 52 my $name = lc($arg->{'list'}) || confess "can't add list without name";
905     my $email = lc($arg->{'email'}) || confess "can't add list without e-mail";
906 dpavlin 66 my $aliases = lc($arg->{'aliases'}) || confess "can't add list without path to aliases file";
907    
908 dpavlin 47 my $from_addr = $arg->{'from'};
909 dpavlin 30
910     my $lists = $self->{'loader'}->find_class('lists');
911    
912 dpavlin 66 $self->_add_aliases(
913     list => $name,
914     email => $email,
915     aliases => $aliases,
916 dpavlin 68 ) || warn "can't add alias $email for list $name";
917 dpavlin 66
918 dpavlin 30 my $l = $lists->find_or_create({
919     name => $name,
920     email => $email,
921     });
922 dpavlin 47
923 dpavlin 30 croak "can't add list $name\n" unless ($l);
924    
925 dpavlin 47 if ($from_addr && $l->from_addr ne $from_addr) {
926     $l->from_addr($from_addr);
927     $l->update;
928     }
929    
930 dpavlin 30 $l->dbi_commit;
931    
932     return $l;
933    
934     }
935    
936    
937 dpavlin 66
938 dpavlin 30 =head2 _get_list
939    
940     Get list C<Class::DBI> object.
941    
942     my $list_obj = $nos->check_list('My list');
943    
944     Returns false on failure.
945    
946     =cut
947    
948     sub _get_list {
949     my $self = shift;
950    
951     my $name = shift || return;
952    
953 dpavlin 31 my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";
954 dpavlin 30
955 dpavlin 52 return $lists->search({ name => lc($name) })->first;
956 dpavlin 30 }
957    
958 dpavlin 70
959     =head2 _remove_alias
960    
961     Remove list alias
962    
963     my $ok = $nos->_remove_alias(
964     email => 'mylist@example.com',
965     aliases => '/etc/mail/mylist',
966     );
967    
968     Returns true if list is removed or false if list doesn't exist. Dies in case of error.
969    
970     =cut
971    
972     sub _remove_alias {
973     my $self = shift;
974    
975     my $arg = {@_};
976    
977     my $email = lc($arg->{'email'}) || confess "can't remove alias without email";
978     my $aliases = lc($arg->{'aliases'}) || confess "can't remove alias without list";
979    
980     my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
981    
982     if ($a->exists($email)) {
983     $a->delete($email) || croak "can't remove alias $email";
984     } else {
985     return 0;
986     }
987    
988     return 1;
989    
990     }
991    
992 dpavlin 39 ###
993     ### SOAP
994     ###
995 dpavlin 30
996 dpavlin 39 package Nos::SOAP;
997    
998 dpavlin 43 use Carp;
999    
1000 dpavlin 39 =head1 SOAP methods
1001    
1002     This methods are thin wrappers to provide SOAP calls. They are grouped in
1003     C<Nos::SOAP> package which is in same F<Nos.pm> module file.
1004    
1005     Usually, you want to use named variables in your SOAP calls if at all
1006     possible.
1007    
1008     However, if you have broken SOAP library (like PHP SOAP class from PEAR)
1009     you will want to use positional arguments (in same order as documented for
1010     methods below).
1011    
1012     =cut
1013    
1014     my $nos;
1015    
1016 dpavlin 66
1017     =head2 new
1018    
1019     Create new SOAP object
1020    
1021     my $soap = new Nos::SOAP(
1022     dsn => 'dbi:Pg:dbname=notices',
1023     user => 'dpavlin',
1024     passwd => '',
1025     debug => 1,
1026     verbose => 1,
1027     hash_len => 8,
1028     aliases => '/etc/aliases',
1029     );
1030    
1031 dpavlin 75 If you are writing SOAP server (like C<soap.cgi> example), you will need to
1032     call this method once to make new instance of Nos::SOAP and specify C<dsn>
1033     and options for it.
1034    
1035 dpavlin 66 =cut
1036    
1037 dpavlin 39 sub new {
1038     my $class = shift;
1039     my $self = {@_};
1040 dpavlin 66
1041     croak "need aliases parametar" unless ($self->{'aliases'});
1042    
1043 dpavlin 39 bless($self, $class);
1044    
1045     $nos = new Nos( @_ ) || die "can't create Nos object";
1046    
1047     $self ? return $self : return undef;
1048     }
1049    
1050    
1051 dpavlin 72 =head2 CreateList
1052 dpavlin 39
1053 dpavlin 72 $message_id = CreateList(
1054 dpavlin 39 list => 'My list',
1055 dpavlin 56 from => 'Name of my list',
1056 dpavlin 39 email => 'my-list@example.com'
1057     );
1058    
1059     =cut
1060    
1061 dpavlin 72 sub CreateList {
1062 dpavlin 39 my $self = shift;
1063    
1064 dpavlin 68 my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
1065 dpavlin 66
1066 dpavlin 39 if ($_[0] !~ m/^HASH/) {
1067 dpavlin 72 return $nos->create_list(
1068 dpavlin 56 list => $_[0], from => $_[1], email => $_[2],
1069 dpavlin 66 aliases => $aliases,
1070 dpavlin 39 );
1071     } else {
1072 dpavlin 72 return $nos->create_list( %{ shift @_ }, aliases => $aliases );
1073 dpavlin 39 }
1074     }
1075    
1076 dpavlin 43
1077 dpavlin 72 =head2 DropList
1078 dpavlin 63
1079 dpavlin 72 $ok = DropList(
1080 dpavlin 63 list => 'My list',
1081     );
1082    
1083     =cut
1084    
1085 dpavlin 72 sub DropList {
1086 dpavlin 63 my $self = shift;
1087    
1088 dpavlin 70 my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
1089    
1090 dpavlin 63 if ($_[0] !~ m/^HASH/) {
1091 dpavlin 72 return $nos->drop_list(
1092 dpavlin 63 list => $_[0],
1093 dpavlin 70 aliases => $aliases,
1094 dpavlin 63 );
1095     } else {
1096 dpavlin 72 return $nos->drop_list( %{ shift @_ }, aliases => $aliases );
1097 dpavlin 63 }
1098     }
1099    
1100 dpavlin 39 =head2 AddMemberToList
1101    
1102     $member_id = AddMemberToList(
1103 dpavlin 43 list => 'My list',
1104     email => 'e-mail@example.com',
1105 dpavlin 58 name => 'Full Name',
1106     ext_id => 42,
1107 dpavlin 39 );
1108    
1109     =cut
1110    
1111     sub AddMemberToList {
1112     my $self = shift;
1113    
1114     if ($_[0] !~ m/^HASH/) {
1115     return $nos->add_member_to_list(
1116 dpavlin 58 list => $_[0], email => $_[1], name => $_[2], ext_id => $_[4],
1117 dpavlin 39 );
1118     } else {
1119     return $nos->add_member_to_list( %{ shift @_ } );
1120     }
1121     }
1122    
1123 dpavlin 43
1124     =head2 ListMembers
1125    
1126     my @members = ListMembers(
1127     list => 'My list',
1128     );
1129    
1130     Returns array of hashes with user informations, see C<list_members>.
1131    
1132     =cut
1133    
1134     sub ListMembers {
1135     my $self = shift;
1136    
1137     my $list_name;
1138    
1139     if ($_[0] !~ m/^HASH/) {
1140     $list_name = shift;
1141     } else {
1142     $list_name = $_[0]->{'list'};
1143     }
1144    
1145 dpavlin 62 return [ $nos->list_members( list => $list_name ) ];
1146 dpavlin 43 }
1147    
1148 dpavlin 62
1149     =head2 DeleteMemberFromList
1150    
1151     $member_id = DeleteMemberFromList(
1152     list => 'My list',
1153     email => 'e-mail@example.com',
1154     );
1155    
1156     =cut
1157    
1158     sub DeleteMemberFromList {
1159     my $self = shift;
1160    
1161     if ($_[0] !~ m/^HASH/) {
1162     return $nos->delete_member_from_list(
1163     list => $_[0], email => $_[1],
1164     );
1165     } else {
1166     return $nos->delete_member_from_list( %{ shift @_ } );
1167     }
1168     }
1169    
1170    
1171 dpavlin 39 =head2 AddMessageToList
1172    
1173     $message_id = AddMessageToList(
1174     list => 'My list',
1175     message => 'From: My list...'
1176     );
1177    
1178     =cut
1179    
1180     sub AddMessageToList {
1181     my $self = shift;
1182    
1183     if ($_[0] !~ m/^HASH/) {
1184     return $nos->add_message_to_list(
1185     list => $_[0], message => $_[1],
1186     );
1187     } else {
1188     return $nos->add_message_to_list( %{ shift @_ } );
1189     }
1190     }
1191    
1192 dpavlin 78 =head2 MessagesReceived
1193 dpavlin 39
1194 dpavlin 78 Return statistics about received messages.
1195 dpavlin 74
1196     my @result = MessagesReceived(
1197     list => 'My list',
1198     email => 'jdoe@example.com',
1199 dpavlin 80 from_date => '2005-01-01 10:15:00',
1200     to_date => '2005-01-01 12:00:00',
1201     message => 0,
1202 dpavlin 74 );
1203    
1204 dpavlin 80 You must specify C<list> or C<email> or any combination of those two. Other
1205     parametars are optional.
1206 dpavlin 74
1207 dpavlin 76 For format of returned array element see C<received_messages>.
1208 dpavlin 74
1209 dpavlin 78 =cut
1210    
1211     sub MessagesReceived {
1212     my $self = shift;
1213    
1214     if ($_[0] !~ m/^HASH/) {
1215 dpavlin 79 die "need at least list or email" unless (scalar @_ < 2);
1216 dpavlin 78 return $nos->received_messages(
1217     list => $_[0], email => $_[1],
1218 dpavlin 80 from_date => $_[2], to_date => $_[3],
1219     message => $_[4]
1220 dpavlin 78 );
1221     } else {
1222 dpavlin 79 my $arg = shift;
1223     die "need list or email argument" unless ($arg->{'list'} || $arg->{'email'});
1224 dpavlin 78 return $nos->received_messages( $arg );
1225     }
1226     }
1227    
1228     ###
1229    
1230     =head1 UNIMPLEMENTED SOAP FUNCTIONS
1231    
1232     This is a stub for documentation of unimplemented functions.
1233    
1234 dpavlin 74 =head2 MessagesReceivedByDate
1235    
1236     =head2 MessagesReceivedByDateWithContent
1237    
1238 dpavlin 78 =head2 ReceivedMessageContent
1239 dpavlin 74
1240     Return content of received message.
1241    
1242     my $mail_body = ReceivedMessageContent( id => 42 );
1243    
1244    
1245    
1246    
1247     =head1 NOTE ON ARRAYS IN SOAP
1248    
1249     Returning arrays from SOAP calls is somewhat fuzzy (at least to me). It
1250     seems that SOAP::Lite client thinks that it has array with one element which
1251     is array of hashes with data.
1252    
1253 dpavlin 25 =head1 EXPORT
1254 dpavlin 20
1255 dpavlin 27 Nothing.
1256 dpavlin 20
1257     =head1 SEE ALSO
1258    
1259     mailman, ezmlm, sympa, L<Mail::Salsa>
1260    
1261 dpavlin 25
1262 dpavlin 20 =head1 AUTHOR
1263    
1264     Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
1265    
1266 dpavlin 25
1267 dpavlin 20 =head1 COPYRIGHT AND LICENSE
1268    
1269     Copyright (C) 2005 by Dobrica Pavlinusic
1270    
1271     This library is free software; you can redistribute it and/or modify
1272     it under the same terms as Perl itself, either Perl version 5.8.4 or,
1273     at your option, any later version of Perl 5 you may have available.
1274    
1275    
1276     =cut
1277 dpavlin 39
1278     1;

  ViewVC Help
Powered by ViewVC 1.1.26