/[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 39 - (hide annotations)
Tue May 17 22:23:40 2005 UTC (18 years, 9 months ago) by dpavlin
File size: 12355 byte(s)
moved Nos::SOAP package to Nos.pm, added SOAP 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 29 our $VERSION = '0.3';
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 29 use Data::Dumper;
30 dpavlin 20
31     =head1 NAME
32    
33     Nos - Notice Sender core module
34    
35     =head1 SYNOPSIS
36    
37     use Nos;
38     my $nos = new Nos();
39    
40     =head1 DESCRIPTION
41    
42     Core module for notice sender's functionality.
43    
44     =head1 METHODS
45    
46     =head2 new
47    
48     Create new instance specifing database, user, password and options.
49    
50     my $nos = new Nos(
51     dsn => 'dbi:Pg:dbname=notices',
52     user => 'dpavlin',
53     passwd => '',
54     debug => 1,
55     verbose => 1,
56 dpavlin 36 hash_len => 8,
57 dpavlin 20 );
58    
59 dpavlin 38 Parametar C<hash_len> defines length of hash which will be added to each
60     outgoing e-mail message to ensure that replies can be linked with sent e-mails.
61 dpavlin 36
62 dpavlin 20 =cut
63    
64     sub new {
65     my $class = shift;
66     my $self = {@_};
67     bless($self, $class);
68    
69 dpavlin 22 croak "need at least dsn" unless ($self->{'dsn'});
70    
71 dpavlin 20 $self->{'loader'} = Class::DBI::Loader->new(
72     debug => $self->{'debug'},
73     dsn => $self->{'dsn'},
74     user => $self->{'user'},
75     password => $self->{'passwd'},
76     namespace => "Nos",
77     # additional_classes => qw/Class::DBI::AbstractSearch/,
78     # additional_base_classes => qw/My::Stuff/,
79     relationships => 1,
80 dpavlin 22 ) || croak "can't init Class::DBI::Loader";
81 dpavlin 20
82 dpavlin 36 $self->{'hash_len'} ||= 8;
83    
84 dpavlin 20 $self ? return $self : return undef;
85     }
86    
87 dpavlin 30
88 dpavlin 33 =head2 new_list
89    
90 dpavlin 38 Create new list. Required arguments are name of C<list> and
91     C<email> address.
92 dpavlin 33
93     $nos->new_list(
94 dpavlin 38 list => 'My list',
95 dpavlin 33 email => 'my-list@example.com',
96     );
97    
98     Returns ID of newly created list.
99    
100 dpavlin 38 Calls internally L<_add_list>, see details there.
101    
102 dpavlin 33 =cut
103    
104     sub new_list {
105     my $self = shift;
106    
107     my $arg = {@_};
108    
109     confess "need list name" unless ($arg->{'list'});
110     confess "need list email" unless ($arg->{'list'});
111    
112     my $l = $self->_get_list($arg->{'list'}) ||
113     $self->_add_list( @_ ) ||
114     return undef;
115    
116     return $l->id;
117     }
118    
119    
120 dpavlin 23 =head2 add_member_to_list
121    
122     Add new member to list
123    
124     $nos->add_member_to_list(
125     list => "My list",
126     email => "john.doe@example.com",
127     name => "John A. Doe",
128     );
129    
130     C<name> parametar is optional.
131    
132 dpavlin 27 Return member ID if user is added.
133 dpavlin 23
134     =cut
135    
136     sub add_member_to_list {
137     my $self = shift;
138    
139     my $arg = {@_};
140    
141 dpavlin 30 my $email = $arg->{'email'} || croak "can't add user without e-mail";
142 dpavlin 23 my $name = $arg->{'name'} || '';
143 dpavlin 30 my $list_name = $arg->{'list'} || croak "need list name";
144 dpavlin 23
145 dpavlin 30 my $list = $self->_get_list($list_name) || croak "list $list_name doesn't exist";
146    
147 dpavlin 23 if (! Email::Valid->address($email)) {
148 dpavlin 33 carp "SKIPPING $name <$email>\n";
149 dpavlin 23 return 0;
150     }
151    
152 dpavlin 29 carp "# $name <$email>\n" if ($self->{'verbose'});
153 dpavlin 23
154     my $users = $self->{'loader'}->find_class('users');
155     my $user_list = $self->{'loader'}->find_class('user_list');
156    
157     my $this_user = $users->find_or_create({
158     email => $email,
159     }) || croak "can't find or create member\n";
160    
161 dpavlin 33 if ($name && $this_user->full_name ne $name) {
162     $this_user->full_name($name || '');
163     $this_user->update;
164     }
165    
166 dpavlin 23 my $user_on_list = $user_list->find_or_create({
167     user_id => $this_user->id,
168     list_id => $list->id,
169     }) || croak "can't add user to list";
170    
171     $list->dbi_commit;
172     $this_user->dbi_commit;
173     $user_on_list->dbi_commit;
174    
175 dpavlin 27 return $this_user->id;
176 dpavlin 23 }
177    
178 dpavlin 29 =head2 add_message_to_list
179 dpavlin 24
180     Adds message to one list's queue for later sending.
181    
182 dpavlin 29 $nos->add_message_to_list(
183 dpavlin 24 list => 'My list',
184 dpavlin 36 message => 'Subject: welcome to list
185 dpavlin 38
186 dpavlin 24 This is example message
187     ',
188     );
189    
190     On success returns ID of newly created (or existing) message.
191    
192 dpavlin 36 Only required header in e-mail is C<Subject:>. C<From:> and C<To:> headers
193     will be automatically generated, but if you want to use own headers, just
194     include them in messages.
195    
196 dpavlin 24 =cut
197    
198 dpavlin 29 sub add_message_to_list {
199 dpavlin 24 my $self = shift;
200    
201     my $args = {@_};
202    
203     my $list_name = $args->{'list'} || confess "need list name";
204     my $message_text = $args->{'message'} || croak "need message";
205    
206 dpavlin 29 my $m = Email::Simple->new($message_text) || croak "can't parse message";
207    
208 dpavlin 32 unless( $m->header('Subject') ) {
209     warn "message doesn't have Subject header\n";
210     return;
211     }
212 dpavlin 29
213 dpavlin 24 my $lists = $self->{'loader'}->find_class('lists');
214    
215     my $this_list = $lists->search(
216     name => $list_name,
217     )->first || croak "can't find list $list_name";
218    
219     my $messages = $self->{'loader'}->find_class('messages');
220    
221     my $this_message = $messages->find_or_create({
222     message => $message_text
223     }) || croak "can't insert message";
224    
225     $this_message->dbi_commit() || croak "can't add message";
226    
227     my $queue = $self->{'loader'}->find_class('queue');
228    
229     $queue->find_or_create({
230     message_id => $this_message->id,
231     list_id => $this_list->id,
232     }) || croak "can't add message ",$this_message->id," to list ",$this_list->id, ": ",$this_list->name;
233    
234     $queue->dbi_commit || croak "can't add message to list ",$this_list->name;
235    
236     return $this_message->id;
237     }
238    
239    
240 dpavlin 22 =head2 send_queued_messages
241 dpavlin 20
242 dpavlin 22 Send queued messages or just ones for selected list
243 dpavlin 20
244 dpavlin 24 $nos->send_queued_messages("My list");
245 dpavlin 20
246 dpavlin 21 =cut
247 dpavlin 20
248 dpavlin 22 sub send_queued_messages {
249 dpavlin 21 my $self = shift;
250 dpavlin 20
251 dpavlin 22 my $list_name = shift;
252 dpavlin 20
253 dpavlin 22 my $lists = $self->{'loader'}->find_class('lists');
254     my $queue = $self->{'loader'}->find_class('queue');
255     my $user_list = $self->{'loader'}->find_class('user_list');
256     my $sent = $self->{'loader'}->find_class('sent');
257 dpavlin 20
258 dpavlin 22 my $my_q;
259     if ($list_name ne '') {
260     my $l_id = $lists->search_like( name => $list_name )->first ||
261     croak "can't find list $list_name";
262     $my_q = $queue->search_like( list_id => $l_id ) ||
263     croak "can't find list $list_name";
264     } else {
265     $my_q = $queue->retrieve_all;
266     }
267 dpavlin 20
268 dpavlin 22 while (my $m = $my_q->next) {
269     next if ($m->all_sent);
270 dpavlin 20
271 dpavlin 22 print "sending message ",$m->message_id," enqueued on ",$m->date," to list ",$m->list_id->name,"\n";
272     my $msg = $m->message_id->message;
273 dpavlin 20
274 dpavlin 22 foreach my $u ($user_list->search(list_id => $m->list_id)) {
275 dpavlin 20
276 dpavlin 29 my $to_email = $u->user_id->email;
277    
278 dpavlin 32 my ($from,$domain) = split(/@/, $u->list_id->email, 2);
279    
280 dpavlin 22 if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {
281 dpavlin 29 print "SKIP $to_email message allready sent\n";
282 dpavlin 22 } else {
283 dpavlin 32 print "=> $to_email\n";
284 dpavlin 20
285 dpavlin 32 my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;
286 dpavlin 36 my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
287 dpavlin 32
288 dpavlin 29 my $hash = $auth->generate_hash( $to_email );
289 dpavlin 20
290 dpavlin 32 my $from = $u->list_id->name . " <" . $from . "+" . $hash . ( $domain ? "@" . $domain : '' ). ">";
291 dpavlin 29 my $to = $u->user_id->full_name . " <$to_email>";
292    
293 dpavlin 32 my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
294 dpavlin 29
295 dpavlin 32 $m_obj->header_set('From', $from) || croak "can't set From: header";
296     $m_obj->header_set('To', $to) || croak "can't set To: header";
297 dpavlin 29
298 dpavlin 38 $m_obj->header_set('X-Nos-Version', $VERSION);
299     $m_obj->header_set('X-Nos-Hash', $hash);
300    
301 dpavlin 22 # FIXME do real sending :-)
302 dpavlin 32 send IO => $m_obj->as_string;
303 dpavlin 22
304     $sent->create({
305     message_id => $m->message_id,
306     user_id => $u->user_id,
307 dpavlin 36 hash => $hash,
308 dpavlin 22 });
309     $sent->dbi_commit;
310     }
311     }
312     $m->all_sent(1);
313     $m->update;
314     $m->dbi_commit;
315     }
316    
317 dpavlin 20 }
318    
319 dpavlin 29 =head2 inbox_message
320    
321     Receive single message for list's inbox.
322    
323 dpavlin 36 my $ok = $nos->inbox_message(
324     list => 'My list',
325     message => $message,
326     );
327 dpavlin 29
328     =cut
329    
330     sub inbox_message {
331     my $self = shift;
332    
333 dpavlin 36 my $arg = {@_};
334 dpavlin 29
335 dpavlin 36 return unless ($arg->{'message'});
336     croak "need list name" unless ($arg->{'list'});
337 dpavlin 29
338 dpavlin 37 my $this_list = $self->_get_list($arg->{'list'}) || croak "can't find list ".$arg->{'list'}."\n";
339    
340 dpavlin 36 my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message";
341    
342     my $to = $m->header('To') || die "can't find To: address in incomming message\n";
343    
344     my @addrs = Email::Address->parse( $to );
345    
346     die "can't parse To: $to address\n" unless (@addrs);
347    
348     my $hl = $self->{'hash_len'} || confess "no hash_len?";
349    
350     my $hash;
351    
352     foreach my $a (@addrs) {
353     if ($a->address =~ m/\+([a-f0-9]{$hl})@/) {
354     $hash = $1;
355     last;
356     }
357     }
358    
359     croak "can't find hash in e-mail $to\n" unless ($hash);
360    
361     my $sent = $self->{'loader'}->find_class('sent');
362    
363     # will use null if no matching message_id is found
364 dpavlin 37 my $sent_msg = $sent->search( hash => $hash )->first;
365 dpavlin 36
366 dpavlin 37 my ($message_id, $user_id) = (undef, undef); # init with NULL
367 dpavlin 36
368 dpavlin 37 if ($sent_msg) {
369     $message_id = $sent_msg->message_id || carp "no message_id";
370     $user_id = $sent_msg->user_id || carp "no user_id";
371     }
372    
373     print "message_id: ",($message_id || "not found"),"\n";
374    
375     my $is_bounce = 0;
376    
377     my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
378     $arg->{'message'}, { report_non_bounces=>1 },
379     ) };
380     carp "can't check if this message is bounce!" if ($@);
381    
382     $is_bounce++ if ($bounce && $bounce->is_bounce);
383    
384     my $received = $self->{'loader'}->find_class('received');
385    
386     my $this_received = $received->find_or_create({
387     user_id => $user_id,
388     list_id => $this_list->id,
389     message_id => $message_id,
390     message => $arg->{'message'},
391     bounced => $is_bounce,
392     }) || croak "can't insert received message";
393    
394     $this_received->dbi_commit;
395    
396 dpavlin 36 warn "inbox is not yet implemented";
397 dpavlin 29 }
398    
399    
400 dpavlin 30 =head1 INTERNAL METHODS
401    
402     Beware of dragons! You shouldn't need to call those methods directly.
403    
404     =head2 _add_list
405    
406     Create new list
407    
408     my $list_obj = $nos->_add_list(
409     list => 'My list',
410     email => 'my-list@example.com',
411     );
412    
413     Returns C<Class::DBI> object for created list.
414    
415 dpavlin 38 C<email> address can be with domain or without it if your
416     MTA appends it. There is no checking for validity of your
417     list e-mail. Flexibility comes with resposibility, so please
418     feed correct (and configured) return addresses.
419    
420 dpavlin 30 =cut
421    
422     sub _add_list {
423     my $self = shift;
424    
425     my $arg = {@_};
426    
427     my $name = $arg->{'list'} || confess "can't add list without name";
428     my $email = $arg->{'email'} || confess "can't add list without e-mail";
429    
430     my $lists = $self->{'loader'}->find_class('lists');
431    
432     my $l = $lists->find_or_create({
433     name => $name,
434     email => $email,
435     });
436    
437     croak "can't add list $name\n" unless ($l);
438    
439     $l->dbi_commit;
440    
441     return $l;
442    
443     }
444    
445    
446     =head2 _get_list
447    
448     Get list C<Class::DBI> object.
449    
450     my $list_obj = $nos->check_list('My list');
451    
452     Returns false on failure.
453    
454     =cut
455    
456     sub _get_list {
457     my $self = shift;
458    
459     my $name = shift || return;
460    
461 dpavlin 31 my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";
462 dpavlin 30
463 dpavlin 31 return $lists->search({ name => $name })->first;
464 dpavlin 30 }
465    
466 dpavlin 39 ###
467     ### SOAP
468     ###
469 dpavlin 30
470 dpavlin 39 package Nos::SOAP;
471    
472     =head1 SOAP methods
473    
474     This methods are thin wrappers to provide SOAP calls. They are grouped in
475     C<Nos::SOAP> package which is in same F<Nos.pm> module file.
476    
477     Usually, you want to use named variables in your SOAP calls if at all
478     possible.
479    
480     However, if you have broken SOAP library (like PHP SOAP class from PEAR)
481     you will want to use positional arguments (in same order as documented for
482     methods below).
483    
484     =cut
485    
486     my $nos;
487    
488     sub new {
489     my $class = shift;
490     my $self = {@_};
491     bless($self, $class);
492    
493     $nos = new Nos( @_ ) || die "can't create Nos object";
494    
495     $self ? return $self : return undef;
496     }
497    
498    
499     =head2 NewList
500    
501     $message_id = NewList(
502     list => 'My list',
503     email => 'my-list@example.com'
504     );
505    
506     =cut
507    
508     sub NewList {
509     my $self = shift;
510    
511     if ($_[0] !~ m/^HASH/) {
512     return $nos->new_list(
513     list => $_[0], email => $_[1],
514     );
515     } else {
516     return $nos->new_list( %{ shift @_ } );
517     }
518     }
519    
520     =head2 AddMemberToList
521    
522     $member_id = AddMemberToList(
523     list => "My list",
524     email => "e-mail@example.com",
525     name => "Full Name"
526     );
527    
528     =cut
529    
530     sub AddMemberToList {
531     my $self = shift;
532    
533     if ($_[0] !~ m/^HASH/) {
534     return $nos->add_member_to_list(
535     list => $_[0], email => $_[1], name => $_[2],
536     );
537     } else {
538     return $nos->add_member_to_list( %{ shift @_ } );
539     }
540     }
541    
542     =head2 AddMessageToList
543    
544     $message_id = AddMessageToList(
545     list => 'My list',
546     message => 'From: My list...'
547     );
548    
549     =cut
550    
551     sub AddMessageToList {
552     my $self = shift;
553    
554     if ($_[0] !~ m/^HASH/) {
555     return $nos->add_message_to_list(
556     list => $_[0], message => $_[1],
557     );
558     } else {
559     return $nos->add_message_to_list( %{ shift @_ } );
560     }
561     }
562    
563    
564     ###
565    
566 dpavlin 25 =head1 EXPORT
567 dpavlin 20
568 dpavlin 27 Nothing.
569 dpavlin 20
570     =head1 SEE ALSO
571    
572     mailman, ezmlm, sympa, L<Mail::Salsa>
573    
574 dpavlin 25
575 dpavlin 20 =head1 AUTHOR
576    
577     Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
578    
579 dpavlin 25
580 dpavlin 20 =head1 COPYRIGHT AND LICENSE
581    
582     Copyright (C) 2005 by Dobrica Pavlinusic
583    
584     This library is free software; you can redistribute it and/or modify
585     it under the same terms as Perl itself, either Perl version 5.8.4 or,
586     at your option, any later version of Perl 5 you may have available.
587    
588    
589     =cut
590 dpavlin 39
591     1;

  ViewVC Help
Powered by ViewVC 1.1.26