/[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

Annotation of /trunk/Nos.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 65 - (hide annotations)
Wed Jun 29 17:05:30 2005 UTC (18 years, 9 months ago) by dpavlin
File size: 21591 byte(s)
added check when sending out e-mail. If unsuccesful, it will croak

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

  ViewVC Help
Powered by ViewVC 1.1.26