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 $email_hash = "+" . $hash . ( $domain ? '@' . $domain : '');
                                my $from_email_only = $from . $email_hash;
                                my $from_bounce = $from . '-bounce' . $email_hash;

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

        if ($arg->{'bounce'} || $return_path eq '<>' || $return_path eq '') {
                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	dpavlin	48	my $email_hash = "+" . $hash . ( $domain ? '@' . $domain : '');
404			my $from_email_only = $from . $email_hash;
405			my $from_bounce = $from . '-bounce' . $email_hash;
406
407	dpavlin	47	$from_addr .= '"' . $u->list_id->from_addr . '" ' if ($u->list_id->from_addr);
408			$from_addr .= '<' . $from_email_only . '>';
409			my $to = '"' . $u->user_id->name . '" <' . $to_email . '>';
410	dpavlin	29
411	dpavlin	32	my $m_obj = Email::Simple->new($msg) \|\| croak "can't parse message";
412	dpavlin	29
413	dpavlin	48	$m_obj->header_set('Return-Path', $from_bounce) \|\| croak "can't set Return-Path: header";
414			$m_obj->header_set('Sender', $from_bounce) \|\| croak "can't set Sender: header";
415			$m_obj->header_set('Errors-To', $from_bounce) \|\| croak "can't set Errors-To: header";
416	dpavlin	47	$m_obj->header_set('From', $from_addr) \|\| croak "can't set From: header";
417	dpavlin	32	$m_obj->header_set('To', $to) \|\| croak "can't set To: header";
418	dpavlin	29
419	dpavlin	38	$m_obj->header_set('X-Nos-Version', $VERSION);
420			$m_obj->header_set('X-Nos-Hash', $hash);
421
422	dpavlin	47	# really send e-mail
423			if (@email_send_options) {
424			send $email_send_driver => $m_obj->as_string, @email_send_options;
425			} else {
426			send $email_send_driver => $m_obj->as_string;
427			}
428	dpavlin	22
429			$sent->create({
430			message_id => $m->message_id,
431			user_id => $u->user_id,
432	dpavlin	36	hash => $hash,
433	dpavlin	22	});
434			$sent->dbi_commit;
435			}
436			}
437			$m->all_sent(1);
438			$m->update;
439			$m->dbi_commit;
440			}
441
442	dpavlin	20	}
443
444	dpavlin	29	=head2 inbox_message
445
446			Receive single message for list's inbox.
447
448	dpavlin	36	my $ok = $nos->inbox_message(
449			list => 'My list',
450			message => $message,
451			);
452	dpavlin	29
453			=cut
454
455			sub inbox_message {
456			my $self = shift;
457
458	dpavlin	36	my $arg = {@_};
459	dpavlin	29
460	dpavlin	36	return unless ($arg->{'message'});
461			croak "need list name" unless ($arg->{'list'});
462	dpavlin	29
463	dpavlin	37	my $this_list = $self->_get_list($arg->{'list'}) \|\| croak "can't find list ".$arg->{'list'}."\n";
464
465	dpavlin	36	my $m = Email::Simple->new($arg->{'message'}) \|\| croak "can't parse message";
466
467			my $to = $m->header('To') \|\| die "can't find To: address in incomming message\n";
468
469	dpavlin	48	my $return_path = $m->header('Return-Path') \|\| '';
470
471	dpavlin	36	my @addrs = Email::Address->parse( $to );
472
473			die "can't parse To: $to address\n" unless (@addrs);
474
475			my $hl = $self->{'hash_len'} \|\| confess "no hash_len?";
476
477			my $hash;
478
479			foreach my $a (@addrs) {
480			if ($a->address =~ m/\+([a-f0-9]{$hl})@/) {
481			$hash = $1;
482			last;
483			}
484			}
485
486	dpavlin	48	warn "can't find hash in e-mail $to\n" unless ($hash);
487	dpavlin	36
488			my $sent = $self->{'loader'}->find_class('sent');
489
490			# will use null if no matching message_id is found
491	dpavlin	37	my $sent_msg = $sent->search( hash => $hash )->first;
492	dpavlin	36
493	dpavlin	37	my ($message_id, $user_id) = (undef, undef); # init with NULL
494	dpavlin	36
495	dpavlin	37	if ($sent_msg) {
496			$message_id = $sent_msg->message_id \|\| carp "no message_id";
497			$user_id = $sent_msg->user_id \|\| carp "no user_id";
498	dpavlin	47	} else {
499			warn "can't find sender with hash $hash\n";
500	dpavlin	37	}
501
502
503			my $is_bounce = 0;
504
505	dpavlin	48	if ($arg->{'bounce'} \|\| $return_path eq '<>' \|\| $return_path eq '') {
506	dpavlin	47	no warnings;
507			my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
508			$arg->{'message'}, { report_non_bounces=>1 },
509			) };
510			carp "can't check if this message is bounce!" if ($@);
511
512			$is_bounce++ if ($bounce && $bounce->is_bounce);
513			}
514	dpavlin	37
515			my $received = $self->{'loader'}->find_class('received');
516
517			my $this_received = $received->find_or_create({
518			user_id => $user_id,
519			list_id => $this_list->id,
520			message_id => $message_id,
521			message => $arg->{'message'},
522			bounced => $is_bounce,
523			}) \|\| croak "can't insert received message";
524
525			$this_received->dbi_commit;
526
527	dpavlin	43	print "message_id: ",($message_id \|\| "not found")," -- $is_bounce\n";
528
529
530	dpavlin	36	warn "inbox is not yet implemented";
531	dpavlin	29	}
532
533
534	dpavlin	30	=head1 INTERNAL METHODS
535
536			Beware of dragons! You shouldn't need to call those methods directly.
537
538			=head2 _add_list
539
540			Create new list
541
542			my $list_obj = $nos->_add_list(
543			list => 'My list',
544	dpavlin	47	from => 'Outgoing from comment',
545	dpavlin	30	email => 'my-list@example.com',
546			);
547
548			Returns C<Class::DBI> object for created list.
549
550	dpavlin	38	C<email> address can be with domain or without it if your
551			MTA appends it. There is no checking for validity of your
552			list e-mail. Flexibility comes with resposibility, so please
553			feed correct (and configured) return addresses.
554
555	dpavlin	30	=cut
556
557			sub _add_list {
558			my $self = shift;
559
560			my $arg = {@_};
561
562			my $name = $arg->{'list'} \|\| confess "can't add list without name";
563			my $email = $arg->{'email'} \|\| confess "can't add list without e-mail";
564	dpavlin	47	my $from_addr = $arg->{'from'};
565	dpavlin	30
566			my $lists = $self->{'loader'}->find_class('lists');
567
568			my $l = $lists->find_or_create({
569			name => $name,
570			email => $email,
571			});
572	dpavlin	47
573	dpavlin	30	croak "can't add list $name\n" unless ($l);
574
575	dpavlin	47	if ($from_addr && $l->from_addr ne $from_addr) {
576			$l->from_addr($from_addr);
577			$l->update;
578			}
579
580	dpavlin	30	$l->dbi_commit;
581
582			return $l;
583
584			}
585
586
587			=head2 _get_list
588
589			Get list C<Class::DBI> object.
590
591			my $list_obj = $nos->check_list('My list');
592
593			Returns false on failure.
594
595			=cut
596
597			sub _get_list {
598			my $self = shift;
599
600			my $name = shift \|\| return;
601
602	dpavlin	31	my $lists = $self->{'loader'}->find_class('lists') \|\| confess "can't find lists class";
603	dpavlin	30
604	dpavlin	31	return $lists->search({ name => $name })->first;
605	dpavlin	30	}
606
607	dpavlin	39	###
608			### SOAP
609			###
610	dpavlin	30
611	dpavlin	39	package Nos::SOAP;
612
613	dpavlin	43	use Carp;
614
615	dpavlin	39	=head1 SOAP methods
616
617			This methods are thin wrappers to provide SOAP calls. They are grouped in
618			C<Nos::SOAP> package which is in same F<Nos.pm> module file.
619
620			Usually, you want to use named variables in your SOAP calls if at all
621			possible.
622
623			However, if you have broken SOAP library (like PHP SOAP class from PEAR)
624			you will want to use positional arguments (in same order as documented for
625			methods below).
626
627			=cut
628
629			my $nos;
630
631			sub new {
632			my $class = shift;
633			my $self = {@_};
634			bless($self, $class);
635
636			$nos = new Nos( @_ ) \|\| die "can't create Nos object";
637
638			$self ? return $self : return undef;
639			}
640
641
642			=head2 NewList
643
644			$message_id = NewList(
645			list => 'My list',
646			email => 'my-list@example.com'
647			);
648
649			=cut
650
651			sub NewList {
652			my $self = shift;
653
654			if ($_[0] !~ m/^HASH/) {
655			return $nos->new_list(
656			list => $_[0], email => $_[1],
657			);
658			} else {
659			return $nos->new_list( %{ shift @_ } );
660			}
661			}
662
663	dpavlin	43
664	dpavlin	39	=head2 AddMemberToList
665
666			$member_id = AddMemberToList(
667	dpavlin	43	list => 'My list',
668			email => 'e-mail@example.com',
669			name => 'Full Name'
670	dpavlin	39	);
671
672			=cut
673
674			sub AddMemberToList {
675			my $self = shift;
676
677			if ($_[0] !~ m/^HASH/) {
678			return $nos->add_member_to_list(
679			list => $_[0], email => $_[1], name => $_[2],
680			);
681			} else {
682			return $nos->add_member_to_list( %{ shift @_ } );
683			}
684			}
685
686	dpavlin	43
687			=head2 ListMembers
688
689			my @members = ListMembers(
690			list => 'My list',
691			);
692
693			Returns array of hashes with user informations, see C<list_members>.
694
695			=cut
696
697			sub ListMembers {
698			my $self = shift;
699
700			my $list_name;
701
702			if ($_[0] !~ m/^HASH/) {
703			$list_name = shift;
704			} else {
705			$list_name = $_[0]->{'list'};
706			}
707
708			return $nos->list_members( list => $list_name );
709			}
710
711	dpavlin	39	=head2 AddMessageToList
712
713			$message_id = AddMessageToList(
714			list => 'My list',
715			message => 'From: My list...'
716			);
717
718			=cut
719
720			sub AddMessageToList {
721			my $self = shift;
722
723			if ($_[0] !~ m/^HASH/) {
724			return $nos->add_message_to_list(
725			list => $_[0], message => $_[1],
726			);
727			} else {
728			return $nos->add_message_to_list( %{ shift @_ } );
729			}
730			}
731
732
733			###
734
735	dpavlin	25	=head1 EXPORT
736	dpavlin	20
737	dpavlin	27	Nothing.
738	dpavlin	20
739			=head1 SEE ALSO
740
741			mailman, ezmlm, sympa, L<Mail::Salsa>
742
743	dpavlin	25
744	dpavlin	20	=head1 AUTHOR
745
746			Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
747
748	dpavlin	25
749	dpavlin	20	=head1 COPYRIGHT AND LICENSE
750
751			Copyright (C) 2005 by Dobrica Pavlinusic
752
753			This library is free software; you can redistribute it and/or modify
754			it under the same terms as Perl itself, either Perl version 5.8.4 or,
755			at your option, any later version of Perl 5 you may have available.
756
757
758			=cut
759	dpavlin	39
760			1;