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

  ViewVC Help
Powered by ViewVC 1.1.26