/[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 71 - (hide annotations)
Mon Aug 22 19:25:24 2005 UTC (18 years, 6 months ago) by dpavlin
File size: 25249 byte(s)
check if aliases file is writable

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

  ViewVC Help
Powered by ViewVC 1.1.26