/[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 75 - (hide annotations)
Wed Aug 24 21:27:40 2005 UTC (18 years, 6 months ago) by dpavlin
File size: 27549 byte(s)
beginning of received_messages, send_queued_messages now returns number of
messages succesfully sent, driver can now be any Email::Send driver (including
Email::Send::Test used for tests), documentation improvements

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

  ViewVC Help
Powered by ViewVC 1.1.26