/[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 68 - (hide annotations)
Mon Aug 1 08:59:36 2005 UTC (18 years, 7 months ago) by dpavlin
File size: 24109 byte(s)
_add_aliases now updates alias if it allready exists, added debug flag to SAOP tests

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

  ViewVC Help
Powered by ViewVC 1.1.26