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

Diff of /trunk/Nos.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 32 by dpavlin, Mon May 16 22:32:58 2005 UTC revision 66 by dpavlin, Fri Jul 8 11:46:35 2005 UTC
# Line 16  our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all' Line 16  our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'
16  our @EXPORT = qw(  our @EXPORT = qw(
17  );  );
18    
19  our $VERSION = '0.3';  our $VERSION = '0.5';
20    
21  use Class::DBI::Loader;  use Class::DBI::Loader;
22  use Email::Valid;  use Email::Valid;
# Line 24  use Email::Send; Line 24  use Email::Send;
24  use Carp;  use Carp;
25  use Email::Auth::AddressHash;  use Email::Auth::AddressHash;
26  use Email::Simple;  use Email::Simple;
27  use Data::Dumper;  use Email::Address;
28    use Mail::DeliveryStatus::BounceParser;
29    use Class::DBI::AbstractSearch;
30    use Mail::Alias;
31    use Cwd qw(abs_path);
32    
33    
34  =head1 NAME  =head1 NAME
35    
# Line 37  Nos - Notice Sender core module Line 42  Nos - Notice Sender core module
42    
43  =head1 DESCRIPTION  =head1 DESCRIPTION
44    
45  Core module for notice sender's functionality.  Notice sender is mail handler. It is not MTA, since it doesn't know how to
46    receive e-mails or send them directly to other hosts. It is not mail list
47    manager because it requires programming to add list members and send
48    messages. You can think of it as mechanisam for off-loading your e-mail
49    sending to remote server using SOAP service.
50    
51    It's concept is based around B<lists>. Each list can have zero or more
52    B<members>. Each list can have zero or more B<messages>.
53    
54    Here comes a twist: each outgoing message will have unique e-mail generated,
55    so Notice Sender will be able to link received replies (or bounces) with
56    outgoing messages.
57    
58    It doesn't do much more than that. It B<can't> create MIME encoded e-mail,
59    send attachments, handle 8-bit characters in headers (which have to be
60    encoded) or anything else.
61    
62    It will just queue your e-mail message to particular list (sending it to
63    possibly remote Notice Sender SOAP server just once), send it out at
64    reasonable rate (so that it doesn't flood your e-mail infrastructure) and
65    track replies.
66    
67    It is best used to send smaller number of messages to more-or-less fixed
68    list of recipients while allowing individual responses to be examined.
69    Tipical use include replacing php e-mail sending code with SOAP call to
70    Notice Sender. It does support additional C<ext_id> field for each member
71    which can be used to track some unique identifier from remote system for
72    particular user.
73    
74    It comes with command-line utility C<sender.pl> which can be used to perform
75    all available operation from scripts (see C<perldoc sender.pl>).
76    This command is also useful for debugging while writing client SOAP
77    application.
78    
79  =head1 METHODS  =head1 METHODS
80    
# Line 51  Create new instance specifing database, Line 88  Create new instance specifing database,
88          passwd => '',          passwd => '',
89          debug => 1,          debug => 1,
90          verbose => 1,          verbose => 1,
91            hash_len => 8,
92   );   );
93    
94    Parametar C<hash_len> defines length of hash which will be added to each
95    outgoing e-mail message to ensure that replies can be linked with sent e-mails.
96    
97  =cut  =cut
98    
99  sub new {  sub new {
# Line 68  sub new { Line 109  sub new {
109                  user            => $self->{'user'},                  user            => $self->{'user'},
110                  password        => $self->{'passwd'},                  password        => $self->{'passwd'},
111                  namespace       => "Nos",                  namespace       => "Nos",
112  #               additional_classes      => qw/Class::DBI::AbstractSearch/,                  additional_classes      => qw/Class::DBI::AbstractSearch/,
113  #               additional_base_classes => qw/My::Stuff/,  #               additional_base_classes => qw/My::Stuff/,
114                  relationships   => 1,                  relationships   => 1,
115          ) || croak "can't init Class::DBI::Loader";          ) || croak "can't init Class::DBI::Loader";
116    
117            $self->{'hash_len'} ||= 8;
118    
119          $self ? return $self : return undef;          $self ? return $self : return undef;
120  }  }
121    
122    
123    =head2 new_list
124    
125    Create new list. Required arguments are name of C<list> and
126    C<email> address.
127    
128     $nos->new_list(
129            list => 'My list',
130            from => 'Outgoing from comment',
131            email => 'my-list@example.com',
132     );
133    
134    Returns ID of newly created list.
135    
136    Calls internally C<_add_list>, see details there.
137    
138    =cut
139    
140    sub new_list {
141            my $self = shift;
142    
143            my $arg = {@_};
144    
145            confess "need list name" unless ($arg->{'list'});
146            confess "need list email" unless ($arg->{'email'});
147    
148            $arg->{'list'} = lc($arg->{'list'});
149            $arg->{'email'} = lc($arg->{'email'});
150    
151            my $l = $self->_get_list($arg->{'list'}) ||
152                    $self->_add_list( @_ ) ||
153                    return undef;
154    
155            return $l->id;
156    }
157    
158    
159    =head2 delete_list
160    
161    Delete list from database.
162    
163     my $ok = delete_list(
164            list => 'My list'
165     );
166    
167    Returns false if list doesn't exist.
168    
169    =cut
170    
171    sub delete_list {
172            my $self = shift;
173    
174            my $args = {@_};
175    
176            croak "need list to delete" unless ($args->{'list'});
177    
178            $args->{'list'} = lc($args->{'list'});
179    
180            my $lists = $self->{'loader'}->find_class('lists');
181    
182            my $this_list = $lists->search( name => $args->{'list'} )->first || return;
183    
184            $this_list->delete || croak "can't delete list\n";
185    
186            return $lists->dbi_commit || croak "can't commit";
187    }
188    
189    
190  =head2 add_member_to_list  =head2 add_member_to_list
191    
192  Add new member to list  Add new member to list
# Line 85  Add new member to list Line 195  Add new member to list
195          list => "My list",          list => "My list",
196          email => "john.doe@example.com",          email => "john.doe@example.com",
197          name => "John A. Doe",          name => "John A. Doe",
198            ext_id => 42,
199   );   );
200    
201  C<name> parametar is optional.  C<name> and C<ext_id> parametars are optional.
202    
203  Return member ID if user is added.  Return member ID if user is added.
204    
# Line 98  sub add_member_to_list { Line 209  sub add_member_to_list {
209    
210          my $arg = {@_};          my $arg = {@_};
211    
212          my $email = $arg->{'email'} || croak "can't add user without e-mail";          my $email = lc($arg->{'email'}) || croak "can't add user without e-mail";
213          my $name = $arg->{'name'} || '';          my $name = $arg->{'name'} || '';
214          my $list_name = $arg->{'list'} || croak "need list name";          my $list_name = lc($arg->{'list'}) || croak "need list name";
215            my $ext_id = $arg->{'ext_id'};
216    
217          my $list = $self->_get_list($list_name) || croak "list $list_name doesn't exist";          my $list = $self->_get_list($list_name) || croak "list $list_name doesn't exist";
218    
219          if (! Email::Valid->address($email)) {          if (! Email::Valid->address($email)) {
220                  carp "SKIPPING $name <$email>\n" if ($self->{'verbose'});                  carp "SKIPPING $name <$email>\n";
221                  return 0;                  return 0;
222          }          }
223    
# Line 116  sub add_member_to_list { Line 228  sub add_member_to_list {
228    
229          my $this_user = $users->find_or_create({          my $this_user = $users->find_or_create({
230                  email => $email,                  email => $email,
                 full_name => $name,  
231          }) || croak "can't find or create member\n";          }) || croak "can't find or create member\n";
232    
233            if ($name && $this_user->name ne $name) {
234                    $this_user->name($name || '');
235                    $this_user->update;
236            }
237    
238            if (defined($ext_id) && ($this_user->ext_id || '') ne $ext_id) {
239                    $this_user->ext_id($ext_id);
240                    $this_user->update;
241            }
242    
243          my $user_on_list = $user_list->find_or_create({          my $user_on_list = $user_list->find_or_create({
244                  user_id => $this_user->id,                  user_id => $this_user->id,
245                  list_id => $list->id,                  list_id => $list->id,
# Line 131  sub add_member_to_list { Line 252  sub add_member_to_list {
252          return $this_user->id;          return $this_user->id;
253  }  }
254    
255    =head2 list_members
256    
257    List all members of some list.
258    
259     my @members = list_members(
260            list => 'My list',
261     );
262    
263    Returns array of hashes with user informations like this:
264    
265     $member = {
266            name => 'Dobrica Pavlinusic',
267            email => 'dpavlin@rot13.org
268     }
269    
270    If list is not found, returns false. If there is C<ext_id> in user data,
271    it will also be returned.
272    
273    =cut
274    
275    sub list_members {
276            my $self = shift;
277    
278            my $args = {@_};
279    
280            my $list_name = lc($args->{'list'}) || confess "need list name";
281    
282            my $lists = $self->{'loader'}->find_class('lists');
283            my $user_list = $self->{'loader'}->find_class('user_list');
284    
285            my $this_list = $lists->search( name => $list_name )->first || return;
286    
287            my @results;
288    
289            foreach my $user_on_list ($user_list->search(list_id => $this_list->id)) {
290                    my $row = {
291                            name => $user_on_list->user_id->name,
292                            email => $user_on_list->user_id->email,
293                    };
294    
295                    my $ext_id = $user_on_list->user_id->ext_id;
296                    $row->{'ext_id'} = $ext_id if (defined($ext_id));
297    
298                    push @results, $row;
299            }
300    
301            return @results;
302    
303    }
304    
305    
306    =head2 delete_member
307    
308    Delete member from database.
309    
310     my $ok = delete_member(
311            name => 'Dobrica Pavlinusic'
312     );
313    
314     my $ok = delete_member(
315            email => 'dpavlin@rot13.org'
316     );
317    
318    Returns false if user doesn't exist.
319    
320    This function will delete member from all lists (by cascading delete), so it
321    shouldn't be used lightly.
322    
323    =cut
324    
325    sub delete_member {
326            my $self = shift;
327    
328            my $args = {@_};
329    
330            croak "need name or email of user to delete" unless ($args->{'name'} || $args->{'email'});
331    
332            $args->{'email'} = lc($args->{'email'}) if ($args->{'email'});
333    
334            my $key = 'name';
335            $key = 'email' if ($args->{'email'});
336    
337            my $users = $self->{'loader'}->find_class('users');
338    
339            my $this_user = $users->search( $key => $args->{$key} )->first || return;
340    
341            $this_user->delete || croak "can't delete user\n";
342    
343            return $users->dbi_commit || croak "can't commit";
344    }
345    
346    =head2 delete_member_from_list
347    
348    Delete member from particular list.
349    
350     my $ok = delete_member_from_list(
351            list => 'My list',
352            email => 'dpavlin@rot13.org',
353     );
354    
355    Returns false if user doesn't exist on that particular list.
356    
357    It will die if list or user doesn't exist. You have been warned (you might
358    want to eval this functon to prevent it from croaking).
359    
360    =cut
361    
362    sub delete_member_from_list {
363            my $self = shift;
364    
365            my $args = {@_};
366    
367            croak "need list name and email of user to delete" unless ($args->{'list'} && $args->{'email'});
368    
369            $args->{'list'} = lc($args->{'list'});
370            $args->{'email'} = lc($args->{'email'});
371    
372            my $user = $self->{'loader'}->find_class('users');
373            my $list = $self->{'loader'}->find_class('lists');
374            my $user_list = $self->{'loader'}->find_class('user_list');
375    
376            my $this_user = $user->search( email => $args->{'email'} )->first || croak "can't find user: ".$args->{'email'};
377            my $this_list = $list->search( name => $args->{'list'} )->first || croak "can't find list: ".$args->{'list'};
378    
379            my $this_user_list = $user_list->search_where( list_id => $this_list->id, user_id => $this_user->id )->first || return;
380    
381            $this_user_list->delete || croak "can't delete user from list\n";
382    
383            return $user_list->dbi_commit || croak "can't commit";
384    }
385    
386  =head2 add_message_to_list  =head2 add_message_to_list
387    
388  Adds message to one list's queue for later sending.  Adds message to one list's queue for later sending.
389    
390   $nos->add_message_to_list(   $nos->add_message_to_list(
391          list => 'My list',          list => 'My list',
392          message => 'From: My list <mylist@example.com>          message => 'Subject: welcome to list
393   To: John A. Doe <john.doe@example.com>  
   
394   This is example message   This is example message
395   ',   ',
396   );       );    
397    
398  On success returns ID of newly created (or existing) message.  On success returns ID of newly created (or existing) message.
399    
400    Only required header in e-mail is C<Subject:>. C<From:> and C<To:> headers
401    will be automatically generated, but if you want to use own headers, just
402    include them in messages.
403    
404  =cut  =cut
405    
406  sub add_message_to_list {  sub add_message_to_list {
# Line 153  sub add_message_to_list { Line 408  sub add_message_to_list {
408    
409          my $args = {@_};          my $args = {@_};
410    
411          my $list_name = $args->{'list'} || confess "need list name";          my $list_name = lc($args->{'list'}) || confess "need list name";
412          my $message_text = $args->{'message'} || croak "need message";          my $message_text = $args->{'message'} || croak "need message";
413    
414          my $m = Email::Simple->new($message_text) || croak "can't parse message";          my $m = Email::Simple->new($message_text) || croak "can't parse message";
# Line 194  sub add_message_to_list { Line 449  sub add_message_to_list {
449    
450  Send queued messages or just ones for selected list  Send queued messages or just ones for selected list
451    
452   $nos->send_queued_messages("My list");   $nos->send_queued_messages(
453            list => 'My list',
454            driver => 'smtp',
455            sleep => 3,
456     );
457    
458    Second option is driver which will be used for e-mail delivery. If not
459    specified, C<IO> driver will be used which will dump e-mail to C<STDERR>.
460    
461    Other valid drivers are:
462    
463    =over 10
464    
465    =item smtp
466    
467    Send e-mail using SMTP server at 127.0.0.1
468    
469    =back
470    
471    Default sleep wait between two messages is 3 seconds.
472    
473  =cut  =cut
474    
475  sub send_queued_messages {  sub send_queued_messages {
476          my $self = shift;          my $self = shift;
477    
478          my $list_name = shift;          my $arg = {@_};
479    
480            my $list_name = lc($arg->{'list'}) || '';
481            my $driver = $arg->{'driver'} || '';
482            my $sleep = $arg->{'sleep'};
483            $sleep ||= 3 unless defined($sleep);
484    
485            my $email_send_driver = 'Email::Send::IO';
486            my @email_send_options;
487    
488            if (lc($driver) eq 'smtp') {
489                    $email_send_driver = 'Email::Send::SMTP';
490                    @email_send_options = ['127.0.0.1'];
491            } else {
492                    warn "dumping all messages to STDERR\n";
493            }
494    
495          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
496          my $queue = $self->{'loader'}->find_class('queue');          my $queue = $self->{'loader'}->find_class('queue');
# Line 233  sub send_queued_messages { Line 522  sub send_queued_messages {
522                          if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {                          if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {
523                                  print "SKIP $to_email message allready sent\n";                                  print "SKIP $to_email message allready sent\n";
524                          } else {                          } else {
525                                  print "=> $to_email\n";                                  print "=> $to_email ";
526    
527                                  my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;                                  my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;
528                                  my $auth = Email::Auth::AddressHash->new( $secret, 10 );                                  my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
529    
530                                  my $hash = $auth->generate_hash( $to_email );                                  my $hash = $auth->generate_hash( $to_email );
531    
532                                  my $from = $u->list_id->name . " <" . $from . "+" . $hash . ( $domain ? "@" . $domain : '' ). ">";                                  my $from_addr;
533                                  my $to = $u->user_id->full_name . " <$to_email>";                                  my $from_email_only = $from . "+" . $hash . ( $domain ? '@' . $domain : '');
534    
535                                    $from_addr .= '"' . $u->list_id->from_addr . '" ' if ($u->list_id->from_addr);
536                                    $from_addr .= '<' . $from_email_only . '>';
537                                    my $to = '"' . $u->user_id->name . '" <' . $to_email . '>';
538    
539                                  my $m_obj = Email::Simple->new($msg) || croak "can't parse message";                                  my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
540    
541                                  $m_obj->header_set('From', $from) || croak "can't set From: header";                                  $m_obj->header_set('Return-Path', $from_email_only) || croak "can't set Return-Path: header";
542                                    $m_obj->header_set('Sender', $from_email_only) || croak "can't set Sender: header";
543                                    $m_obj->header_set('Errors-To', $from_email_only) || croak "can't set Errors-To: header";
544                                    $m_obj->header_set('From', $from_addr) || croak "can't set From: header";
545                                  $m_obj->header_set('To', $to) || croak "can't set To: header";                                  $m_obj->header_set('To', $to) || croak "can't set To: header";
546    
547                                  # FIXME do real sending :-)                                  $m_obj->header_set('X-Nos-Version', $VERSION);
548                                  send IO => $m_obj->as_string;                                  $m_obj->header_set('X-Nos-Hash', $hash);
549    
550                                  $sent->create({                                  # really send e-mail
551                                          message_id => $m->message_id,                                  my $sent_status;
552                                          user_id => $u->user_id,  
553                                  });                                  if (@email_send_options) {
554                                  $sent->dbi_commit;                                          $sent_status = send $email_send_driver => $m_obj->as_string, @email_send_options;
555                                    } else {
556                                            $sent_status = send $email_send_driver => $m_obj->as_string;
557                                    }
558    
559                                    croak "can't send e-mail: $sent_status\n\nOriginal e-mail follows:\n".$m_obj->as_string unless ($sent_status);
560                                    my @bad = @{ $sent_status->prop('bad') };
561                                    croak "failed sending to ",join(",",@bad) if (@bad);
562    
563                                    if ($sent_status) {
564    
565                                            $sent->create({
566                                                    message_id => $m->message_id,
567                                                    user_id => $u->user_id,
568                                                    hash => $hash,
569                                            });
570                                            $sent->dbi_commit;
571    
572                                            print " - $sent_status\n";
573    
574                                    } else {
575                                            warn "ERROR: $sent_status\n";
576                                    }
577    
578                                    if ($sleep) {
579                                            warn "sleeping $sleep seconds\n";
580                                            sleep($sleep);
581                                    }
582                          }                          }
583                  }                  }
584                  $m->all_sent(1);                  $m->all_sent(1);
# Line 269  sub send_queued_messages { Line 592  sub send_queued_messages {
592    
593  Receive single message for list's inbox.  Receive single message for list's inbox.
594    
595   my $ok = $nos->inbox_message($message);   my $ok = $nos->inbox_message(
596            list => 'My list',
597            message => $message,
598     );
599    
600    This method is used by C<sender.pl> when receiving e-mail messages.
601    
602  =cut  =cut
603    
604  sub inbox_message {  sub inbox_message {
605          my $self = shift;          my $self = shift;
606    
607          my $message = shift || return;          my $arg = {@_};
608    
609            return unless ($arg->{'message'});
610            croak "need list name" unless ($arg->{'list'});
611    
612            $arg->{'list'} = lc($arg->{'list'});
613    
614            my $this_list = $self->_get_list($arg->{'list'}) || croak "can't find list ".$arg->{'list'}."\n";
615    
616            my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message";
617    
618            my $to = $m->header('To') || die "can't find To: address in incomming message\n";
619    
620            my $return_path = $m->header('Return-Path') || '';
621    
622            my @addrs = Email::Address->parse( $to );
623    
624            die "can't parse To: $to address\n" unless (@addrs);
625    
626            my $hl = $self->{'hash_len'} || confess "no hash_len?";
627    
628            my $hash;
629    
630            foreach my $a (@addrs) {
631                    if ($a->address =~ m/\+([a-f0-9]{$hl})@/i) {
632                            $hash = $1;
633                            last;
634                    }
635            }
636    
637            #warn "can't find hash in e-mail $to\n" unless ($hash);
638    
639            my $sent = $self->{'loader'}->find_class('sent');
640    
641            # will use null if no matching message_id is found
642            my $sent_msg;
643            $sent_msg = $sent->search( hash => $hash )->first if ($hash);
644    
645            my ($message_id, $user_id) = (undef, undef);    # init with NULL
646    
647            if ($sent_msg) {
648                    $message_id = $sent_msg->message_id || carp "no message_id";
649                    $user_id = $sent_msg->user_id || carp "no user_id";
650            } else {
651                    #warn "can't find sender with hash $hash\n";
652                    my $users = $self->{'loader'}->find_class('users');
653                    my $from = $m->header('From');
654                    $from = $1 if ($from =~ m/<(.*)>/);
655                    my $this_user = $users->search( email => lc($from) )->first;
656                    $user_id = $this_user->id if ($this_user);
657            }
658    
659    
660          my $m = new Email::Simple->new($message);          my $is_bounce = 0;
661    
662            if ($return_path eq '<>' || $return_path eq '') {
663                    no warnings;
664                    my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
665                            $arg->{'message'}, { report_non_bounces=>1 },
666                    ) };
667                    #warn "can't check if this message is bounce!" if ($@);
668            
669                    $is_bounce++ if ($bounce && $bounce->is_bounce);
670            }
671    
672            my $received = $self->{'loader'}->find_class('received');
673    
674            my $this_received = $received->find_or_create({
675                    user_id => $user_id,
676                    list_id => $this_list->id,
677                    message_id => $message_id,
678                    message => $arg->{'message'},
679                    bounced => $is_bounce,
680            }) || croak "can't insert received message";
681    
682            $this_received->dbi_commit;
683    
684    #       print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
685  }  }
686    
687    
# Line 287  sub inbox_message { Line 689  sub inbox_message {
689    
690  Beware of dragons! You shouldn't need to call those methods directly.  Beware of dragons! You shouldn't need to call those methods directly.
691    
692    
693    =head2 _add_aliases
694    
695    Add new list to C</etc/aliases> (or equivavlent) file
696    
697     my $ok = $nos->add_aliases(
698            list => 'My list',
699            email => 'my-list@example.com',
700            aliases => '/etc/mail/mylist',
701            archive => '/path/to/mbox/archive',
702    
703     );
704    
705    C<archive> parametar is optional.
706    
707    Return false on failure.
708    
709    =cut
710    
711    sub _add_aliases {
712            my $self = shift;
713    
714            my $arg = {@_};
715    
716            croak "need list and email options" unless ($arg->{'list'} && $arg->{'email'});
717    
718            my $aliases = $arg->{'aliases'} || croak "need aliases";
719    
720            unless (-e $aliases) {
721                    warn "aliases file $aliases doesn't exist, creating empty\n";
722                    open(my $fh, '>', $aliases) || croak "can't create $aliases: $!";
723                    close($fh);
724            }
725    
726            my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
727    
728            my $target = '';
729    
730            if (my $archive = $arg->{'archive'}) {
731                    $target .= "$archive, ";
732    
733                    if (! -e $archive) {
734                            warn "please make sure that file $archive is writable for your e-mail user (defaulting to bad 777 permission for now)";
735    
736                            open(my $fh, '>', $archive) || croak "can't create archive file $archive: $!";
737                            close($fh);
738                            chmod 0777, $archive || croak "can't chmod archive file $archive to 0777: $!";
739                    }
740            }
741    
742            # resolve my path to absolute one
743            my $self_path = abs_path($0);
744            $self_path =~ s#/[^/]+$##;
745            $self_path =~ s#/t/*$#/#;
746    
747            $target .= qq#| cd $self_path && ./sender.pl --inbox="$arg->{'list'}"#;
748    
749            unless ($a->append($arg->{'email'}, $target)) {
750                    croak "can't add alias ".$a->error_check;
751            }
752    
753            return 1;
754    }
755    
756  =head2 _add_list  =head2 _add_list
757    
758  Create new list  Create new list
759    
760   my $list_obj = $nos->_add_list(   my $list_obj = $nos->_add_list(
761          list => 'My list',          list => 'My list',
762            from => 'Outgoing from comment',
763          email => 'my-list@example.com',          email => 'my-list@example.com',
764            aliases => '/etc/mail/mylist',
765   );   );
766    
767  Returns C<Class::DBI> object for created list.  Returns C<Class::DBI> object for created list.
768    
769    C<email> address can be with domain or without it if your
770    MTA appends it. There is no checking for validity of your
771    list e-mail. Flexibility comes with resposibility, so please
772    feed correct (and configured) return addresses.
773    
774  =cut  =cut
775    
776  sub _add_list {  sub _add_list {
# Line 305  sub _add_list { Line 778  sub _add_list {
778    
779          my $arg = {@_};          my $arg = {@_};
780    
781          my $name = $arg->{'list'} || confess "can't add list without name";          my $name = lc($arg->{'list'}) || confess "can't add list without name";
782          my $email = $arg->{'email'} || confess "can't add list without e-mail";          my $email = lc($arg->{'email'}) || confess "can't add list without e-mail";
783            my $aliases = lc($arg->{'aliases'}) || confess "can't add list without path to aliases file";
784    
785            my $from_addr = $arg->{'from'};
786    
787          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
788    
789            $self->_add_aliases(
790                    list => $name,
791                    email => $email,
792                    aliases => $aliases,
793            ) || croak "can't add alias $email for list $name";
794    
795          my $l = $lists->find_or_create({          my $l = $lists->find_or_create({
796                  name => $name,                  name => $name,
797                  email => $email,                  email => $email,
798          });          });
799            
800          croak "can't add list $name\n" unless ($l);          croak "can't add list $name\n" unless ($l);
801    
802            if ($from_addr && $l->from_addr ne $from_addr) {
803                    $l->from_addr($from_addr);
804                    $l->update;
805            }
806    
807          $l->dbi_commit;          $l->dbi_commit;
808    
809          return $l;          return $l;
# Line 324  sub _add_list { Line 811  sub _add_list {
811  }  }
812    
813    
814    
815  =head2 _get_list  =head2 _get_list
816    
817  Get list C<Class::DBI> object.  Get list C<Class::DBI> object.
# Line 341  sub _get_list { Line 829  sub _get_list {
829    
830          my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";          my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";
831    
832          return $lists->search({ name => $name })->first;          return $lists->search({ name => lc($name) })->first;
833    }
834    
835    ###
836    ### SOAP
837    ###
838    
839    package Nos::SOAP;
840    
841    use Carp;
842    
843    =head1 SOAP methods
844    
845    This methods are thin wrappers to provide SOAP calls. They are grouped in
846    C<Nos::SOAP> package which is in same F<Nos.pm> module file.
847    
848    Usually, you want to use named variables in your SOAP calls if at all
849    possible.
850    
851    However, if you have broken SOAP library (like PHP SOAP class from PEAR)
852    you will want to use positional arguments (in same order as documented for
853    methods below).
854    
855    =cut
856    
857    my $nos;
858    
859    
860    =head2 new
861    
862    Create new SOAP object
863    
864     my $soap = new Nos::SOAP(
865            dsn => 'dbi:Pg:dbname=notices',
866            user => 'dpavlin',
867            passwd => '',
868            debug => 1,
869            verbose => 1,
870            hash_len => 8,
871            aliases => '/etc/aliases',
872     );
873    
874    =cut
875    
876    sub new {
877            my $class = shift;
878            my $self = {@_};
879    
880            croak "need aliases parametar" unless ($self->{'aliases'});
881    
882            bless($self, $class);
883    
884            $nos = new Nos( @_ ) || die "can't create Nos object";
885    
886            $self ? return $self : return undef;
887    }
888    
889    
890    =head2 NewList
891    
892     $message_id = NewList(
893            list => 'My list',
894            from => 'Name of my list',
895            email => 'my-list@example.com'
896     );
897    
898    =cut
899    
900    sub NewList {
901            my $self = shift;
902    
903            my $aliases = $self->{'aliases'} || croak "Nos::SOAP need 'aliases' argument to new constructor";
904    
905            if ($_[0] !~ m/^HASH/) {
906                    return $nos->new_list(
907                            list => $_[0], from => $_[1], email => $_[2],
908                            aliases => $aliases,
909                    );
910            } else {
911                    return $nos->new_list( %{ shift @_ }, aliases => $aliases );
912            }
913    }
914    
915    
916    =head2 DeleteList
917    
918     $ok = DeleteList(
919            list => 'My list',
920     );
921    
922    =cut
923    
924    sub DeleteList {
925            my $self = shift;
926    
927            if ($_[0] !~ m/^HASH/) {
928                    return $nos->delete_list(
929                            list => $_[0],
930                    );
931            } else {
932                    return $nos->delete_list( %{ shift @_ } );
933            }
934    }
935    
936    =head2 AddMemberToList
937    
938     $member_id = AddMemberToList(
939            list => 'My list',
940            email => 'e-mail@example.com',
941            name => 'Full Name',
942            ext_id => 42,
943     );
944    
945    =cut
946    
947    sub AddMemberToList {
948            my $self = shift;
949    
950            if ($_[0] !~ m/^HASH/) {
951                    return $nos->add_member_to_list(
952                            list => $_[0], email => $_[1], name => $_[2], ext_id => $_[4],
953                    );
954            } else {
955                    return $nos->add_member_to_list( %{ shift @_ } );
956            }
957    }
958    
959    
960    =head2 ListMembers
961    
962     my @members = ListMembers(
963            list => 'My list',
964     );
965    
966    Returns array of hashes with user informations, see C<list_members>.
967    
968    Returning arrays from SOAP calls is somewhat fuzzy (at least to me). It
969    seems that SOAP::Lite client thinks that it has array with one element which
970    is array of hashes with data.
971    
972    =cut
973    
974    sub ListMembers {
975            my $self = shift;
976    
977            my $list_name;
978    
979            if ($_[0] !~ m/^HASH/) {
980                    $list_name = shift;
981            } else {
982                    $list_name = $_[0]->{'list'};
983            }
984    
985            return [ $nos->list_members( list => $list_name ) ];
986    }
987    
988    
989    =head2 DeleteMemberFromList
990    
991     $member_id = DeleteMemberFromList(
992            list => 'My list',
993            email => 'e-mail@example.com',
994     );
995    
996    =cut
997    
998    sub DeleteMemberFromList {
999            my $self = shift;
1000    
1001            if ($_[0] !~ m/^HASH/) {
1002                    return $nos->delete_member_from_list(
1003                            list => $_[0], email => $_[1],
1004                    );
1005            } else {
1006                    return $nos->delete_member_from_list( %{ shift @_ } );
1007            }
1008    }
1009    
1010    
1011    =head2 AddMessageToList
1012    
1013     $message_id = AddMessageToList(
1014            list => 'My list',
1015            message => 'From: My list...'
1016     );
1017    
1018    =cut
1019    
1020    sub AddMessageToList {
1021            my $self = shift;
1022    
1023            if ($_[0] !~ m/^HASH/) {
1024                    return $nos->add_message_to_list(
1025                            list => $_[0], message => $_[1],
1026                    );
1027            } else {
1028                    return $nos->add_message_to_list( %{ shift @_ } );
1029            }
1030  }  }
1031    
1032    
1033    ###
1034    
1035  =head1 EXPORT  =head1 EXPORT
1036    
1037  Nothing.  Nothing.
# Line 369  at your option, any later version of Per Line 1056  at your option, any later version of Per
1056    
1057    
1058  =cut  =cut
1059    
1060    1;
Legend:
Removed from v.32  
changed lines
  Added in v.66
  ViewVC Help
Powered by ViewVC 1.1.26