/[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 81 - (show annotations)
Fri Aug 26 06:13:44 2005 UTC (18 years, 6 months ago) by dpavlin
File size: 29084 byte(s)
fix ordering by date, fix tests and notice about dates beeing inclusive

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

  ViewVC Help
Powered by ViewVC 1.1.26