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

  ViewVC Help
Powered by ViewVC 1.1.26