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

Contents of /trunk/Nos.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 39 - (show 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 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 our $VERSION = '0.3';
20
21 use Class::DBI::Loader;
22 use Email::Valid;
23 use Email::Send;
24 use Carp;
25 use Email::Auth::AddressHash;
26 use Email::Simple;
27 use Email::Address;
28 use Mail::DeliveryStatus::BounceParser;
29 use Data::Dumper;
30
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 hash_len => 8,
57 );
58
59 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
62 =cut
63
64 sub new {
65 my $class = shift;
66 my $self = {@_};
67 bless($self, $class);
68
69 croak "need at least dsn" unless ($self->{'dsn'});
70
71 $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 ) || croak "can't init Class::DBI::Loader";
81
82 $self->{'hash_len'} ||= 8;
83
84 $self ? return $self : return undef;
85 }
86
87
88 =head2 new_list
89
90 Create new list. Required arguments are name of C<list> and
91 C<email> address.
92
93 $nos->new_list(
94 list => 'My list',
95 email => 'my-list@example.com',
96 );
97
98 Returns ID of newly created list.
99
100 Calls internally L<_add_list>, see details there.
101
102 =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 =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 Return member ID if user is added.
133
134 =cut
135
136 sub add_member_to_list {
137 my $self = shift;
138
139 my $arg = {@_};
140
141 my $email = $arg->{'email'} || croak "can't add user without e-mail";
142 my $name = $arg->{'name'} || '';
143 my $list_name = $arg->{'list'} || croak "need list name";
144
145 my $list = $self->_get_list($list_name) || croak "list $list_name doesn't exist";
146
147 if (! Email::Valid->address($email)) {
148 carp "SKIPPING $name <$email>\n";
149 return 0;
150 }
151
152 carp "# $name <$email>\n" if ($self->{'verbose'});
153
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 if ($name && $this_user->full_name ne $name) {
162 $this_user->full_name($name || '');
163 $this_user->update;
164 }
165
166 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 return $this_user->id;
176 }
177
178 =head2 add_message_to_list
179
180 Adds message to one list's queue for later sending.
181
182 $nos->add_message_to_list(
183 list => 'My list',
184 message => 'Subject: welcome to list
185
186 This is example message
187 ',
188 );
189
190 On success returns ID of newly created (or existing) message.
191
192 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 =cut
197
198 sub add_message_to_list {
199 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 my $m = Email::Simple->new($message_text) || croak "can't parse message";
207
208 unless( $m->header('Subject') ) {
209 warn "message doesn't have Subject header\n";
210 return;
211 }
212
213 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 =head2 send_queued_messages
241
242 Send queued messages or just ones for selected list
243
244 $nos->send_queued_messages("My list");
245
246 =cut
247
248 sub send_queued_messages {
249 my $self = shift;
250
251 my $list_name = shift;
252
253 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
258 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
268 while (my $m = $my_q->next) {
269 next if ($m->all_sent);
270
271 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
274 foreach my $u ($user_list->search(list_id => $m->list_id)) {
275
276 my $to_email = $u->user_id->email;
277
278 my ($from,$domain) = split(/@/, $u->list_id->email, 2);
279
280 if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {
281 print "SKIP $to_email message allready sent\n";
282 } else {
283 print "=> $to_email\n";
284
285 my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;
286 my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
287
288 my $hash = $auth->generate_hash( $to_email );
289
290 my $from = $u->list_id->name . " <" . $from . "+" . $hash . ( $domain ? "@" . $domain : '' ). ">";
291 my $to = $u->user_id->full_name . " <$to_email>";
292
293 my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
294
295 $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
298 $m_obj->header_set('X-Nos-Version', $VERSION);
299 $m_obj->header_set('X-Nos-Hash', $hash);
300
301 # FIXME do real sending :-)
302 send IO => $m_obj->as_string;
303
304 $sent->create({
305 message_id => $m->message_id,
306 user_id => $u->user_id,
307 hash => $hash,
308 });
309 $sent->dbi_commit;
310 }
311 }
312 $m->all_sent(1);
313 $m->update;
314 $m->dbi_commit;
315 }
316
317 }
318
319 =head2 inbox_message
320
321 Receive single message for list's inbox.
322
323 my $ok = $nos->inbox_message(
324 list => 'My list',
325 message => $message,
326 );
327
328 =cut
329
330 sub inbox_message {
331 my $self = shift;
332
333 my $arg = {@_};
334
335 return unless ($arg->{'message'});
336 croak "need list name" unless ($arg->{'list'});
337
338 my $this_list = $self->_get_list($arg->{'list'}) || croak "can't find list ".$arg->{'list'}."\n";
339
340 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 my $sent_msg = $sent->search( hash => $hash )->first;
365
366 my ($message_id, $user_id) = (undef, undef); # init with NULL
367
368 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 warn "inbox is not yet implemented";
397 }
398
399
400 =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 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 =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 my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";
462
463 return $lists->search({ name => $name })->first;
464 }
465
466 ###
467 ### SOAP
468 ###
469
470 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 =head1 EXPORT
567
568 Nothing.
569
570 =head1 SEE ALSO
571
572 mailman, ezmlm, sympa, L<Mail::Salsa>
573
574
575 =head1 AUTHOR
576
577 Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
578
579
580 =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
591 1;

  ViewVC Help
Powered by ViewVC 1.1.26