/[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 83 - (show annotations)
Mon Aug 29 14:53:53 2005 UTC (18 years, 6 months ago) by dpavlin
File size: 29176 byte(s)
fixed small (grave) bug in named parametars

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 # remove hostname from email to make Postfix's postalias happy
872 $email =~ s/@.+//;
873
874 if ($a->exists($email)) {
875 $a->update($email, $target) or croak "can't update alias ".$a->error_check;
876 } else {
877 $a->append($email, $target) or croak "can't add alias ".$a->error_check;
878 }
879
880 #$a->write($aliases) or croak "can't save aliases $aliases ".$a->error_check;
881
882 return 1;
883 }
884
885 =head2 _add_list
886
887 Create new list
888
889 my $list_obj = $nos->_add_list(
890 list => 'My list',
891 from => 'Outgoing from comment',
892 email => 'my-list@example.com',
893 aliases => '/etc/mail/mylist',
894 );
895
896 Returns C<Class::DBI> object for created list.
897
898 C<email> address can be with domain or without it if your
899 MTA appends it. There is no checking for validity of your
900 list e-mail. Flexibility comes with resposibility, so please
901 feed correct (and configured) return addresses.
902
903 =cut
904
905 sub _add_list {
906 my $self = shift;
907
908 my $arg = {@_};
909
910 my $name = lc($arg->{'list'}) || confess "can't add list without name";
911 my $email = lc($arg->{'email'}) || confess "can't add list without e-mail";
912 my $aliases = lc($arg->{'aliases'}) || confess "can't add list without path to aliases file";
913
914 my $from_addr = $arg->{'from'};
915
916 my $lists = $self->{'loader'}->find_class('lists');
917
918 $self->_add_aliases(
919 list => $name,
920 email => $email,
921 aliases => $aliases,
922 ) || warn "can't add alias $email for list $name";
923
924 my $l = $lists->find_or_create({
925 name => $name,
926 email => $email,
927 });
928
929 croak "can't add list $name\n" unless ($l);
930
931 if ($from_addr && $l->from_addr ne $from_addr) {
932 $l->from_addr($from_addr);
933 $l->update;
934 }
935
936 $l->dbi_commit;
937
938 return $l;
939
940 }
941
942
943
944 =head2 _get_list
945
946 Get list C<Class::DBI> object.
947
948 my $list_obj = $nos->check_list('My list');
949
950 Returns false on failure.
951
952 =cut
953
954 sub _get_list {
955 my $self = shift;
956
957 my $name = shift || return;
958
959 my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";
960
961 return $lists->search({ name => lc($name) })->first;
962 }
963
964
965 =head2 _remove_alias
966
967 Remove list alias
968
969 my $ok = $nos->_remove_alias(
970 email => 'mylist@example.com',
971 aliases => '/etc/mail/mylist',
972 );
973
974 Returns true if list is removed or false if list doesn't exist. Dies in case of error.
975
976 =cut
977
978 sub _remove_alias {
979 my $self = shift;
980
981 my $arg = {@_};
982
983 my $email = lc($arg->{'email'}) || confess "can't remove alias without email";
984 my $aliases = lc($arg->{'aliases'}) || confess "can't remove alias without list";
985
986 my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
987
988 if ($a->exists($email)) {
989 $a->delete($email) || croak "can't remove alias $email";
990 } else {
991 return 0;
992 }
993
994 return 1;
995
996 }
997
998 ###
999 ### SOAP
1000 ###
1001
1002 package Nos::SOAP;
1003
1004 use Carp;
1005
1006 =head1 SOAP methods
1007
1008 This methods are thin wrappers to provide SOAP calls. They are grouped in
1009 C<Nos::SOAP> package which is in same F<Nos.pm> module file.
1010
1011 Usually, you want to use named variables in your SOAP calls if at all
1012 possible.
1013
1014 However, if you have broken SOAP library (like PHP SOAP class from PEAR)
1015 you will want to use positional arguments (in same order as documented for
1016 methods below).
1017
1018 =cut
1019
1020 my $nos;
1021
1022
1023 =head2 new
1024
1025 Create new SOAP object
1026
1027 my $soap = new Nos::SOAP(
1028 dsn => 'dbi:Pg:dbname=notices',
1029 user => 'dpavlin',
1030 passwd => '',
1031 debug => 1,
1032 verbose => 1,
1033 hash_len => 8,
1034 aliases => '/etc/aliases',
1035 );
1036
1037 If you are writing SOAP server (like C<soap.cgi> example), you will need to
1038 call this method once to make new instance of Nos::SOAP and specify C<dsn>
1039 and options for it.
1040
1041 =cut
1042
1043 sub new {
1044 my $class = shift;
1045 my $self = {@_};
1046
1047 croak "need aliases parametar" unless ($self->{'aliases'});
1048
1049 bless($self, $class);
1050
1051 $nos = new Nos( @_ ) || die "can't create Nos object";
1052
1053 $self ? return $self : return undef;
1054 }
1055
1056
1057 =head2 CreateList
1058
1059 $message_id = CreateList(
1060 list => 'My list',
1061 from => 'Name of my list',
1062 email => 'my-list@example.com'
1063 );
1064
1065 =cut
1066
1067 sub CreateList {
1068 my $self = shift;
1069
1070 my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
1071
1072 if ($_[0] !~ m/^HASH/) {
1073 return $nos->create_list(
1074 list => $_[0], from => $_[1], email => $_[2],
1075 aliases => $aliases,
1076 );
1077 } else {
1078 return $nos->create_list( %{ shift @_ }, aliases => $aliases );
1079 }
1080 }
1081
1082
1083 =head2 DropList
1084
1085 $ok = DropList(
1086 list => 'My list',
1087 );
1088
1089 =cut
1090
1091 sub DropList {
1092 my $self = shift;
1093
1094 my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
1095
1096 if ($_[0] !~ m/^HASH/) {
1097 return $nos->drop_list(
1098 list => $_[0],
1099 aliases => $aliases,
1100 );
1101 } else {
1102 return $nos->drop_list( %{ shift @_ }, aliases => $aliases );
1103 }
1104 }
1105
1106 =head2 AddMemberToList
1107
1108 $member_id = AddMemberToList(
1109 list => 'My list',
1110 email => 'e-mail@example.com',
1111 name => 'Full Name',
1112 ext_id => 42,
1113 );
1114
1115 =cut
1116
1117 sub AddMemberToList {
1118 my $self = shift;
1119
1120 if ($_[0] !~ m/^HASH/) {
1121 return $nos->add_member_to_list(
1122 list => $_[0], email => $_[1], name => $_[2], ext_id => $_[4],
1123 );
1124 } else {
1125 return $nos->add_member_to_list( %{ shift @_ } );
1126 }
1127 }
1128
1129
1130 =head2 ListMembers
1131
1132 my @members = ListMembers(
1133 list => 'My list',
1134 );
1135
1136 Returns array of hashes with user informations, see C<list_members>.
1137
1138 =cut
1139
1140 sub ListMembers {
1141 my $self = shift;
1142
1143 my $list_name;
1144
1145 if ($_[0] !~ m/^HASH/) {
1146 $list_name = shift;
1147 } else {
1148 $list_name = $_[0]->{'list'};
1149 }
1150
1151 return [ $nos->list_members( list => $list_name ) ];
1152 }
1153
1154
1155 =head2 DeleteMemberFromList
1156
1157 $member_id = DeleteMemberFromList(
1158 list => 'My list',
1159 email => 'e-mail@example.com',
1160 );
1161
1162 =cut
1163
1164 sub DeleteMemberFromList {
1165 my $self = shift;
1166
1167 if ($_[0] !~ m/^HASH/) {
1168 return $nos->delete_member_from_list(
1169 list => $_[0], email => $_[1],
1170 );
1171 } else {
1172 return $nos->delete_member_from_list( %{ shift @_ } );
1173 }
1174 }
1175
1176
1177 =head2 AddMessageToList
1178
1179 $message_id = AddMessageToList(
1180 list => 'My list',
1181 message => 'From: My list...'
1182 );
1183
1184 =cut
1185
1186 sub AddMessageToList {
1187 my $self = shift;
1188
1189 if ($_[0] !~ m/^HASH/) {
1190 return $nos->add_message_to_list(
1191 list => $_[0], message => $_[1],
1192 );
1193 } else {
1194 return $nos->add_message_to_list( %{ shift @_ } );
1195 }
1196 }
1197
1198 =head2 MessagesReceived
1199
1200 Return statistics about received messages.
1201
1202 my @result = MessagesReceived(
1203 list => 'My list',
1204 email => 'jdoe@example.com',
1205 from_date => '2005-01-01 10:15:00',
1206 to_date => '2005-01-01 12:00:00',
1207 message => 0,
1208 );
1209
1210 You must specify C<list> or C<email> or any combination of those two. Other
1211 parametars are optional.
1212
1213 For format of returned array element see C<received_messages>.
1214
1215 =cut
1216
1217 sub MessagesReceived {
1218 my $self = shift;
1219
1220 if ($_[0] !~ m/^HASH/) {
1221 die "need at least list or email" unless (scalar @_ < 2);
1222 return $nos->received_messages(
1223 list => $_[0], email => $_[1],
1224 from_date => $_[2], to_date => $_[3],
1225 message => $_[4]
1226 );
1227 } else {
1228 my $arg = shift;
1229 die "need list or email argument" unless ($arg->{'list'} || $arg->{'email'});
1230 return $nos->received_messages( %{ $arg } );
1231 }
1232 }
1233
1234 ###
1235
1236 =head1 NOTE ON ARRAYS IN SOAP
1237
1238 Returning arrays from SOAP calls is somewhat fuzzy (at least to me). It
1239 seems that SOAP::Lite client thinks that it has array with one element which
1240 is array of hashes with data.
1241
1242 =head1 EXPORT
1243
1244 Nothing.
1245
1246 =head1 SEE ALSO
1247
1248 mailman, ezmlm, sympa, L<Mail::Salsa>
1249
1250
1251 =head1 AUTHOR
1252
1253 Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
1254
1255
1256 =head1 COPYRIGHT AND LICENSE
1257
1258 Copyright (C) 2005 by Dobrica Pavlinusic
1259
1260 This library is free software; you can redistribute it and/or modify
1261 it under the same terms as Perl itself, either Perl version 5.8.4 or,
1262 at your option, any later version of Perl 5 you may have available.
1263
1264
1265 =cut
1266
1267 1;

  ViewVC Help
Powered by ViewVC 1.1.26