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

  ViewVC Help
Powered by ViewVC 1.1.26