/[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 76 - (hide annotations)
Wed Aug 24 22:11:00 2005 UTC (18 years, 6 months ago) by dpavlin
File size: 27593 byte(s)
100 tests and counting :-) Added test for each sent message and generating
replies and partly tested that

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

  ViewVC Help
Powered by ViewVC 1.1.26