/[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 45 - (show annotations)
Wed May 18 13:12:54 2005 UTC (18 years, 9 months ago) by dpavlin
File size: 14259 byte(s)
added delete_member

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.4';
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->name ne $name) {
162 $this_user->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 list_members
179
180 List all members of some list.
181
182 my @members = list_members(
183 list => 'My list',
184 );
185
186 Returns array of hashes with user informations like this:
187
188 $member = {
189 name => 'Dobrica Pavlinusic',
190 email => 'dpavlin@rot13.org
191 }
192
193 If list is not found, returns false.
194
195 =cut
196
197 sub list_members {
198 my $self = shift;
199
200 my $args = {@_};
201
202 my $list_name = $args->{'list'} || confess "need list name";
203
204 my $lists = $self->{'loader'}->find_class('lists');
205 my $user_list = $self->{'loader'}->find_class('user_list');
206
207 my $this_list = $lists->search( name => $list_name )->first || return;
208
209 my @results;
210
211 foreach my $user_on_list ($user_list->search(list_id => $this_list->id)) {
212 my $row = {
213 name => $user_on_list->user_id->name,
214 email => $user_on_list->user_id->email,
215 };
216
217 push @results, $row;
218 }
219
220 return @results;
221
222 }
223
224
225 =head2 delete_member
226
227 Delete member from database.
228
229 my $ok = delete_member(
230 name => 'Dobrica Pavlinusic'
231 );
232
233 my $ok = delete_member(
234 email => 'dpavlin@rot13.org'
235 );
236
237 Returns false if user doesn't exist.
238
239 =cut
240
241 sub delete_member {
242 my $self = shift;
243
244 my $args = {@_};
245
246 croak "need name or email of user to delete" unless ($args->{'name'} || $args->{'email'});
247
248 my $key = 'name';
249 $key = 'email' if ($args->{'email'});
250
251 my $users = $self->{'loader'}->find_class('users');
252
253 my $this_user = $users->search( $key => $args->{$key} )->first || return;
254
255 print Dumper($this_user);
256
257 $this_user->delete || croak "can't delete user\n";
258
259 return $users->dbi_commit || croak "can't commit";
260 }
261
262 =head2 add_message_to_list
263
264 Adds message to one list's queue for later sending.
265
266 $nos->add_message_to_list(
267 list => 'My list',
268 message => 'Subject: welcome to list
269
270 This is example message
271 ',
272 );
273
274 On success returns ID of newly created (or existing) message.
275
276 Only required header in e-mail is C<Subject:>. C<From:> and C<To:> headers
277 will be automatically generated, but if you want to use own headers, just
278 include them in messages.
279
280 =cut
281
282 sub add_message_to_list {
283 my $self = shift;
284
285 my $args = {@_};
286
287 my $list_name = $args->{'list'} || confess "need list name";
288 my $message_text = $args->{'message'} || croak "need message";
289
290 my $m = Email::Simple->new($message_text) || croak "can't parse message";
291
292 unless( $m->header('Subject') ) {
293 warn "message doesn't have Subject header\n";
294 return;
295 }
296
297 my $lists = $self->{'loader'}->find_class('lists');
298
299 my $this_list = $lists->search(
300 name => $list_name,
301 )->first || croak "can't find list $list_name";
302
303 my $messages = $self->{'loader'}->find_class('messages');
304
305 my $this_message = $messages->find_or_create({
306 message => $message_text
307 }) || croak "can't insert message";
308
309 $this_message->dbi_commit() || croak "can't add message";
310
311 my $queue = $self->{'loader'}->find_class('queue');
312
313 $queue->find_or_create({
314 message_id => $this_message->id,
315 list_id => $this_list->id,
316 }) || croak "can't add message ",$this_message->id," to list ",$this_list->id, ": ",$this_list->name;
317
318 $queue->dbi_commit || croak "can't add message to list ",$this_list->name;
319
320 return $this_message->id;
321 }
322
323
324 =head2 send_queued_messages
325
326 Send queued messages or just ones for selected list
327
328 $nos->send_queued_messages("My list");
329
330 =cut
331
332 sub send_queued_messages {
333 my $self = shift;
334
335 my $list_name = shift;
336
337 my $lists = $self->{'loader'}->find_class('lists');
338 my $queue = $self->{'loader'}->find_class('queue');
339 my $user_list = $self->{'loader'}->find_class('user_list');
340 my $sent = $self->{'loader'}->find_class('sent');
341
342 my $my_q;
343 if ($list_name ne '') {
344 my $l_id = $lists->search_like( name => $list_name )->first ||
345 croak "can't find list $list_name";
346 $my_q = $queue->search_like( list_id => $l_id ) ||
347 croak "can't find list $list_name";
348 } else {
349 $my_q = $queue->retrieve_all;
350 }
351
352 while (my $m = $my_q->next) {
353 next if ($m->all_sent);
354
355 print "sending message ",$m->message_id," enqueued on ",$m->date," to list ",$m->list_id->name,"\n";
356 my $msg = $m->message_id->message;
357
358 foreach my $u ($user_list->search(list_id => $m->list_id)) {
359
360 my $to_email = $u->user_id->email;
361
362 my ($from,$domain) = split(/@/, $u->list_id->email, 2);
363
364 if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {
365 print "SKIP $to_email message allready sent\n";
366 } else {
367 print "=> $to_email\n";
368
369 my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;
370 my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
371
372 my $hash = $auth->generate_hash( $to_email );
373
374 my $from = $u->list_id->name . " <" . $from . "+" . $hash . ( $domain ? "@" . $domain : '' ). ">";
375 my $to = $u->user_id->name . " <$to_email>";
376
377 my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
378
379 $m_obj->header_set('From', $from) || croak "can't set From: header";
380 $m_obj->header_set('To', $to) || croak "can't set To: header";
381
382 $m_obj->header_set('X-Nos-Version', $VERSION);
383 $m_obj->header_set('X-Nos-Hash', $hash);
384
385 # FIXME do real sending :-)
386 send IO => $m_obj->as_string;
387
388 $sent->create({
389 message_id => $m->message_id,
390 user_id => $u->user_id,
391 hash => $hash,
392 });
393 $sent->dbi_commit;
394 }
395 }
396 $m->all_sent(1);
397 $m->update;
398 $m->dbi_commit;
399 }
400
401 }
402
403 =head2 inbox_message
404
405 Receive single message for list's inbox.
406
407 my $ok = $nos->inbox_message(
408 list => 'My list',
409 message => $message,
410 );
411
412 =cut
413
414 sub inbox_message {
415 my $self = shift;
416
417 my $arg = {@_};
418
419 return unless ($arg->{'message'});
420 croak "need list name" unless ($arg->{'list'});
421
422 my $this_list = $self->_get_list($arg->{'list'}) || croak "can't find list ".$arg->{'list'}."\n";
423
424 my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message";
425
426 my $to = $m->header('To') || die "can't find To: address in incomming message\n";
427
428 my @addrs = Email::Address->parse( $to );
429
430 die "can't parse To: $to address\n" unless (@addrs);
431
432 my $hl = $self->{'hash_len'} || confess "no hash_len?";
433
434 my $hash;
435
436 foreach my $a (@addrs) {
437 if ($a->address =~ m/\+([a-f0-9]{$hl})@/) {
438 $hash = $1;
439 last;
440 }
441 }
442
443 croak "can't find hash in e-mail $to\n" unless ($hash);
444
445 my $sent = $self->{'loader'}->find_class('sent');
446
447 # will use null if no matching message_id is found
448 my $sent_msg = $sent->search( hash => $hash )->first;
449
450 my ($message_id, $user_id) = (undef, undef); # init with NULL
451
452 if ($sent_msg) {
453 $message_id = $sent_msg->message_id || carp "no message_id";
454 $user_id = $sent_msg->user_id || carp "no user_id";
455 }
456
457
458 my $is_bounce = 0;
459
460 my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
461 $arg->{'message'}, { report_non_bounces=>1 },
462 ) };
463 carp "can't check if this message is bounce!" if ($@);
464
465 $is_bounce++ if ($bounce && $bounce->is_bounce);
466
467 my $received = $self->{'loader'}->find_class('received');
468
469 my $this_received = $received->find_or_create({
470 user_id => $user_id,
471 list_id => $this_list->id,
472 message_id => $message_id,
473 message => $arg->{'message'},
474 bounced => $is_bounce,
475 }) || croak "can't insert received message";
476
477 $this_received->dbi_commit;
478
479 print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
480
481
482 warn "inbox is not yet implemented";
483 }
484
485
486 =head1 INTERNAL METHODS
487
488 Beware of dragons! You shouldn't need to call those methods directly.
489
490 =head2 _add_list
491
492 Create new list
493
494 my $list_obj = $nos->_add_list(
495 list => 'My list',
496 email => 'my-list@example.com',
497 );
498
499 Returns C<Class::DBI> object for created list.
500
501 C<email> address can be with domain or without it if your
502 MTA appends it. There is no checking for validity of your
503 list e-mail. Flexibility comes with resposibility, so please
504 feed correct (and configured) return addresses.
505
506 =cut
507
508 sub _add_list {
509 my $self = shift;
510
511 my $arg = {@_};
512
513 my $name = $arg->{'list'} || confess "can't add list without name";
514 my $email = $arg->{'email'} || confess "can't add list without e-mail";
515
516 my $lists = $self->{'loader'}->find_class('lists');
517
518 my $l = $lists->find_or_create({
519 name => $name,
520 email => $email,
521 });
522
523 croak "can't add list $name\n" unless ($l);
524
525 $l->dbi_commit;
526
527 return $l;
528
529 }
530
531
532 =head2 _get_list
533
534 Get list C<Class::DBI> object.
535
536 my $list_obj = $nos->check_list('My list');
537
538 Returns false on failure.
539
540 =cut
541
542 sub _get_list {
543 my $self = shift;
544
545 my $name = shift || return;
546
547 my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";
548
549 return $lists->search({ name => $name })->first;
550 }
551
552 ###
553 ### SOAP
554 ###
555
556 package Nos::SOAP;
557
558 use Carp;
559
560 =head1 SOAP methods
561
562 This methods are thin wrappers to provide SOAP calls. They are grouped in
563 C<Nos::SOAP> package which is in same F<Nos.pm> module file.
564
565 Usually, you want to use named variables in your SOAP calls if at all
566 possible.
567
568 However, if you have broken SOAP library (like PHP SOAP class from PEAR)
569 you will want to use positional arguments (in same order as documented for
570 methods below).
571
572 =cut
573
574 my $nos;
575
576 sub new {
577 my $class = shift;
578 my $self = {@_};
579 bless($self, $class);
580
581 $nos = new Nos( @_ ) || die "can't create Nos object";
582
583 $self ? return $self : return undef;
584 }
585
586
587 =head2 NewList
588
589 $message_id = NewList(
590 list => 'My list',
591 email => 'my-list@example.com'
592 );
593
594 =cut
595
596 sub NewList {
597 my $self = shift;
598
599 if ($_[0] !~ m/^HASH/) {
600 return $nos->new_list(
601 list => $_[0], email => $_[1],
602 );
603 } else {
604 return $nos->new_list( %{ shift @_ } );
605 }
606 }
607
608
609 =head2 AddMemberToList
610
611 $member_id = AddMemberToList(
612 list => 'My list',
613 email => 'e-mail@example.com',
614 name => 'Full Name'
615 );
616
617 =cut
618
619 sub AddMemberToList {
620 my $self = shift;
621
622 if ($_[0] !~ m/^HASH/) {
623 return $nos->add_member_to_list(
624 list => $_[0], email => $_[1], name => $_[2],
625 );
626 } else {
627 return $nos->add_member_to_list( %{ shift @_ } );
628 }
629 }
630
631
632 =head2 ListMembers
633
634 my @members = ListMembers(
635 list => 'My list',
636 );
637
638 Returns array of hashes with user informations, see C<list_members>.
639
640 =cut
641
642 sub ListMembers {
643 my $self = shift;
644
645 my $list_name;
646
647 if ($_[0] !~ m/^HASH/) {
648 $list_name = shift;
649 } else {
650 $list_name = $_[0]->{'list'};
651 }
652
653 return $nos->list_members( list => $list_name );
654 }
655
656 =head2 AddMessageToList
657
658 $message_id = AddMessageToList(
659 list => 'My list',
660 message => 'From: My list...'
661 );
662
663 =cut
664
665 sub AddMessageToList {
666 my $self = shift;
667
668 if ($_[0] !~ m/^HASH/) {
669 return $nos->add_message_to_list(
670 list => $_[0], message => $_[1],
671 );
672 } else {
673 return $nos->add_message_to_list( %{ shift @_ } );
674 }
675 }
676
677
678 ###
679
680 =head1 EXPORT
681
682 Nothing.
683
684 =head1 SEE ALSO
685
686 mailman, ezmlm, sympa, L<Mail::Salsa>
687
688
689 =head1 AUTHOR
690
691 Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
692
693
694 =head1 COPYRIGHT AND LICENSE
695
696 Copyright (C) 2005 by Dobrica Pavlinusic
697
698 This library is free software; you can redistribute it and/or modify
699 it under the same terms as Perl itself, either Perl version 5.8.4 or,
700 at your option, any later version of Perl 5 you may have available.
701
702
703 =cut
704
705 1;

  ViewVC Help
Powered by ViewVC 1.1.26