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

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 Data::Dumper;
29
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 hash_len => 8,
56 );
57
58 Parametar C<hash_len> defined length of hash which will be added to each
59 outgoing e-mail message.
60
61 =cut
62
63 sub new {
64 my $class = shift;
65 my $self = {@_};
66 bless($self, $class);
67
68 croak "need at least dsn" unless ($self->{'dsn'});
69
70 $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 ) || croak "can't init Class::DBI::Loader";
80
81 $self->{'hash_len'} ||= 8;
82
83 $self ? return $self : return undef;
84 }
85
86
87 =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 =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 Return member ID if user is added.
129
130 =cut
131
132 sub add_member_to_list {
133 my $self = shift;
134
135 my $arg = {@_};
136
137 my $email = $arg->{'email'} || croak "can't add user without e-mail";
138 my $name = $arg->{'name'} || '';
139 my $list_name = $arg->{'list'} || croak "need list name";
140
141 my $list = $self->_get_list($list_name) || croak "list $list_name doesn't exist";
142
143 if (! Email::Valid->address($email)) {
144 carp "SKIPPING $name <$email>\n";
145 return 0;
146 }
147
148 carp "# $name <$email>\n" if ($self->{'verbose'});
149
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 if ($name && $this_user->full_name ne $name) {
158 $this_user->full_name($name || '');
159 $this_user->update;
160 }
161
162 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 return $this_user->id;
172 }
173
174 =head2 add_message_to_list
175
176 Adds message to one list's queue for later sending.
177
178 $nos->add_message_to_list(
179 list => 'My list',
180 message => 'Subject: welcome to list
181
182 This is example message
183 ',
184 );
185
186 On success returns ID of newly created (or existing) message.
187
188 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 =cut
193
194 sub add_message_to_list {
195 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 my $m = Email::Simple->new($message_text) || croak "can't parse message";
203
204 unless( $m->header('Subject') ) {
205 warn "message doesn't have Subject header\n";
206 return;
207 }
208
209 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 =head2 send_queued_messages
237
238 Send queued messages or just ones for selected list
239
240 $nos->send_queued_messages("My list");
241
242 =cut
243
244 sub send_queued_messages {
245 my $self = shift;
246
247 my $list_name = shift;
248
249 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
254 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
264 while (my $m = $my_q->next) {
265 next if ($m->all_sent);
266
267 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
270 foreach my $u ($user_list->search(list_id => $m->list_id)) {
271
272 my $to_email = $u->user_id->email;
273
274 my ($from,$domain) = split(/@/, $u->list_id->email, 2);
275
276 if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {
277 print "SKIP $to_email message allready sent\n";
278 } else {
279 print "=> $to_email\n";
280
281 my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;
282 my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
283
284 my $hash = $auth->generate_hash( $to_email );
285
286 my $from = $u->list_id->name . " <" . $from . "+" . $hash . ( $domain ? "@" . $domain : '' ). ">";
287 my $to = $u->user_id->full_name . " <$to_email>";
288
289 my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
290
291 $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
294 # FIXME do real sending :-)
295 send IO => $m_obj->as_string;
296
297 $sent->create({
298 message_id => $m->message_id,
299 user_id => $u->user_id,
300 hash => $hash,
301 });
302 $sent->dbi_commit;
303 }
304 }
305 $m->all_sent(1);
306 $m->update;
307 $m->dbi_commit;
308 }
309
310 }
311
312 =head2 inbox_message
313
314 Receive single message for list's inbox.
315
316 my $ok = $nos->inbox_message(
317 list => 'My list',
318 message => $message,
319 );
320
321 =cut
322
323 sub inbox_message {
324 my $self = shift;
325
326 my $arg = {@_};
327
328 return unless ($arg->{'message'});
329 croak "need list name" unless ($arg->{'list'});
330
331 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 }
361
362
363 =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 my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";
420
421 return $lists->search({ name => $name })->first;
422 }
423
424
425 =head1 EXPORT
426
427 Nothing.
428
429 =head1 SEE ALSO
430
431 mailman, ezmlm, sympa, L<Mail::Salsa>
432
433
434 =head1 AUTHOR
435
436 Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
437
438
439 =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