/[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 77 - (hide annotations)
Thu Aug 25 00:37:48 2005 UTC (18 years, 7 months ago) by dpavlin
File size: 27732 byte(s)
implemented arguments email and list to received_messages using
SQL::Abstract, small improvements of tests

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

  ViewVC Help
Powered by ViewVC 1.1.26