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;
use Data::Dumper;

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

#$email_send_driver = 'Sendmail';


=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;

print Dumper($this_user);

        $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("My list",'smtp');

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

=cut

sub send_queued_messages {
        my $self = shift;

        my $list_name = shift;

        my $driver = shift || '';

        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 Return-Path: header";
                                $m_obj->header_set('Errors-To', $from_email_only) || croak "can't set Return-Path: 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;
                        }
                }
                $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 @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;
                }
        }

        croak "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->search( hash => $hash )->first;

        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 $is_bounce = 0;

        {
                no warnings;
                my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
                        $arg->{'message'}, { report_non_bounces=>1 },
                ) };
                carp "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";


        warn "inbox is not yet implemented";
}


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