/[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 72 - (show annotations)
Mon Aug 22 20:24:04 2005 UTC (18 years, 7 months ago) by dpavlin
File size: 25257 byte(s)
great API change: list options are now create_list and drop_list

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

  ViewVC Help
Powered by ViewVC 1.1.26