/[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

Contents of /trunk/Nos.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.26