/[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 67 - (hide annotations)
Fri Jul 8 17:00:20 2005 UTC (18 years, 7 months ago) by dpavlin
File size: 24029 byte(s)
more fixes for SOAP, still not working

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

  ViewVC Help
Powered by ViewVC 1.1.26