notice-sender/trunk/Nos.pm

package Nos;

use 5.008;
use strict;
use warnings;

require Exporter;

our @ISA = qw(Exporter);

our %EXPORT_TAGS = ( 'all' => [ qw(
) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw( 
);

our $VERSION = '0.4';

use Class::DBI::Loader;
use Email::Valid;
use Email::Send;
use Carp;
use Email::Auth::AddressHash;
use Email::Simple;
use Email::Address;
use Mail::DeliveryStatus::BounceParser;


=head1 NAME

Nos - Notice Sender core module

=head1 SYNOPSIS

  use Nos;
  my $nos = new Nos();

=head1 DESCRIPTION

Core module for notice sender's functionality.

=head1 METHODS

=head2 new

Create new instance specifing database, user, password and options.

 my $nos = new Nos(
        dsn => 'dbi:Pg:dbname=notices',
        user => 'dpavlin',
        passwd => '',
        debug => 1,
        verbose => 1,
        hash_len => 8,
 );

Parametar C<hash_len> defines length of hash which will be added to each
outgoing e-mail message to ensure that replies can be linked with sent e-mails.

=cut

sub new {
        my $class = shift;
        my $self = {@_};
        bless($self, $class);

        croak "need at least dsn" unless ($self->{'dsn'});

        $self->{'loader'} = Class::DBI::Loader->new(
                debug           => $self->{'debug'},
                dsn             => $self->{'dsn'},
                user            => $self->{'user'},
                password        => $self->{'passwd'},
                namespace       => "Nos",
#               additional_classes      => qw/Class::DBI::AbstractSearch/,
#               additional_base_classes => qw/My::Stuff/,
                relationships   => 1,
        ) || croak "can't init Class::DBI::Loader";

        $self->{'hash_len'} ||= 8;

        $self ? return $self : return undef;
}


=head2 new_list

Create new list. Required arguments are name of C<list> and
C<email> address.

 $nos->new_list(
        list => 'My list',
        from => 'Outgoing from comment',
        email => 'my-list@example.com',
 );

Returns ID of newly created list.

Calls internally L<_add_list>, see details there.

=cut

sub new_list {
        my $self = shift;

        my $arg = {@_};

        confess "need list name" unless ($arg->{'list'});
        confess "need list email" unless ($arg->{'list'});

        my $l = $self->_get_list($arg->{'list'}) ||
                $self->_add_list( @_ ) ||
                return undef;

        return $l->id;
}


=head2 add_member_to_list

Add new member to list

 $nos->add_member_to_list(
        list => "My list",
        email => "john.doe@example.com",
        name => "John A. Doe",
 );

C<name> parametar is optional.

Return member ID if user is added.

=cut

sub add_member_to_list {
        my $self = shift;

        my $arg = {@_};

        my $email = $arg->{'email'} || croak "can't add user without e-mail";
        my $name = $arg->{'name'} || '';
        my $list_name = $arg->{'list'} || croak "need list name";

        my $list = $self->_get_list($list_name) || croak "list $list_name doesn't exist";

        if (! Email::Valid->address($email)) {
                carp "SKIPPING $name <$email>\n";
                return 0;
        }

        carp "# $name <$email>\n" if ($self->{'verbose'});

        my $users = $self->{'loader'}->find_class('users');
        my $user_list = $self->{'loader'}->find_class('user_list');

        my $this_user = $users->find_or_create({
                email => $email,
        }) || croak "can't find or create member\n";

        if ($name && $this_user->name ne $name) {
                $this_user->name($name || '');
                $this_user->update;
        }

        my $user_on_list = $user_list->find_or_create({
                user_id => $this_user->id,
                list_id => $list->id,
        }) || croak "can't add user to list";

        $list->dbi_commit;
        $this_user->dbi_commit;
        $user_on_list->dbi_commit;

        return $this_user->id;
}

=head2 list_members

List all members of some list.

 my @members = list_members(
        list => 'My list',
 );

Returns array of hashes with user informations like this:

 $member = {
        name => 'Dobrica Pavlinusic',
        email => 'dpavlin@rot13.org
 }

If list is not found, returns false.

=cut

sub list_members {
        my $self = shift;

        my $args = {@_};

        my $list_name = $args->{'list'} || confess "need list name";

        my $lists = $self->{'loader'}->find_class('lists');
        my $user_list = $self->{'loader'}->find_class('user_list');

        my $this_list = $lists->search( name => $list_name )->first || return;

        my @results;

        foreach my $user_on_list ($user_list->search(list_id => $this_list->id)) {
                my $row = {
                        name => $user_on_list->user_id->name,
                        email => $user_on_list->user_id->email,
                };

                push @results, $row;
        }

        return @results;

}


=head2 delete_member

Delete member from database.

 my $ok = delete_member(
        name => 'Dobrica Pavlinusic'
 );

 my $ok = delete_member(
        email => 'dpavlin@rot13.org'
 );

Returns false if user doesn't exist.

=cut

sub delete_member {
        my $self = shift;

        my $args = {@_};

        croak "need name or email of user to delete" unless ($args->{'name'} || $args->{'email'});

        my $key = 'name';
        $key = 'email' if ($args->{'email'});

        my $users = $self->{'loader'}->find_class('users');

        my $this_user = $users->search( $key => $args->{$key} )->first || return;

        $this_user->delete || croak "can't delete user\n";

        return $users->dbi_commit || croak "can't commit";
}

=head2 add_message_to_list

Adds message to one list's queue for later sending.

 $nos->add_message_to_list(
        list => 'My list',
        message => 'Subject: welcome to list

 This is example message
 ',
 );     

On success returns ID of newly created (or existing) message.

Only required header in e-mail is C<Subject:>. C<From:> and C<To:> headers
will be automatically generated, but if you want to use own headers, just
include them in messages.

=cut

sub add_message_to_list {
        my $self = shift;

        my $args = {@_};

        my $list_name = $args->{'list'} || confess "need list name";
        my $message_text = $args->{'message'} || croak "need message";

        my $m = Email::Simple->new($message_text) || croak "can't parse message";

        unless( $m->header('Subject') ) {
                warn "message doesn't have Subject header\n";
                return;
        }

        my $lists = $self->{'loader'}->find_class('lists');

        my $this_list = $lists->search(
                name => $list_name,
        )->first || croak "can't find list $list_name";

        my $messages = $self->{'loader'}->find_class('messages');

        my $this_message = $messages->find_or_create({
                message => $message_text
        }) || croak "can't insert message";

        $this_message->dbi_commit() || croak "can't add message";

        my $queue = $self->{'loader'}->find_class('queue');

        $queue->find_or_create({
                message_id => $this_message->id,
                list_id => $this_list->id,
        }) || croak "can't add message ",$this_message->id," to list ",$this_list->id, ": ",$this_list->name;

        $queue->dbi_commit || croak "can't add message to list ",$this_list->name;

        return $this_message->id;
}


=head2 send_queued_messages

Send queued messages or just ones for selected list

 $nos->send_queued_messages(
        list => 'My list',
        driver => 'smtp',
        sleep => 3,
 );

Second option is driver which will be used for e-mail delivery. If not
specified, C<IO> driver will be used which will dump e-mail to C<STDERR>.

Other valid drivers are:

=over 10

=item smtp

Send e-mail using SMTP server at 127.0.0.1

=back

Default sleep wait between two messages is 3 seconds.

=cut

sub send_queued_messages {
        my $self = shift;

        my $arg = {@_};

        my $list_name = $arg->{'list'} || '';
        my $driver = $arg->{'driver'} || '';
        my $sleep = $arg->{'sleep'};
        $sleep ||= 3 unless defined($sleep);

        my $email_send_driver = 'Email::Send::IO';
        my @email_send_options;

        if (lc($driver) eq 'smtp') {
                $email_send_driver = 'Email::Send::SMTP';
                @email_send_options = ['127.0.0.1'];
        }
        warn "using $driver [$email_send_driver]\n";

        my $lists = $self->{'loader'}->find_class('lists');
        my $queue = $self->{'loader'}->find_class('queue');
        my $user_list = $self->{'loader'}->find_class('user_list');
        my $sent = $self->{'loader'}->find_class('sent');

        my $my_q;
        if ($list_name ne '') {
                my $l_id = $lists->search_like( name => $list_name )->first ||
                        croak "can't find list $list_name";
                $my_q = $queue->search_like( list_id => $l_id ) ||
                        croak "can't find list $list_name";
        } else {
                $my_q = $queue->retrieve_all;
        }

        while (my $m = $my_q->next) {
                next if ($m->all_sent);

                print "sending message ",$m->message_id," enqueued on ",$m->date," to list ",$m->list_id->name,"\n";
                my $msg = $m->message_id->message;

                foreach my $u ($user_list->search(list_id => $m->list_id)) {

                        my $to_email = $u->user_id->email;

                        my ($from,$domain) = split(/@/, $u->list_id->email, 2);

                        if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {
                                print "SKIP $to_email message allready sent\n";
                        } else {
                                print "=> $to_email\n";

                                my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;
                                my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );

                                my $hash = $auth->generate_hash( $to_email );

                                my $from_addr;
                                my $from_email_only = $from . "+" . $hash . ( $domain ? '@' . $domain : '');

                                $from_addr .= '"' . $u->list_id->from_addr . '" ' if ($u->list_id->from_addr);
                                $from_addr .= '<' . $from_email_only . '>';
                                my $to = '"' . $u->user_id->name . '" <' . $to_email . '>';

                                my $m_obj = Email::Simple->new($msg) || croak "can't parse message";

                                $m_obj->header_set('Return-Path', $from_email_only) || croak "can't set Return-Path: header";
                                $m_obj->header_set('Sender', $from_email_only) || croak "can't set Sender: header";
                                $m_obj->header_set('Errors-To', $from_email_only) || croak "can't set Errors-To: header";
                                $m_obj->header_set('From', $from_addr) || croak "can't set From: header";
                                $m_obj->header_set('To', $to) || croak "can't set To: header";

                                $m_obj->header_set('X-Nos-Version', $VERSION);
                                $m_obj->header_set('X-Nos-Hash', $hash);

                                # really send e-mail
                                if (@email_send_options) {
                                        send $email_send_driver => $m_obj->as_string, @email_send_options;
                                } else {
                                        send $email_send_driver => $m_obj->as_string;
                                }

                                $sent->create({
                                        message_id => $m->message_id,
                                        user_id => $u->user_id,
                                        hash => $hash,
                                });
                                $sent->dbi_commit;

                                if ($sleep) {
                                        warn "sleeping $sleep seconds\n";
                                        sleep($sleep);
                                }
                        }
                }
                $m->all_sent(1);
                $m->update;
                $m->dbi_commit;
        }

}

=head2 inbox_message

Receive single message for list's inbox.

 my $ok = $nos->inbox_message(
        list => 'My list',
        message => $message,
 );

=cut

sub inbox_message {
        my $self = shift;

        my $arg = {@_};

        return unless ($arg->{'message'});
        croak "need list name" unless ($arg->{'list'});

        my $this_list = $self->_get_list($arg->{'list'}) || croak "can't find list ".$arg->{'list'}."\n";

        my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message";

        my $to = $m->header('To') || die "can't find To: address in incomming message\n";

        my $return_path = $m->header('Return-Path') || '';

        my @addrs = Email::Address->parse( $to );

        die "can't parse To: $to address\n" unless (@addrs);

        my $hl = $self->{'hash_len'} || confess "no hash_len?";

        my $hash;

        foreach my $a (@addrs) {
                if ($a->address =~ m/\+([a-f0-9]{$hl})@/) {
                        $hash = $1;
                        last;
                }
        }

        #warn "can't find hash in e-mail $to\n" unless ($hash);

        my $sent = $self->{'loader'}->find_class('sent');

        # will use null if no matching message_id is found
        my $sent_msg;
        $sent_msg = $sent->search( hash => $hash )->first if ($hash);

        my ($message_id, $user_id) = (undef, undef);    # init with NULL

        if ($sent_msg) {
                $message_id = $sent_msg->message_id || carp "no message_id";
                $user_id = $sent_msg->user_id || carp "no user_id";
        } else {
                #warn "can't find sender with hash $hash\n";
                my $users = $self->{'loader'}->find_class('users');
                my $from = $m->header('From');
                $from = $1 if ($from =~ m/<(.*)>/);
                my $this_user = $users->search( email => $from )->first;
                $user_id = $this_user->id if ($this_user);
        }


        my $is_bounce = 0;

        if ($return_path eq '<>' || $return_path eq '') {
                no warnings;
                my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
                        $arg->{'message'}, { report_non_bounces=>1 },
                ) };
                #warn "can't check if this message is bounce!" if ($@);
        
                $is_bounce++ if ($bounce && $bounce->is_bounce);
        }

        my $received = $self->{'loader'}->find_class('received');

        my $this_received = $received->find_or_create({
                user_id => $user_id,
                list_id => $this_list->id,
                message_id => $message_id,
                message => $arg->{'message'},
                bounced => $is_bounce,
        }) || croak "can't insert received message";

        $this_received->dbi_commit;

#       print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
}


=head1 INTERNAL METHODS

Beware of dragons! You shouldn't need to call those methods directly.

=head2 _add_list

Create new list

 my $list_obj = $nos->_add_list(
        list => 'My list',
        from => 'Outgoing from comment',
        email => 'my-list@example.com',
 );

Returns C<Class::DBI> object for created list.

C<email> address can be with domain or without it if your
MTA appends it. There is no checking for validity of your
list e-mail. Flexibility comes with resposibility, so please
feed correct (and configured) return addresses.

=cut

sub _add_list {
        my $self = shift;

        my $arg = {@_};

        my $name = $arg->{'list'} || confess "can't add list without name";
        my $email = $arg->{'email'} || confess "can't add list without e-mail";
        my $from_addr = $arg->{'from'};

        my $lists = $self->{'loader'}->find_class('lists');

        my $l = $lists->find_or_create({
                name => $name,
                email => $email,
        });

        croak "can't add list $name\n" unless ($l);

        if ($from_addr && $l->from_addr ne $from_addr) {
                $l->from_addr($from_addr);
                $l->update;
        }

        $l->dbi_commit;

        return $l;

}


=head2 _get_list

Get list C<Class::DBI> object.

 my $list_obj = $nos->check_list('My list');

Returns false on failure.

=cut

sub _get_list {
        my $self = shift;

        my $name = shift || return;

        my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";

        return $lists->search({ name => $name })->first;
}

###
### SOAP
###

package Nos::SOAP;

use Carp;

=head1 SOAP methods

This methods are thin wrappers to provide SOAP calls. They are grouped in
C<Nos::SOAP> package which is in same F<Nos.pm> module file.

Usually, you want to use named variables in your SOAP calls if at all
possible.

However, if you have broken SOAP library (like PHP SOAP class from PEAR)
you will want to use positional arguments (in same order as documented for
methods below).

=cut

my $nos;

sub new {
        my $class = shift;
        my $self = {@_};
        bless($self, $class);

        $nos = new Nos( @_ ) || die "can't create Nos object";

        $self ? return $self : return undef;
}


=head2 NewList

 $message_id = NewList(
        list => 'My list',
        email => 'my-list@example.com'
 ); 

=cut

sub NewList {
        my $self = shift;

        if ($_[0] !~ m/^HASH/) {
                return $nos->new_list(
                        list => $_[0], email => $_[1],
                );
        } else {
                return $nos->new_list( %{ shift @_ } );
        }
}


=head2 AddMemberToList

 $member_id = AddMemberToList(
        list => 'My list',
        email => 'e-mail@example.com',
        name => 'Full Name'
 );

=cut

sub AddMemberToList {
        my $self = shift;

        if ($_[0] !~ m/^HASH/) {
                return $nos->add_member_to_list(
                        list => $_[0], email => $_[1], name => $_[2],
                );
        } else {
                return $nos->add_member_to_list( %{ shift @_ } );
        }
}


=head2 ListMembers

 my @members = ListMembers(
        list => 'My list',
 );

Returns array of hashes with user informations, see C<list_members>.

=cut

sub ListMembers {
        my $self = shift;

        my $list_name;

        if ($_[0] !~ m/^HASH/) {
                $list_name = shift;
        } else {
                $list_name = $_[0]->{'list'};
        }

        return $nos->list_members( list => $list_name );
}

=head2 AddMessageToList

 $message_id = AddMessageToList(
        list => 'My list',
        message => 'From: My list...'
 ); 

=cut

sub AddMessageToList {
        my $self = shift;

        if ($_[0] !~ m/^HASH/) {
                return $nos->add_message_to_list(
                        list => $_[0], message => $_[1],
                );
        } else {
                return $nos->add_message_to_list( %{ shift @_ } );
        }
}


###

=head1 EXPORT

Nothing.

=head1 SEE ALSO

mailman, ezmlm, sympa, L<Mail::Salsa>


=head1 AUTHOR

Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>


=head1 COPYRIGHT AND LICENSE

Copyright (C) 2005 by Dobrica Pavlinusic

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.4 or,
at your option, any later version of Perl 5 you may have available.


=cut

1;
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	45	our $VERSION = '0.4';
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	37	use Mail::DeliveryStatus::BounceParser;
29	dpavlin	20
30	dpavlin	47
31	dpavlin	20	=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	dpavlin	36	hash_len => 8,
57	dpavlin	20	);
58
59	dpavlin	38	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	dpavlin	36
62	dpavlin	20	=cut
63
64			sub new {
65			my $class = shift;
66			my $self = {@_};
67			bless($self, $class);
68
69	dpavlin	22	croak "need at least dsn" unless ($self->{'dsn'});
70
71	dpavlin	20	$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	dpavlin	22	) \|\| croak "can't init Class::DBI::Loader";
81	dpavlin	20
82	dpavlin	36	$self->{'hash_len'} \|\|= 8;
83
84	dpavlin	20	$self ? return $self : return undef;
85			}
86
87	dpavlin	30
88	dpavlin	33	=head2 new_list
89
90	dpavlin	38	Create new list. Required arguments are name of C<list> and
91			C<email> address.
92	dpavlin	33
93			$nos->new_list(
94	dpavlin	38	list => 'My list',
95	dpavlin	47	from => 'Outgoing from comment',
96	dpavlin	33	email => 'my-list@example.com',
97			);
98
99			Returns ID of newly created list.
100
101	dpavlin	38	Calls internally L<_add_list>, see details there.
102
103	dpavlin	33	=cut
104
105			sub new_list {
106			my $self = shift;
107
108			my $arg = {@_};
109
110			confess "need list name" unless ($arg->{'list'});
111			confess "need list email" unless ($arg->{'list'});
112
113			my $l = $self->_get_list($arg->{'list'}) \|\|
114			$self->_add_list( @_ ) \|\|
115			return undef;
116
117			return $l->id;
118			}
119
120
121	dpavlin	23	=head2 add_member_to_list
122
123			Add new member to list
124
125			$nos->add_member_to_list(
126			list => "My list",
127			email => "john.doe@example.com",
128			name => "John A. Doe",
129			);
130
131			C<name> parametar is optional.
132
133	dpavlin	27	Return member ID if user is added.
134	dpavlin	23
135			=cut
136
137			sub add_member_to_list {
138			my $self = shift;
139
140			my $arg = {@_};
141
142	dpavlin	30	my $email = $arg->{'email'} \|\| croak "can't add user without e-mail";
143	dpavlin	23	my $name = $arg->{'name'} \|\| '';
144	dpavlin	30	my $list_name = $arg->{'list'} \|\| croak "need list name";
145	dpavlin	23
146	dpavlin	30	my $list = $self->_get_list($list_name) \|\| croak "list $list_name doesn't exist";
147
148	dpavlin	23	if (! Email::Valid->address($email)) {
149	dpavlin	33	carp "SKIPPING $name <$email>\n";
150	dpavlin	23	return 0;
151			}
152
153	dpavlin	29	carp "# $name <$email>\n" if ($self->{'verbose'});
154	dpavlin	23
155			my $users = $self->{'loader'}->find_class('users');
156			my $user_list = $self->{'loader'}->find_class('user_list');
157
158			my $this_user = $users->find_or_create({
159			email => $email,
160			}) \|\| croak "can't find or create member\n";
161
162	dpavlin	45	if ($name && $this_user->name ne $name) {
163			$this_user->name($name \|\| '');
164	dpavlin	33	$this_user->update;
165			}
166
167	dpavlin	23	my $user_on_list = $user_list->find_or_create({
168			user_id => $this_user->id,
169			list_id => $list->id,
170			}) \|\| croak "can't add user to list";
171
172			$list->dbi_commit;
173			$this_user->dbi_commit;
174			$user_on_list->dbi_commit;
175
176	dpavlin	27	return $this_user->id;
177	dpavlin	23	}
178
179	dpavlin	43	=head2 list_members
180
181	dpavlin	45	List all members of some list.
182
183	dpavlin	43	my @members = list_members(
184			list => 'My list',
185			);
186
187			Returns array of hashes with user informations like this:
188
189			$member = {
190	dpavlin	45	name => 'Dobrica Pavlinusic',
191	dpavlin	43	email => 'dpavlin@rot13.org
192			}
193
194	dpavlin	45	If list is not found, returns false.
195
196	dpavlin	43	=cut
197
198			sub list_members {
199			my $self = shift;
200
201			my $args = {@_};
202
203			my $list_name = $args->{'list'} \|\| confess "need list name";
204
205			my $lists = $self->{'loader'}->find_class('lists');
206			my $user_list = $self->{'loader'}->find_class('user_list');
207
208	dpavlin	45	my $this_list = $lists->search( name => $list_name )->first \|\| return;
209	dpavlin	43
210			my @results;
211
212			foreach my $user_on_list ($user_list->search(list_id => $this_list->id)) {
213			my $row = {
214	dpavlin	45	name => $user_on_list->user_id->name,
215	dpavlin	43	email => $user_on_list->user_id->email,
216			};
217
218			push @results, $row;
219			}
220
221			return @results;
222
223			}
224
225
226	dpavlin	45	=head2 delete_member
227
228			Delete member from database.
229
230			my $ok = delete_member(
231			name => 'Dobrica Pavlinusic'
232			);
233
234			my $ok = delete_member(
235			email => 'dpavlin@rot13.org'
236			);
237
238			Returns false if user doesn't exist.
239
240			=cut
241
242			sub delete_member {
243			my $self = shift;
244
245			my $args = {@_};
246
247			croak "need name or email of user to delete" unless ($args->{'name'} \|\| $args->{'email'});
248
249			my $key = 'name';
250			$key = 'email' if ($args->{'email'});
251
252			my $users = $self->{'loader'}->find_class('users');
253
254			my $this_user = $users->search( $key => $args->{$key} )->first \|\| return;
255
256			$this_user->delete \|\| croak "can't delete user\n";
257
258			return $users->dbi_commit \|\| croak "can't commit";
259			}
260
261	dpavlin	29	=head2 add_message_to_list
262	dpavlin	24
263			Adds message to one list's queue for later sending.
264
265	dpavlin	29	$nos->add_message_to_list(
266	dpavlin	24	list => 'My list',
267	dpavlin	36	message => 'Subject: welcome to list
268	dpavlin	38
269	dpavlin	24	This is example message
270			',
271			);
272
273			On success returns ID of newly created (or existing) message.
274
275	dpavlin	36	Only required header in e-mail is C<Subject:>. C<From:> and C<To:> headers
276			will be automatically generated, but if you want to use own headers, just
277			include them in messages.
278
279	dpavlin	24	=cut
280
281	dpavlin	29	sub add_message_to_list {
282	dpavlin	24	my $self = shift;
283
284			my $args = {@_};
285
286			my $list_name = $args->{'list'} \|\| confess "need list name";
287			my $message_text = $args->{'message'} \|\| croak "need message";
288
289	dpavlin	29	my $m = Email::Simple->new($message_text) \|\| croak "can't parse message";
290
291	dpavlin	32	unless( $m->header('Subject') ) {
292			warn "message doesn't have Subject header\n";
293			return;
294			}
295	dpavlin	29
296	dpavlin	24	my $lists = $self->{'loader'}->find_class('lists');
297
298			my $this_list = $lists->search(
299			name => $list_name,
300			)->first \|\| croak "can't find list $list_name";
301
302			my $messages = $self->{'loader'}->find_class('messages');
303
304			my $this_message = $messages->find_or_create({
305			message => $message_text
306			}) \|\| croak "can't insert message";
307
308			$this_message->dbi_commit() \|\| croak "can't add message";
309
310			my $queue = $self->{'loader'}->find_class('queue');
311
312			$queue->find_or_create({
313			message_id => $this_message->id,
314			list_id => $this_list->id,
315			}) \|\| croak "can't add message ",$this_message->id," to list ",$this_list->id, ": ",$this_list->name;
316
317			$queue->dbi_commit \|\| croak "can't add message to list ",$this_list->name;
318
319			return $this_message->id;
320			}
321
322
323	dpavlin	22	=head2 send_queued_messages
324	dpavlin	20
325	dpavlin	22	Send queued messages or just ones for selected list
326	dpavlin	20
327	dpavlin	49	$nos->send_queued_messages(
328			list => 'My list',
329			driver => 'smtp',
330			sleep => 3,
331			);
332	dpavlin	20
333	dpavlin	47	Second option is driver which will be used for e-mail delivery. If not
334			specified, C<IO> driver will be used which will dump e-mail to C<STDERR>.
335
336			Other valid drivers are:
337
338			=over 10
339
340			=item smtp
341
342			Send e-mail using SMTP server at 127.0.0.1
343
344			=back
345
346	dpavlin	49	Default sleep wait between two messages is 3 seconds.
347
348	dpavlin	21	=cut
349	dpavlin	20
350	dpavlin	22	sub send_queued_messages {
351	dpavlin	21	my $self = shift;
352	dpavlin	20
353	dpavlin	49	my $arg = {@_};
354	dpavlin	20
355	dpavlin	49	my $list_name = $arg->{'list'} \|\| '';
356			my $driver = $arg->{'driver'} \|\| '';
357			my $sleep = $arg->{'sleep'};
358			$sleep \|\|= 3 unless defined($sleep);
359	dpavlin	47
360	dpavlin	49	my $email_send_driver = 'Email::Send::IO';
361			my @email_send_options;
362
363	dpavlin	47	if (lc($driver) eq 'smtp') {
364			$email_send_driver = 'Email::Send::SMTP';
365			@email_send_options = ['127.0.0.1'];
366			}
367			warn "using $driver [$email_send_driver]\n";
368
369	dpavlin	22	my $lists = $self->{'loader'}->find_class('lists');
370			my $queue = $self->{'loader'}->find_class('queue');
371			my $user_list = $self->{'loader'}->find_class('user_list');
372			my $sent = $self->{'loader'}->find_class('sent');
373	dpavlin	20
374	dpavlin	22	my $my_q;
375			if ($list_name ne '') {
376			my $l_id = $lists->search_like( name => $list_name )->first \|\|
377			croak "can't find list $list_name";
378			$my_q = $queue->search_like( list_id => $l_id ) \|\|
379			croak "can't find list $list_name";
380			} else {
381			$my_q = $queue->retrieve_all;
382			}
383	dpavlin	20
384	dpavlin	22	while (my $m = $my_q->next) {
385			next if ($m->all_sent);
386	dpavlin	20
387	dpavlin	22	print "sending message ",$m->message_id," enqueued on ",$m->date," to list ",$m->list_id->name,"\n";
388			my $msg = $m->message_id->message;
389	dpavlin	20
390	dpavlin	22	foreach my $u ($user_list->search(list_id => $m->list_id)) {
391	dpavlin	20
392	dpavlin	29	my $to_email = $u->user_id->email;
393
394	dpavlin	32	my ($from,$domain) = split(/@/, $u->list_id->email, 2);
395
396	dpavlin	22	if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {
397	dpavlin	29	print "SKIP $to_email message allready sent\n";
398	dpavlin	22	} else {
399	dpavlin	32	print "=> $to_email\n";
400	dpavlin	20
401	dpavlin	32	my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;
402	dpavlin	36	my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
403	dpavlin	32
404	dpavlin	29	my $hash = $auth->generate_hash( $to_email );
405	dpavlin	20
406	dpavlin	47	my $from_addr;
407	dpavlin	49	my $from_email_only = $from . "+" . $hash . ( $domain ? '@' . $domain : '');
408	dpavlin	48
409	dpavlin	47	$from_addr .= '"' . $u->list_id->from_addr . '" ' if ($u->list_id->from_addr);
410			$from_addr .= '<' . $from_email_only . '>';
411			my $to = '"' . $u->user_id->name . '" <' . $to_email . '>';
412	dpavlin	29
413	dpavlin	32	my $m_obj = Email::Simple->new($msg) \|\| croak "can't parse message";
414	dpavlin	29
415	dpavlin	49	$m_obj->header_set('Return-Path', $from_email_only) \|\| croak "can't set Return-Path: header";
416			$m_obj->header_set('Sender', $from_email_only) \|\| croak "can't set Sender: header";
417			$m_obj->header_set('Errors-To', $from_email_only) \|\| croak "can't set Errors-To: header";
418	dpavlin	47	$m_obj->header_set('From', $from_addr) \|\| croak "can't set From: header";
419	dpavlin	32	$m_obj->header_set('To', $to) \|\| croak "can't set To: header";
420	dpavlin	29
421	dpavlin	38	$m_obj->header_set('X-Nos-Version', $VERSION);
422			$m_obj->header_set('X-Nos-Hash', $hash);
423
424	dpavlin	47	# really send e-mail
425			if (@email_send_options) {
426			send $email_send_driver => $m_obj->as_string, @email_send_options;
427			} else {
428			send $email_send_driver => $m_obj->as_string;
429			}
430	dpavlin	22
431			$sent->create({
432			message_id => $m->message_id,
433			user_id => $u->user_id,
434	dpavlin	36	hash => $hash,
435	dpavlin	22	});
436			$sent->dbi_commit;
437	dpavlin	49
438			if ($sleep) {
439			warn "sleeping $sleep seconds\n";
440			sleep($sleep);
441			}
442	dpavlin	22	}
443			}
444			$m->all_sent(1);
445			$m->update;
446			$m->dbi_commit;
447			}
448
449	dpavlin	20	}
450
451	dpavlin	29	=head2 inbox_message
452
453			Receive single message for list's inbox.
454
455	dpavlin	36	my $ok = $nos->inbox_message(
456			list => 'My list',
457			message => $message,
458			);
459	dpavlin	29
460			=cut
461
462			sub inbox_message {
463			my $self = shift;
464
465	dpavlin	36	my $arg = {@_};
466	dpavlin	29
467	dpavlin	36	return unless ($arg->{'message'});
468			croak "need list name" unless ($arg->{'list'});
469	dpavlin	29
470	dpavlin	37	my $this_list = $self->_get_list($arg->{'list'}) \|\| croak "can't find list ".$arg->{'list'}."\n";
471
472	dpavlin	36	my $m = Email::Simple->new($arg->{'message'}) \|\| croak "can't parse message";
473
474			my $to = $m->header('To') \|\| die "can't find To: address in incomming message\n";
475
476	dpavlin	48	my $return_path = $m->header('Return-Path') \|\| '';
477
478	dpavlin	36	my @addrs = Email::Address->parse( $to );
479
480			die "can't parse To: $to address\n" unless (@addrs);
481
482			my $hl = $self->{'hash_len'} \|\| confess "no hash_len?";
483
484			my $hash;
485
486			foreach my $a (@addrs) {
487			if ($a->address =~ m/\+([a-f0-9]{$hl})@/) {
488			$hash = $1;
489			last;
490			}
491			}
492
493	dpavlin	50	#warn "can't find hash in e-mail $to\n" unless ($hash);
494	dpavlin	36
495			my $sent = $self->{'loader'}->find_class('sent');
496
497			# will use null if no matching message_id is found
498	dpavlin	50	my $sent_msg;
499			$sent_msg = $sent->search( hash => $hash )->first if ($hash);
500	dpavlin	36
501	dpavlin	37	my ($message_id, $user_id) = (undef, undef); # init with NULL
502	dpavlin	36
503	dpavlin	37	if ($sent_msg) {
504			$message_id = $sent_msg->message_id \|\| carp "no message_id";
505			$user_id = $sent_msg->user_id \|\| carp "no user_id";
506	dpavlin	47	} else {
507	dpavlin	50	#warn "can't find sender with hash $hash\n";
508			my $users = $self->{'loader'}->find_class('users');
509			my $from = $m->header('From');
510			$from = $1 if ($from =~ m/<(.*)>/);
511			my $this_user = $users->search( email => $from )->first;
512			$user_id = $this_user->id if ($this_user);
513	dpavlin	37	}
514
515
516			my $is_bounce = 0;
517
518	dpavlin	49	if ($return_path eq '<>' \|\| $return_path eq '') {
519	dpavlin	47	no warnings;
520			my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
521			$arg->{'message'}, { report_non_bounces=>1 },
522			) };
523	dpavlin	50	#warn "can't check if this message is bounce!" if ($@);
524	dpavlin	47
525			$is_bounce++ if ($bounce && $bounce->is_bounce);
526			}
527	dpavlin	37
528			my $received = $self->{'loader'}->find_class('received');
529
530			my $this_received = $received->find_or_create({
531			user_id => $user_id,
532			list_id => $this_list->id,
533			message_id => $message_id,
534			message => $arg->{'message'},
535			bounced => $is_bounce,
536			}) \|\| croak "can't insert received message";
537
538			$this_received->dbi_commit;
539
540	dpavlin	49	# print "message_id: ",($message_id \|\| "not found")," -- $is_bounce\n";
541	dpavlin	29	}
542
543
544	dpavlin	30	=head1 INTERNAL METHODS
545
546			Beware of dragons! You shouldn't need to call those methods directly.
547
548			=head2 _add_list
549
550			Create new list
551
552			my $list_obj = $nos->_add_list(
553			list => 'My list',
554	dpavlin	47	from => 'Outgoing from comment',
555	dpavlin	30	email => 'my-list@example.com',
556			);
557
558			Returns C<Class::DBI> object for created list.
559
560	dpavlin	38	C<email> address can be with domain or without it if your
561			MTA appends it. There is no checking for validity of your
562			list e-mail. Flexibility comes with resposibility, so please
563			feed correct (and configured) return addresses.
564
565	dpavlin	30	=cut
566
567			sub _add_list {
568			my $self = shift;
569
570			my $arg = {@_};
571
572			my $name = $arg->{'list'} \|\| confess "can't add list without name";
573			my $email = $arg->{'email'} \|\| confess "can't add list without e-mail";
574	dpavlin	47	my $from_addr = $arg->{'from'};
575	dpavlin	30
576			my $lists = $self->{'loader'}->find_class('lists');
577
578			my $l = $lists->find_or_create({
579			name => $name,
580			email => $email,
581			});
582	dpavlin	47
583	dpavlin	30	croak "can't add list $name\n" unless ($l);
584
585	dpavlin	47	if ($from_addr && $l->from_addr ne $from_addr) {
586			$l->from_addr($from_addr);
587			$l->update;
588			}
589
590	dpavlin	30	$l->dbi_commit;
591
592			return $l;
593
594			}
595
596
597			=head2 _get_list
598
599			Get list C<Class::DBI> object.
600
601			my $list_obj = $nos->check_list('My list');
602
603			Returns false on failure.
604
605			=cut
606
607			sub _get_list {
608			my $self = shift;
609
610			my $name = shift \|\| return;
611
612	dpavlin	31	my $lists = $self->{'loader'}->find_class('lists') \|\| confess "can't find lists class";
613	dpavlin	30
614	dpavlin	31	return $lists->search({ name => $name })->first;
615	dpavlin	30	}
616
617	dpavlin	39	###
618			### SOAP
619			###
620	dpavlin	30
621	dpavlin	39	package Nos::SOAP;
622
623	dpavlin	43	use Carp;
624
625	dpavlin	39	=head1 SOAP methods
626
627			This methods are thin wrappers to provide SOAP calls. They are grouped in
628			C<Nos::SOAP> package which is in same F<Nos.pm> module file.
629
630			Usually, you want to use named variables in your SOAP calls if at all
631			possible.
632
633			However, if you have broken SOAP library (like PHP SOAP class from PEAR)
634			you will want to use positional arguments (in same order as documented for
635			methods below).
636
637			=cut
638
639			my $nos;
640
641			sub new {
642			my $class = shift;
643			my $self = {@_};
644			bless($self, $class);
645
646			$nos = new Nos( @_ ) \|\| die "can't create Nos object";
647
648			$self ? return $self : return undef;
649			}
650
651
652			=head2 NewList
653
654			$message_id = NewList(
655			list => 'My list',
656			email => 'my-list@example.com'
657			);
658
659			=cut
660
661			sub NewList {
662			my $self = shift;
663
664			if ($_[0] !~ m/^HASH/) {
665			return $nos->new_list(
666			list => $_[0], email => $_[1],
667			);
668			} else {
669			return $nos->new_list( %{ shift @_ } );
670			}
671			}
672
673	dpavlin	43
674	dpavlin	39	=head2 AddMemberToList
675
676			$member_id = AddMemberToList(
677	dpavlin	43	list => 'My list',
678			email => 'e-mail@example.com',
679			name => 'Full Name'
680	dpavlin	39	);
681
682			=cut
683
684			sub AddMemberToList {
685			my $self = shift;
686
687			if ($_[0] !~ m/^HASH/) {
688			return $nos->add_member_to_list(
689			list => $_[0], email => $_[1], name => $_[2],
690			);
691			} else {
692			return $nos->add_member_to_list( %{ shift @_ } );
693			}
694			}
695
696	dpavlin	43
697			=head2 ListMembers
698
699			my @members = ListMembers(
700			list => 'My list',
701			);
702
703			Returns array of hashes with user informations, see C<list_members>.
704
705			=cut
706
707			sub ListMembers {
708			my $self = shift;
709
710			my $list_name;
711
712			if ($_[0] !~ m/^HASH/) {
713			$list_name = shift;
714			} else {
715			$list_name = $_[0]->{'list'};
716			}
717
718			return $nos->list_members( list => $list_name );
719			}
720
721	dpavlin	39	=head2 AddMessageToList
722
723			$message_id = AddMessageToList(
724			list => 'My list',
725			message => 'From: My list...'
726			);
727
728			=cut
729
730			sub AddMessageToList {
731			my $self = shift;
732
733			if ($_[0] !~ m/^HASH/) {
734			return $nos->add_message_to_list(
735			list => $_[0], message => $_[1],
736			);
737			} else {
738			return $nos->add_message_to_list( %{ shift @_ } );
739			}
740			}
741
742
743			###
744
745	dpavlin	25	=head1 EXPORT
746	dpavlin	20
747	dpavlin	27	Nothing.
748	dpavlin	20
749			=head1 SEE ALSO
750
751			mailman, ezmlm, sympa, L<Mail::Salsa>
752
753	dpavlin	25
754	dpavlin	20	=head1 AUTHOR
755
756			Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
757
758	dpavlin	25
759	dpavlin	20	=head1 COPYRIGHT AND LICENSE
760
761			Copyright (C) 2005 by Dobrica Pavlinusic
762
763			This library is free software; you can redistribute it and/or modify
764			it under the same terms as Perl itself, either Perl version 5.8.4 or,
765			at your option, any later version of Perl 5 you may have available.
766
767
768			=cut
769	dpavlin	39
770			1;