/[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 80 - (show annotations)
Fri Aug 26 05:38:00 2005 UTC (18 years, 6 months ago) by dpavlin
File size: 29254 byte(s)
implemented date rangers and whole message content for received_messages,
need to fix tests

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 Each element in returned array will have following structure:
743
744 my $row = {
745 id => 42, # unique ID of received message
746 list => 'My list', # useful if filtering by email
747 ext_id => 9999, # ext_id from message sender
748 email => 'jdoe@example.com', # e-mail of message sender
749 bounced => 0, # true if message is bounce
750 date => '2005-08-24 18:57:24', # date of receival in ISO format
751 }
752
753 If you specified C<message> option, this hash will also have C<message> key
754 which will contain whole received message.
755
756 =cut
757
758 sub received_messages {
759 my $self = shift;
760
761 my $arg = {@_} if (@_);
762
763 # croak "need list name or email" unless ($arg->{'list'} || $arg->{'email'});
764
765 my $sql = qq{
766 select
767 received.id as id,
768 lists.name as list,
769 users.ext_id as ext_id,
770 users.email as email,
771 };
772 $sql .= qq{ message,} if ($arg->{'message'});
773 $sql .= qq{
774 bounced,received.date as date
775 from received
776 join lists on lists.id = list_id
777 join users on users.id = user_id
778 };
779
780 my $order = qq{ order by date desc };
781
782 my $where;
783
784 $where->{'lists.name'} = lc($arg->{'list'}) if ($arg->{'list'});
785 $where->{'users.email'} = lc($arg->{'email'}) if ($arg->{'email'});
786 $where->{'received.date'} = { '>=', $arg->{'date_from'} } if ($arg->{'date_from'});
787 $where->{'received.date'} = { '<=', $arg->{'date_to'} } if ($arg->{'date_to'});
788
789 # hum, yammy one-liner
790 my($stmt, @bind) = SQL::Abstract->new->where($where);
791
792 my $dbh = $self->{'loader'}->find_class('received')->db_Main;
793
794 my $sth = $dbh->prepare($sql . $stmt . $order);
795 $sth->execute(@bind);
796 return $sth->fetchall_hash;
797 }
798
799
800 =head1 INTERNAL METHODS
801
802 Beware of dragons! You shouldn't need to call those methods directly.
803
804
805 =head2 _add_aliases
806
807 Add or update alias in C</etc/aliases> (or equivalent) file for selected list
808
809 my $ok = $nos->add_aliases(
810 list => 'My list',
811 email => 'my-list@example.com',
812 aliases => '/etc/mail/mylist',
813 archive => '/path/to/mbox/archive',
814
815 );
816
817 C<archive> parametar is optional.
818
819 Return false on failure.
820
821 =cut
822
823 sub _add_aliases {
824 my $self = shift;
825
826 my $arg = {@_};
827
828 foreach my $o (qw/list email aliases/) {
829 croak "need $o option" unless ($arg->{$o});
830 }
831
832 my $aliases = $arg->{'aliases'};
833 my $email = $arg->{'email'};
834 my $list = $arg->{'list'};
835
836 unless (-e $aliases) {
837 warn "aliases file $aliases doesn't exist, creating empty\n";
838 open(my $fh, '>', $aliases) || croak "can't create $aliases: $!";
839 close($fh);
840 chmod 0777, $aliases || warn "can't change permission to 0777";
841 }
842
843 die "FATAL: aliases file $aliases is not writable\n" unless (-w $aliases);
844
845 my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
846
847 my $target = '';
848
849 if (my $archive = $arg->{'archive'}) {
850 $target .= "$archive, ";
851
852 if (! -e $archive) {
853 warn "please make sure that file $archive is writable for your e-mail user (defaulting to bad 777 permission for now)";
854
855 open(my $fh, '>', $archive) || croak "can't create archive file $archive: $!";
856 close($fh);
857 chmod 0777, $archive || croak "can't chmod archive file $archive to 0777: $!";
858 }
859 }
860
861 # resolve my path to absolute one
862 my $self_path = abs_path($0);
863 $self_path =~ s#/[^/]+$##;
864 $self_path =~ s#/t/*$#/#;
865
866 $target .= qq#| cd $self_path && ./sender.pl --inbox="$list"#;
867
868 if ($a->exists($email)) {
869 $a->update($email, $target) or croak "can't update alias ".$a->error_check;
870 } else {
871 $a->append($email, $target) or croak "can't add alias ".$a->error_check;
872 }
873
874 #$a->write($aliases) or croak "can't save aliases $aliases ".$a->error_check;
875
876 return 1;
877 }
878
879 =head2 _add_list
880
881 Create new list
882
883 my $list_obj = $nos->_add_list(
884 list => 'My list',
885 from => 'Outgoing from comment',
886 email => 'my-list@example.com',
887 aliases => '/etc/mail/mylist',
888 );
889
890 Returns C<Class::DBI> object for created list.
891
892 C<email> address can be with domain or without it if your
893 MTA appends it. There is no checking for validity of your
894 list e-mail. Flexibility comes with resposibility, so please
895 feed correct (and configured) return addresses.
896
897 =cut
898
899 sub _add_list {
900 my $self = shift;
901
902 my $arg = {@_};
903
904 my $name = lc($arg->{'list'}) || confess "can't add list without name";
905 my $email = lc($arg->{'email'}) || confess "can't add list without e-mail";
906 my $aliases = lc($arg->{'aliases'}) || confess "can't add list without path to aliases file";
907
908 my $from_addr = $arg->{'from'};
909
910 my $lists = $self->{'loader'}->find_class('lists');
911
912 $self->_add_aliases(
913 list => $name,
914 email => $email,
915 aliases => $aliases,
916 ) || warn "can't add alias $email for list $name";
917
918 my $l = $lists->find_or_create({
919 name => $name,
920 email => $email,
921 });
922
923 croak "can't add list $name\n" unless ($l);
924
925 if ($from_addr && $l->from_addr ne $from_addr) {
926 $l->from_addr($from_addr);
927 $l->update;
928 }
929
930 $l->dbi_commit;
931
932 return $l;
933
934 }
935
936
937
938 =head2 _get_list
939
940 Get list C<Class::DBI> object.
941
942 my $list_obj = $nos->check_list('My list');
943
944 Returns false on failure.
945
946 =cut
947
948 sub _get_list {
949 my $self = shift;
950
951 my $name = shift || return;
952
953 my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";
954
955 return $lists->search({ name => lc($name) })->first;
956 }
957
958
959 =head2 _remove_alias
960
961 Remove list alias
962
963 my $ok = $nos->_remove_alias(
964 email => 'mylist@example.com',
965 aliases => '/etc/mail/mylist',
966 );
967
968 Returns true if list is removed or false if list doesn't exist. Dies in case of error.
969
970 =cut
971
972 sub _remove_alias {
973 my $self = shift;
974
975 my $arg = {@_};
976
977 my $email = lc($arg->{'email'}) || confess "can't remove alias without email";
978 my $aliases = lc($arg->{'aliases'}) || confess "can't remove alias without list";
979
980 my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
981
982 if ($a->exists($email)) {
983 $a->delete($email) || croak "can't remove alias $email";
984 } else {
985 return 0;
986 }
987
988 return 1;
989
990 }
991
992 ###
993 ### SOAP
994 ###
995
996 package Nos::SOAP;
997
998 use Carp;
999
1000 =head1 SOAP methods
1001
1002 This methods are thin wrappers to provide SOAP calls. They are grouped in
1003 C<Nos::SOAP> package which is in same F<Nos.pm> module file.
1004
1005 Usually, you want to use named variables in your SOAP calls if at all
1006 possible.
1007
1008 However, if you have broken SOAP library (like PHP SOAP class from PEAR)
1009 you will want to use positional arguments (in same order as documented for
1010 methods below).
1011
1012 =cut
1013
1014 my $nos;
1015
1016
1017 =head2 new
1018
1019 Create new SOAP object
1020
1021 my $soap = new Nos::SOAP(
1022 dsn => 'dbi:Pg:dbname=notices',
1023 user => 'dpavlin',
1024 passwd => '',
1025 debug => 1,
1026 verbose => 1,
1027 hash_len => 8,
1028 aliases => '/etc/aliases',
1029 );
1030
1031 If you are writing SOAP server (like C<soap.cgi> example), you will need to
1032 call this method once to make new instance of Nos::SOAP and specify C<dsn>
1033 and options for it.
1034
1035 =cut
1036
1037 sub new {
1038 my $class = shift;
1039 my $self = {@_};
1040
1041 croak "need aliases parametar" unless ($self->{'aliases'});
1042
1043 bless($self, $class);
1044
1045 $nos = new Nos( @_ ) || die "can't create Nos object";
1046
1047 $self ? return $self : return undef;
1048 }
1049
1050
1051 =head2 CreateList
1052
1053 $message_id = CreateList(
1054 list => 'My list',
1055 from => 'Name of my list',
1056 email => 'my-list@example.com'
1057 );
1058
1059 =cut
1060
1061 sub CreateList {
1062 my $self = shift;
1063
1064 my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
1065
1066 if ($_[0] !~ m/^HASH/) {
1067 return $nos->create_list(
1068 list => $_[0], from => $_[1], email => $_[2],
1069 aliases => $aliases,
1070 );
1071 } else {
1072 return $nos->create_list( %{ shift @_ }, aliases => $aliases );
1073 }
1074 }
1075
1076
1077 =head2 DropList
1078
1079 $ok = DropList(
1080 list => 'My list',
1081 );
1082
1083 =cut
1084
1085 sub DropList {
1086 my $self = shift;
1087
1088 my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
1089
1090 if ($_[0] !~ m/^HASH/) {
1091 return $nos->drop_list(
1092 list => $_[0],
1093 aliases => $aliases,
1094 );
1095 } else {
1096 return $nos->drop_list( %{ shift @_ }, aliases => $aliases );
1097 }
1098 }
1099
1100 =head2 AddMemberToList
1101
1102 $member_id = AddMemberToList(
1103 list => 'My list',
1104 email => 'e-mail@example.com',
1105 name => 'Full Name',
1106 ext_id => 42,
1107 );
1108
1109 =cut
1110
1111 sub AddMemberToList {
1112 my $self = shift;
1113
1114 if ($_[0] !~ m/^HASH/) {
1115 return $nos->add_member_to_list(
1116 list => $_[0], email => $_[1], name => $_[2], ext_id => $_[4],
1117 );
1118 } else {
1119 return $nos->add_member_to_list( %{ shift @_ } );
1120 }
1121 }
1122
1123
1124 =head2 ListMembers
1125
1126 my @members = ListMembers(
1127 list => 'My list',
1128 );
1129
1130 Returns array of hashes with user informations, see C<list_members>.
1131
1132 =cut
1133
1134 sub ListMembers {
1135 my $self = shift;
1136
1137 my $list_name;
1138
1139 if ($_[0] !~ m/^HASH/) {
1140 $list_name = shift;
1141 } else {
1142 $list_name = $_[0]->{'list'};
1143 }
1144
1145 return [ $nos->list_members( list => $list_name ) ];
1146 }
1147
1148
1149 =head2 DeleteMemberFromList
1150
1151 $member_id = DeleteMemberFromList(
1152 list => 'My list',
1153 email => 'e-mail@example.com',
1154 );
1155
1156 =cut
1157
1158 sub DeleteMemberFromList {
1159 my $self = shift;
1160
1161 if ($_[0] !~ m/^HASH/) {
1162 return $nos->delete_member_from_list(
1163 list => $_[0], email => $_[1],
1164 );
1165 } else {
1166 return $nos->delete_member_from_list( %{ shift @_ } );
1167 }
1168 }
1169
1170
1171 =head2 AddMessageToList
1172
1173 $message_id = AddMessageToList(
1174 list => 'My list',
1175 message => 'From: My list...'
1176 );
1177
1178 =cut
1179
1180 sub AddMessageToList {
1181 my $self = shift;
1182
1183 if ($_[0] !~ m/^HASH/) {
1184 return $nos->add_message_to_list(
1185 list => $_[0], message => $_[1],
1186 );
1187 } else {
1188 return $nos->add_message_to_list( %{ shift @_ } );
1189 }
1190 }
1191
1192 =head2 MessagesReceived
1193
1194 Return statistics about received messages.
1195
1196 my @result = MessagesReceived(
1197 list => 'My list',
1198 email => 'jdoe@example.com',
1199 from_date => '2005-01-01 10:15:00',
1200 to_date => '2005-01-01 12:00:00',
1201 message => 0,
1202 );
1203
1204 You must specify C<list> or C<email> or any combination of those two. Other
1205 parametars are optional.
1206
1207 For format of returned array element see C<received_messages>.
1208
1209 =cut
1210
1211 sub MessagesReceived {
1212 my $self = shift;
1213
1214 if ($_[0] !~ m/^HASH/) {
1215 die "need at least list or email" unless (scalar @_ < 2);
1216 return $nos->received_messages(
1217 list => $_[0], email => $_[1],
1218 from_date => $_[2], to_date => $_[3],
1219 message => $_[4]
1220 );
1221 } else {
1222 my $arg = shift;
1223 die "need list or email argument" unless ($arg->{'list'} || $arg->{'email'});
1224 return $nos->received_messages( $arg );
1225 }
1226 }
1227
1228 ###
1229
1230 =head1 UNIMPLEMENTED SOAP FUNCTIONS
1231
1232 This is a stub for documentation of unimplemented functions.
1233
1234 =head2 MessagesReceivedByDate
1235
1236 =head2 MessagesReceivedByDateWithContent
1237
1238 =head2 ReceivedMessageContent
1239
1240 Return content of received message.
1241
1242 my $mail_body = ReceivedMessageContent( id => 42 );
1243
1244
1245
1246
1247 =head1 NOTE ON ARRAYS IN SOAP
1248
1249 Returning arrays from SOAP calls is somewhat fuzzy (at least to me). It
1250 seems that SOAP::Lite client thinks that it has array with one element which
1251 is array of hashes with data.
1252
1253 =head1 EXPORT
1254
1255 Nothing.
1256
1257 =head1 SEE ALSO
1258
1259 mailman, ezmlm, sympa, L<Mail::Salsa>
1260
1261
1262 =head1 AUTHOR
1263
1264 Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
1265
1266
1267 =head1 COPYRIGHT AND LICENSE
1268
1269 Copyright (C) 2005 by Dobrica Pavlinusic
1270
1271 This library is free software; you can redistribute it and/or modify
1272 it under the same terms as Perl itself, either Perl version 5.8.4 or,
1273 at your option, any later version of Perl 5 you may have available.
1274
1275
1276 =cut
1277
1278 1;

  ViewVC Help
Powered by ViewVC 1.1.26