/[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 70 - (hide annotations)
Tue Aug 2 19:41:28 2005 UTC (18 years, 7 months ago) by dpavlin
File size: 25173 byte(s)
added _remove_alias and use it when deleting list

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 68 Add or update alias in C</etc/aliases> (or equivavlent) 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     my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
739    
740     my $target = '';
741    
742     if (my $archive = $arg->{'archive'}) {
743     $target .= "$archive, ";
744    
745     if (! -e $archive) {
746     warn "please make sure that file $archive is writable for your e-mail user (defaulting to bad 777 permission for now)";
747    
748     open(my $fh, '>', $archive) || croak "can't create archive file $archive: $!";
749     close($fh);
750     chmod 0777, $archive || croak "can't chmod archive file $archive to 0777: $!";
751     }
752     }
753    
754     # resolve my path to absolute one
755     my $self_path = abs_path($0);
756     $self_path =~ s#/[^/]+$##;
757     $self_path =~ s#/t/*$#/#;
758    
759 dpavlin 68 $target .= qq#| cd $self_path && ./sender.pl --inbox="$list"#;
760 dpavlin 66
761 dpavlin 68 if ($a->exists($email)) {
762     $a->update($email, $target) or croak "can't update alias ".$a->error_check;
763     } else {
764     $a->append($email, $target) or croak "can't add alias ".$a->error_check;
765 dpavlin 66 }
766    
767 dpavlin 70 #$a->write($aliases) or croak "can't save aliases $aliases ".$a->error_check;
768    
769 dpavlin 66 return 1;
770     }
771    
772 dpavlin 30 =head2 _add_list
773    
774     Create new list
775    
776     my $list_obj = $nos->_add_list(
777     list => 'My list',
778 dpavlin 47 from => 'Outgoing from comment',
779 dpavlin 30 email => 'my-list@example.com',
780 dpavlin 66 aliases => '/etc/mail/mylist',
781 dpavlin 30 );
782    
783     Returns C<Class::DBI> object for created list.
784    
785 dpavlin 38 C<email> address can be with domain or without it if your
786     MTA appends it. There is no checking for validity of your
787     list e-mail. Flexibility comes with resposibility, so please
788     feed correct (and configured) return addresses.
789    
790 dpavlin 30 =cut
791    
792     sub _add_list {
793     my $self = shift;
794    
795     my $arg = {@_};
796    
797 dpavlin 52 my $name = lc($arg->{'list'}) || confess "can't add list without name";
798     my $email = lc($arg->{'email'}) || confess "can't add list without e-mail";
799 dpavlin 66 my $aliases = lc($arg->{'aliases'}) || confess "can't add list without path to aliases file";
800    
801 dpavlin 47 my $from_addr = $arg->{'from'};
802 dpavlin 30
803     my $lists = $self->{'loader'}->find_class('lists');
804    
805 dpavlin 66 $self->_add_aliases(
806     list => $name,
807     email => $email,
808     aliases => $aliases,
809 dpavlin 68 ) || warn "can't add alias $email for list $name";
810 dpavlin 66
811 dpavlin 30 my $l = $lists->find_or_create({
812     name => $name,
813     email => $email,
814     });
815 dpavlin 47
816 dpavlin 30 croak "can't add list $name\n" unless ($l);
817    
818 dpavlin 47 if ($from_addr && $l->from_addr ne $from_addr) {
819     $l->from_addr($from_addr);
820     $l->update;
821     }
822    
823 dpavlin 30 $l->dbi_commit;
824    
825     return $l;
826    
827     }
828    
829    
830 dpavlin 66
831 dpavlin 30 =head2 _get_list
832    
833     Get list C<Class::DBI> object.
834    
835     my $list_obj = $nos->check_list('My list');
836    
837     Returns false on failure.
838    
839     =cut
840    
841     sub _get_list {
842     my $self = shift;
843    
844     my $name = shift || return;
845    
846 dpavlin 31 my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";
847 dpavlin 30
848 dpavlin 52 return $lists->search({ name => lc($name) })->first;
849 dpavlin 30 }
850    
851 dpavlin 70
852     =head2 _remove_alias
853    
854     Remove list alias
855    
856     my $ok = $nos->_remove_alias(
857     email => 'mylist@example.com',
858     aliases => '/etc/mail/mylist',
859     );
860    
861     Returns true if list is removed or false if list doesn't exist. Dies in case of error.
862    
863     =cut
864    
865     sub _remove_alias {
866     my $self = shift;
867    
868     my $arg = {@_};
869    
870     my $email = lc($arg->{'email'}) || confess "can't remove alias without email";
871     my $aliases = lc($arg->{'aliases'}) || confess "can't remove alias without list";
872    
873     my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
874    
875     if ($a->exists($email)) {
876     $a->delete($email) || croak "can't remove alias $email";
877     } else {
878     return 0;
879     }
880    
881     return 1;
882    
883     }
884    
885 dpavlin 39 ###
886     ### SOAP
887     ###
888 dpavlin 30
889 dpavlin 39 package Nos::SOAP;
890    
891 dpavlin 43 use Carp;
892    
893 dpavlin 39 =head1 SOAP methods
894    
895     This methods are thin wrappers to provide SOAP calls. They are grouped in
896     C<Nos::SOAP> package which is in same F<Nos.pm> module file.
897    
898     Usually, you want to use named variables in your SOAP calls if at all
899     possible.
900    
901     However, if you have broken SOAP library (like PHP SOAP class from PEAR)
902     you will want to use positional arguments (in same order as documented for
903     methods below).
904    
905     =cut
906    
907     my $nos;
908    
909 dpavlin 66
910     =head2 new
911    
912     Create new SOAP object
913    
914     my $soap = new Nos::SOAP(
915     dsn => 'dbi:Pg:dbname=notices',
916     user => 'dpavlin',
917     passwd => '',
918     debug => 1,
919     verbose => 1,
920     hash_len => 8,
921     aliases => '/etc/aliases',
922     );
923    
924     =cut
925    
926 dpavlin 39 sub new {
927     my $class = shift;
928     my $self = {@_};
929 dpavlin 66
930     croak "need aliases parametar" unless ($self->{'aliases'});
931    
932 dpavlin 39 bless($self, $class);
933    
934     $nos = new Nos( @_ ) || die "can't create Nos object";
935    
936     $self ? return $self : return undef;
937     }
938    
939    
940     =head2 NewList
941    
942     $message_id = NewList(
943     list => 'My list',
944 dpavlin 56 from => 'Name of my list',
945 dpavlin 39 email => 'my-list@example.com'
946     );
947    
948     =cut
949    
950     sub NewList {
951     my $self = shift;
952    
953 dpavlin 68 my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
954 dpavlin 66
955 dpavlin 39 if ($_[0] !~ m/^HASH/) {
956     return $nos->new_list(
957 dpavlin 56 list => $_[0], from => $_[1], email => $_[2],
958 dpavlin 66 aliases => $aliases,
959 dpavlin 39 );
960     } else {
961 dpavlin 66 return $nos->new_list( %{ shift @_ }, aliases => $aliases );
962 dpavlin 39 }
963     }
964    
965 dpavlin 43
966 dpavlin 63 =head2 DeleteList
967    
968     $ok = DeleteList(
969     list => 'My list',
970     );
971    
972     =cut
973    
974     sub DeleteList {
975     my $self = shift;
976    
977 dpavlin 70 my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
978    
979 dpavlin 63 if ($_[0] !~ m/^HASH/) {
980     return $nos->delete_list(
981     list => $_[0],
982 dpavlin 70 aliases => $aliases,
983 dpavlin 63 );
984     } else {
985 dpavlin 70 return $nos->delete_list( %{ shift @_ }, aliases => $aliases );
986 dpavlin 63 }
987     }
988    
989 dpavlin 39 =head2 AddMemberToList
990    
991     $member_id = AddMemberToList(
992 dpavlin 43 list => 'My list',
993     email => 'e-mail@example.com',
994 dpavlin 58 name => 'Full Name',
995     ext_id => 42,
996 dpavlin 39 );
997    
998     =cut
999    
1000     sub AddMemberToList {
1001     my $self = shift;
1002    
1003     if ($_[0] !~ m/^HASH/) {
1004     return $nos->add_member_to_list(
1005 dpavlin 58 list => $_[0], email => $_[1], name => $_[2], ext_id => $_[4],
1006 dpavlin 39 );
1007     } else {
1008     return $nos->add_member_to_list( %{ shift @_ } );
1009     }
1010     }
1011    
1012 dpavlin 43
1013     =head2 ListMembers
1014    
1015     my @members = ListMembers(
1016     list => 'My list',
1017     );
1018    
1019     Returns array of hashes with user informations, see C<list_members>.
1020    
1021 dpavlin 62 Returning arrays from SOAP calls is somewhat fuzzy (at least to me). It
1022     seems that SOAP::Lite client thinks that it has array with one element which
1023     is array of hashes with data.
1024    
1025 dpavlin 43 =cut
1026    
1027     sub ListMembers {
1028     my $self = shift;
1029    
1030     my $list_name;
1031    
1032     if ($_[0] !~ m/^HASH/) {
1033     $list_name = shift;
1034     } else {
1035     $list_name = $_[0]->{'list'};
1036     }
1037    
1038 dpavlin 62 return [ $nos->list_members( list => $list_name ) ];
1039 dpavlin 43 }
1040    
1041 dpavlin 62
1042     =head2 DeleteMemberFromList
1043    
1044     $member_id = DeleteMemberFromList(
1045     list => 'My list',
1046     email => 'e-mail@example.com',
1047     );
1048    
1049     =cut
1050    
1051     sub DeleteMemberFromList {
1052     my $self = shift;
1053    
1054     if ($_[0] !~ m/^HASH/) {
1055     return $nos->delete_member_from_list(
1056     list => $_[0], email => $_[1],
1057     );
1058     } else {
1059     return $nos->delete_member_from_list( %{ shift @_ } );
1060     }
1061     }
1062    
1063    
1064 dpavlin 39 =head2 AddMessageToList
1065    
1066     $message_id = AddMessageToList(
1067     list => 'My list',
1068     message => 'From: My list...'
1069     );
1070    
1071     =cut
1072    
1073     sub AddMessageToList {
1074     my $self = shift;
1075    
1076     if ($_[0] !~ m/^HASH/) {
1077     return $nos->add_message_to_list(
1078     list => $_[0], message => $_[1],
1079     );
1080     } else {
1081     return $nos->add_message_to_list( %{ shift @_ } );
1082     }
1083     }
1084    
1085    
1086     ###
1087    
1088 dpavlin 25 =head1 EXPORT
1089 dpavlin 20
1090 dpavlin 27 Nothing.
1091 dpavlin 20
1092     =head1 SEE ALSO
1093    
1094     mailman, ezmlm, sympa, L<Mail::Salsa>
1095    
1096 dpavlin 25
1097 dpavlin 20 =head1 AUTHOR
1098    
1099     Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
1100    
1101 dpavlin 25
1102 dpavlin 20 =head1 COPYRIGHT AND LICENSE
1103    
1104     Copyright (C) 2005 by Dobrica Pavlinusic
1105    
1106     This library is free software; you can redistribute it and/or modify
1107     it under the same terms as Perl itself, either Perl version 5.8.4 or,
1108     at your option, any later version of Perl 5 you may have available.
1109    
1110    
1111     =cut
1112 dpavlin 39
1113     1;

  ViewVC Help
Powered by ViewVC 1.1.26