/[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 87 - (show annotations)
Thu Sep 21 10:49:00 2006 UTC (17 years, 7 months ago) by dpavlin
File size: 29172 byte(s)
missing Subject: doesn't prevent adding message to queue

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 warn "message doesn't have Subject header\n" unless( $m->header('Subject') );
425
426 my $lists = $self->{'loader'}->find_class('lists');
427
428 my $this_list = $lists->search(
429 name => $list_name,
430 )->first || croak "can't find list $list_name";
431
432 my $messages = $self->{'loader'}->find_class('messages');
433
434 my $this_message = $messages->find_or_create({
435 message => $message_text
436 }) || croak "can't insert message";
437
438 $this_message->dbi_commit() || croak "can't add message";
439
440 my $queue = $self->{'loader'}->find_class('queue');
441
442 $queue->find_or_create({
443 message_id => $this_message->id,
444 list_id => $this_list->id,
445 }) || croak "can't add message ",$this_message->id," to list ",$this_list->id, ": ",$this_list->name;
446
447 $queue->dbi_commit || croak "can't add message to list ",$this_list->name;
448
449 return $this_message->id;
450 }
451
452
453 =head2 send_queued_messages
454
455 Send queued messages or just ones for selected list
456
457 $nos->send_queued_messages(
458 list => 'My list',
459 driver => 'smtp',
460 sleep => 3,
461 );
462
463 Second option is driver which will be used for e-mail delivery. If not
464 specified, C<IO> driver will be used which will dump e-mail to C<STDERR>.
465
466 Other valid drivers are:
467
468 =over 10
469
470 =item smtp
471
472 Send e-mail using SMTP server at 127.0.0.1
473
474 =back
475
476 Any other driver name will try to use C<Email::Send::that_driver> module.
477
478 Default sleep wait between two messages is 3 seconds.
479
480 This method will return number of succesfully sent messages.
481
482 =cut
483
484 sub send_queued_messages {
485 my $self = shift;
486
487 my $arg = {@_};
488
489 my $list_name = lc($arg->{'list'}) || '';
490 my $driver = $arg->{'driver'} || '';
491 my $sleep = $arg->{'sleep'};
492 $sleep ||= 3 unless defined($sleep);
493
494 # number of messages sent o.k.
495 my $ok = 0;
496
497 my $email_send_driver = 'Email::Send::IO';
498 my @email_send_options;
499
500 if (lc($driver) eq 'smtp') {
501 $email_send_driver = 'Email::Send::SMTP';
502 @email_send_options = ['127.0.0.1'];
503 } elsif ($driver && $driver ne '') {
504 $email_send_driver = 'Email::Send::' . $driver;
505 } else {
506 warn "dumping all messages to STDERR\n";
507 }
508
509 my $lists = $self->{'loader'}->find_class('lists');
510 my $queue = $self->{'loader'}->find_class('queue');
511 my $user_list = $self->{'loader'}->find_class('user_list');
512 my $sent = $self->{'loader'}->find_class('sent');
513
514 my $my_q;
515 if ($list_name ne '') {
516 my $l_id = $lists->search_like( name => $list_name )->first ||
517 croak "can't find list $list_name";
518 $my_q = $queue->search_like( list_id => $l_id ) ||
519 croak "can't find list $list_name";
520 } else {
521 $my_q = $queue->retrieve_all;
522 }
523
524 while (my $m = $my_q->next) {
525 next if ($m->all_sent);
526
527 print "sending message ",$m->message_id," enqueued on ",$m->date," to list ",$m->list_id->name,"\n";
528 my $msg = $m->message_id->message;
529
530 foreach my $u ($user_list->search(list_id => $m->list_id)) {
531
532 my $to_email = $u->user_id->email;
533
534 my ($from,$domain) = split(/@/, $u->list_id->email, 2);
535
536 if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {
537 print "SKIP $to_email message allready sent\n";
538 } else {
539 print "=> $to_email ";
540
541 my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;
542 my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
543
544 my $hash = $auth->generate_hash( $to_email );
545
546 my $from_addr;
547 my $from_email_only = $from . "+" . $hash . ( $domain ? '@' . $domain : '');
548
549 $from_addr .= '"' . $u->list_id->from_addr . '" ' if ($u->list_id->from_addr);
550 $from_addr .= '<' . $from_email_only . '>';
551 my $to = '"' . $u->user_id->name . '" <' . $to_email . '>';
552
553 my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
554
555 $m_obj->header_set('Return-Path', $from_email_only) || croak "can't set Return-Path: header";
556 #$m_obj->header_set('Sender', $from_email_only) || croak "can't set Sender: header";
557 $m_obj->header_set('Errors-To', $from_email_only) || croak "can't set Errors-To: header";
558 $m_obj->header_set('From', $from_addr) || croak "can't set From: header";
559 $m_obj->header_set('To', $to) || croak "can't set To: header";
560
561 $m_obj->header_set('X-Nos-Version', $VERSION);
562 $m_obj->header_set('X-Nos-Hash', $hash);
563
564 # really send e-mail
565 my $sent_status;
566
567 if (@email_send_options) {
568 $sent_status = send $email_send_driver => $m_obj->as_string, @email_send_options;
569 } else {
570 $sent_status = send $email_send_driver => $m_obj->as_string;
571 }
572
573 croak "can't send e-mail: $sent_status\n\nOriginal e-mail follows:\n".$m_obj->as_string unless ($sent_status);
574 my @bad;
575 @bad = @{ $sent_status->prop('bad') } if (eval { $sent_status->can('prop') });
576 croak "failed sending to ",join(",",@bad) if (@bad);
577
578 if ($sent_status) {
579
580 $sent->create({
581 message_id => $m->message_id,
582 user_id => $u->user_id,
583 hash => $hash,
584 });
585 $sent->dbi_commit;
586
587 print " - $sent_status\n";
588
589 $ok++;
590 } else {
591 warn "ERROR: $sent_status\n";
592 }
593
594 if ($sleep) {
595 warn "sleeping $sleep seconds\n";
596 sleep($sleep);
597 }
598 }
599 }
600 $m->all_sent(1);
601 $m->update;
602 $m->dbi_commit;
603 }
604
605 return $ok;
606
607 }
608
609 =head2 inbox_message
610
611 Receive single message for list's inbox.
612
613 my $ok = $nos->inbox_message(
614 list => 'My list',
615 message => $message,
616 );
617
618 This method is used by C<sender.pl> when receiving e-mail messages.
619
620 =cut
621
622 sub inbox_message {
623 my $self = shift;
624
625 my $arg = {@_};
626
627 return unless ($arg->{'message'});
628 croak "need list name" unless ($arg->{'list'});
629
630 $arg->{'list'} = lc($arg->{'list'});
631
632 my $this_list = $self->_get_list($arg->{'list'}) || croak "can't find list ".$arg->{'list'}."\n";
633
634 my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message";
635
636 my $to = $m->header('To') || die "can't find To: address in incomming message\n";
637
638 my $return_path = $m->header('Return-Path') || '';
639
640 my @addrs = Email::Address->parse( $to );
641
642 die "can't parse To: $to address\n" unless (@addrs);
643
644 my $hl = $self->{'hash_len'} || confess "no hash_len?";
645
646 my $hash;
647
648 foreach my $a (@addrs) {
649 if ($a->address =~ m/\+([a-f0-9]{$hl})@/i) {
650 $hash = $1;
651 last;
652 }
653 }
654
655 #warn "can't find hash in e-mail $to\n" unless ($hash);
656
657 my $sent = $self->{'loader'}->find_class('sent');
658
659 # will use null if no matching message_id is found
660 my $sent_msg;
661 $sent_msg = $sent->search( hash => $hash )->first if ($hash);
662
663 my ($message_id, $user_id) = (undef, undef); # init with NULL
664
665 if ($sent_msg) {
666 $message_id = $sent_msg->message_id || carp "no message_id";
667 $user_id = $sent_msg->user_id || carp "no user_id";
668 } else {
669 #warn "can't find sender with hash $hash\n";
670 my $users = $self->{'loader'}->find_class('users');
671 my $from = $m->header('From');
672 $from = $1 if ($from =~ m/<(.*)>/);
673 my $this_user = $users->search( email => lc($from) )->first;
674 $user_id = $this_user->id if ($this_user);
675 }
676
677
678 my $is_bounce = 0;
679
680 if ($return_path eq '<>' || $return_path eq '') {
681 no warnings;
682 my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
683 $arg->{'message'}, { report_non_bounces=>1 },
684 ) };
685 #warn "can't check if this message is bounce!" if ($@);
686
687 $is_bounce++ if ($bounce && $bounce->is_bounce);
688 }
689
690 my $received = $self->{'loader'}->find_class('received');
691
692 my $this_received = $received->find_or_create({
693 user_id => $user_id,
694 list_id => $this_list->id,
695 message_id => $message_id,
696 message => $arg->{'message'},
697 bounced => $is_bounce,
698 }) || croak "can't insert received message";
699
700 $this_received->dbi_commit;
701
702 # print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
703 }
704
705 =head2 received_messages
706
707 Returns all received messages for given list or user.
708
709 my @received = $nos->received_messages(
710 list => 'My list',
711 email => "john.doe@example.com",
712 from_date => '2005-01-01 10:15:00',
713 to_date => '2005-01-01 12:00:00',
714 message => 0,
715 );
716
717 If don't specify C<list> or C<email> it will return all received messages.
718 Results will be sorted by received date, oldest first.
719
720 Other optional parametars include:
721
722 =over 10
723
724 =item from_date
725
726 Date (in ISO format) for lower limit of dates received
727
728 =item to_date
729
730 Return just messages older than this date
731
732 =item message
733
734 Include whole received message in result. This will probably make result
735 array very large. Use with care.
736
737 =back
738
739 Date ranges are inclusive, so results will include messages sent on
740 particular date specified with C<date_from> or C<date_to>.
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 asc };
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 # remove hostname from email to make Postfix's postalias happy
869 $email =~ s/@.+//;
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 => $_[3],
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