/[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 75 - (show annotations)
Wed Aug 24 21:27:40 2005 UTC (18 years, 6 months ago) by dpavlin
File size: 27549 byte(s)
beginning of received_messages, send_queued_messages now returns number of
messages succesfully sent, driver can now be any Email::Send driver (including
Email::Send::Test used for tests), documentation improvements

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

  ViewVC Help
Powered by ViewVC 1.1.26