/[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 36 - (hide annotations)
Tue May 17 17:49:14 2005 UTC (18 years, 10 months ago) by dpavlin
File size: 9309 byte(s)
work on inbox option

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 29 use Data::Dumper;
29 dpavlin 20
30     =head1 NAME
31    
32     Nos - Notice Sender core module
33    
34     =head1 SYNOPSIS
35    
36     use Nos;
37     my $nos = new Nos();
38    
39     =head1 DESCRIPTION
40    
41     Core module for notice sender's functionality.
42    
43     =head1 METHODS
44    
45     =head2 new
46    
47     Create new instance specifing database, user, password and options.
48    
49     my $nos = new Nos(
50     dsn => 'dbi:Pg:dbname=notices',
51     user => 'dpavlin',
52     passwd => '',
53     debug => 1,
54     verbose => 1,
55 dpavlin 36 hash_len => 8,
56 dpavlin 20 );
57    
58 dpavlin 36 Parametar C<hash_len> defined length of hash which will be added to each
59     outgoing e-mail message.
60    
61 dpavlin 20 =cut
62    
63     sub new {
64     my $class = shift;
65     my $self = {@_};
66     bless($self, $class);
67    
68 dpavlin 22 croak "need at least dsn" unless ($self->{'dsn'});
69    
70 dpavlin 20 $self->{'loader'} = Class::DBI::Loader->new(
71     debug => $self->{'debug'},
72     dsn => $self->{'dsn'},
73     user => $self->{'user'},
74     password => $self->{'passwd'},
75     namespace => "Nos",
76     # additional_classes => qw/Class::DBI::AbstractSearch/,
77     # additional_base_classes => qw/My::Stuff/,
78     relationships => 1,
79 dpavlin 22 ) || croak "can't init Class::DBI::Loader";
80 dpavlin 20
81 dpavlin 36 $self->{'hash_len'} ||= 8;
82    
83 dpavlin 20 $self ? return $self : return undef;
84     }
85    
86 dpavlin 30
87 dpavlin 33 =head2 new_list
88    
89     Create new list
90    
91     $nos->new_list(
92     list => 'My list",
93     email => 'my-list@example.com',
94     );
95    
96     Returns ID of newly created list.
97    
98     =cut
99    
100     sub new_list {
101     my $self = shift;
102    
103     my $arg = {@_};
104    
105     confess "need list name" unless ($arg->{'list'});
106     confess "need list email" unless ($arg->{'list'});
107    
108     my $l = $self->_get_list($arg->{'list'}) ||
109     $self->_add_list( @_ ) ||
110     return undef;
111    
112     return $l->id;
113     }
114    
115    
116 dpavlin 23 =head2 add_member_to_list
117    
118     Add new member to list
119    
120     $nos->add_member_to_list(
121     list => "My list",
122     email => "john.doe@example.com",
123     name => "John A. Doe",
124     );
125    
126     C<name> parametar is optional.
127    
128 dpavlin 27 Return member ID if user is added.
129 dpavlin 23
130     =cut
131    
132     sub add_member_to_list {
133     my $self = shift;
134    
135     my $arg = {@_};
136    
137 dpavlin 30 my $email = $arg->{'email'} || croak "can't add user without e-mail";
138 dpavlin 23 my $name = $arg->{'name'} || '';
139 dpavlin 30 my $list_name = $arg->{'list'} || croak "need list name";
140 dpavlin 23
141 dpavlin 30 my $list = $self->_get_list($list_name) || croak "list $list_name doesn't exist";
142    
143 dpavlin 23 if (! Email::Valid->address($email)) {
144 dpavlin 33 carp "SKIPPING $name <$email>\n";
145 dpavlin 23 return 0;
146     }
147    
148 dpavlin 29 carp "# $name <$email>\n" if ($self->{'verbose'});
149 dpavlin 23
150     my $users = $self->{'loader'}->find_class('users');
151     my $user_list = $self->{'loader'}->find_class('user_list');
152    
153     my $this_user = $users->find_or_create({
154     email => $email,
155     }) || croak "can't find or create member\n";
156    
157 dpavlin 33 if ($name && $this_user->full_name ne $name) {
158     $this_user->full_name($name || '');
159     $this_user->update;
160     }
161    
162 dpavlin 23 my $user_on_list = $user_list->find_or_create({
163     user_id => $this_user->id,
164     list_id => $list->id,
165     }) || croak "can't add user to list";
166    
167     $list->dbi_commit;
168     $this_user->dbi_commit;
169     $user_on_list->dbi_commit;
170    
171 dpavlin 27 return $this_user->id;
172 dpavlin 23 }
173    
174 dpavlin 29 =head2 add_message_to_list
175 dpavlin 24
176     Adds message to one list's queue for later sending.
177    
178 dpavlin 29 $nos->add_message_to_list(
179 dpavlin 24 list => 'My list',
180 dpavlin 36 message => 'Subject: welcome to list
181 dpavlin 24
182     This is example message
183     ',
184     );
185    
186     On success returns ID of newly created (or existing) message.
187    
188 dpavlin 36 Only required header in e-mail is C<Subject:>. C<From:> and C<To:> headers
189     will be automatically generated, but if you want to use own headers, just
190     include them in messages.
191    
192 dpavlin 24 =cut
193    
194 dpavlin 29 sub add_message_to_list {
195 dpavlin 24 my $self = shift;
196    
197     my $args = {@_};
198    
199     my $list_name = $args->{'list'} || confess "need list name";
200     my $message_text = $args->{'message'} || croak "need message";
201    
202 dpavlin 29 my $m = Email::Simple->new($message_text) || croak "can't parse message";
203    
204 dpavlin 32 unless( $m->header('Subject') ) {
205     warn "message doesn't have Subject header\n";
206     return;
207     }
208 dpavlin 29
209 dpavlin 24 my $lists = $self->{'loader'}->find_class('lists');
210    
211     my $this_list = $lists->search(
212     name => $list_name,
213     )->first || croak "can't find list $list_name";
214    
215     my $messages = $self->{'loader'}->find_class('messages');
216    
217     my $this_message = $messages->find_or_create({
218     message => $message_text
219     }) || croak "can't insert message";
220    
221     $this_message->dbi_commit() || croak "can't add message";
222    
223     my $queue = $self->{'loader'}->find_class('queue');
224    
225     $queue->find_or_create({
226     message_id => $this_message->id,
227     list_id => $this_list->id,
228     }) || croak "can't add message ",$this_message->id," to list ",$this_list->id, ": ",$this_list->name;
229    
230     $queue->dbi_commit || croak "can't add message to list ",$this_list->name;
231    
232     return $this_message->id;
233     }
234    
235    
236 dpavlin 22 =head2 send_queued_messages
237 dpavlin 20
238 dpavlin 22 Send queued messages or just ones for selected list
239 dpavlin 20
240 dpavlin 24 $nos->send_queued_messages("My list");
241 dpavlin 20
242 dpavlin 21 =cut
243 dpavlin 20
244 dpavlin 22 sub send_queued_messages {
245 dpavlin 21 my $self = shift;
246 dpavlin 20
247 dpavlin 22 my $list_name = shift;
248 dpavlin 20
249 dpavlin 22 my $lists = $self->{'loader'}->find_class('lists');
250     my $queue = $self->{'loader'}->find_class('queue');
251     my $user_list = $self->{'loader'}->find_class('user_list');
252     my $sent = $self->{'loader'}->find_class('sent');
253 dpavlin 20
254 dpavlin 22 my $my_q;
255     if ($list_name ne '') {
256     my $l_id = $lists->search_like( name => $list_name )->first ||
257     croak "can't find list $list_name";
258     $my_q = $queue->search_like( list_id => $l_id ) ||
259     croak "can't find list $list_name";
260     } else {
261     $my_q = $queue->retrieve_all;
262     }
263 dpavlin 20
264 dpavlin 22 while (my $m = $my_q->next) {
265     next if ($m->all_sent);
266 dpavlin 20
267 dpavlin 22 print "sending message ",$m->message_id," enqueued on ",$m->date," to list ",$m->list_id->name,"\n";
268     my $msg = $m->message_id->message;
269 dpavlin 20
270 dpavlin 22 foreach my $u ($user_list->search(list_id => $m->list_id)) {
271 dpavlin 20
272 dpavlin 29 my $to_email = $u->user_id->email;
273    
274 dpavlin 32 my ($from,$domain) = split(/@/, $u->list_id->email, 2);
275    
276 dpavlin 22 if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {
277 dpavlin 29 print "SKIP $to_email message allready sent\n";
278 dpavlin 22 } else {
279 dpavlin 32 print "=> $to_email\n";
280 dpavlin 20
281 dpavlin 32 my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;
282 dpavlin 36 my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
283 dpavlin 32
284 dpavlin 29 my $hash = $auth->generate_hash( $to_email );
285 dpavlin 20
286 dpavlin 32 my $from = $u->list_id->name . " <" . $from . "+" . $hash . ( $domain ? "@" . $domain : '' ). ">";
287 dpavlin 29 my $to = $u->user_id->full_name . " <$to_email>";
288    
289 dpavlin 32 my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
290 dpavlin 29
291 dpavlin 32 $m_obj->header_set('From', $from) || croak "can't set From: header";
292     $m_obj->header_set('To', $to) || croak "can't set To: header";
293 dpavlin 29
294 dpavlin 22 # FIXME do real sending :-)
295 dpavlin 32 send IO => $m_obj->as_string;
296 dpavlin 22
297     $sent->create({
298     message_id => $m->message_id,
299     user_id => $u->user_id,
300 dpavlin 36 hash => $hash,
301 dpavlin 22 });
302     $sent->dbi_commit;
303     }
304     }
305     $m->all_sent(1);
306     $m->update;
307     $m->dbi_commit;
308     }
309    
310 dpavlin 20 }
311    
312 dpavlin 29 =head2 inbox_message
313    
314     Receive single message for list's inbox.
315    
316 dpavlin 36 my $ok = $nos->inbox_message(
317     list => 'My list',
318     message => $message,
319     );
320 dpavlin 29
321     =cut
322    
323     sub inbox_message {
324     my $self = shift;
325    
326 dpavlin 36 my $arg = {@_};
327 dpavlin 29
328 dpavlin 36 return unless ($arg->{'message'});
329     croak "need list name" unless ($arg->{'list'});
330 dpavlin 29
331 dpavlin 36 my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message";
332    
333     my $to = $m->header('To') || die "can't find To: address in incomming message\n";
334    
335     my @addrs = Email::Address->parse( $to );
336    
337     die "can't parse To: $to address\n" unless (@addrs);
338    
339     my $hl = $self->{'hash_len'} || confess "no hash_len?";
340    
341     my $hash;
342    
343     foreach my $a (@addrs) {
344     if ($a->address =~ m/\+([a-f0-9]{$hl})@/) {
345     $hash = $1;
346     last;
347     }
348     }
349    
350     croak "can't find hash in e-mail $to\n" unless ($hash);
351    
352     my $sent = $self->{'loader'}->find_class('sent');
353    
354     # will use null if no matching message_id is found
355     my $message_id = $sent->search( hash => $hash )->first->message_id;
356    
357     print "message_id: $message_id\n";
358    
359     warn "inbox is not yet implemented";
360 dpavlin 29 }
361    
362    
363 dpavlin 30 =head1 INTERNAL METHODS
364    
365     Beware of dragons! You shouldn't need to call those methods directly.
366    
367     =head2 _add_list
368    
369     Create new list
370    
371     my $list_obj = $nos->_add_list(
372     list => 'My list',
373     email => 'my-list@example.com',
374     );
375    
376     Returns C<Class::DBI> object for created list.
377    
378     =cut
379    
380     sub _add_list {
381     my $self = shift;
382    
383     my $arg = {@_};
384    
385     my $name = $arg->{'list'} || confess "can't add list without name";
386     my $email = $arg->{'email'} || confess "can't add list without e-mail";
387    
388     my $lists = $self->{'loader'}->find_class('lists');
389    
390     my $l = $lists->find_or_create({
391     name => $name,
392     email => $email,
393     });
394    
395     croak "can't add list $name\n" unless ($l);
396    
397     $l->dbi_commit;
398    
399     return $l;
400    
401     }
402    
403    
404     =head2 _get_list
405    
406     Get list C<Class::DBI> object.
407    
408     my $list_obj = $nos->check_list('My list');
409    
410     Returns false on failure.
411    
412     =cut
413    
414     sub _get_list {
415     my $self = shift;
416    
417     my $name = shift || return;
418    
419 dpavlin 31 my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";
420 dpavlin 30
421 dpavlin 31 return $lists->search({ name => $name })->first;
422 dpavlin 30 }
423    
424    
425 dpavlin 25 =head1 EXPORT
426 dpavlin 20
427 dpavlin 27 Nothing.
428 dpavlin 20
429     =head1 SEE ALSO
430    
431     mailman, ezmlm, sympa, L<Mail::Salsa>
432    
433 dpavlin 25
434 dpavlin 20 =head1 AUTHOR
435    
436     Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
437    
438 dpavlin 25
439 dpavlin 20 =head1 COPYRIGHT AND LICENSE
440    
441     Copyright (C) 2005 by Dobrica Pavlinusic
442    
443     This library is free software; you can redistribute it and/or modify
444     it under the same terms as Perl itself, either Perl version 5.8.4 or,
445     at your option, any later version of Perl 5 you may have available.
446    
447    
448     =cut

  ViewVC Help
Powered by ViewVC 1.1.26