jifty-dbi/lib/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.9_00';

use Email::Valid;
use Email::Send;
use Carp;
use Email::Auth::AddressHash;
use Email::Simple;
use Email::Address;
use Mail::DeliveryStatus::BounceParser;
use Mail::Alias;
use Cwd qw(abs_path);

use Jifty::DBI::Handle;
use lib 'lib';
use Nos::Lists;


=head1 NAME

Nos - Notice Sender core module

=head1 SYNOPSIS

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

=head1 DESCRIPTION

Notice sender is mail handler. It is not MTA, since it doesn't know how to
receive e-mails or send them directly to other hosts. It is not mail list
manager because it requires programming to add list members and send
messages. You can think of it as mechanisam for off-loading your e-mail
sending to remote server using SOAP service.

It's concept is based around B<lists>. Each list can have zero or more
B<members>. Each list can have zero or more B<messages>.

Here comes a twist: each outgoing message will have unique e-mail generated,
so Notice Sender will be able to link received replies (or bounces) with
outgoing messages.

It doesn't do much more than that. It B<can't> create MIME encoded e-mail,
send attachments, handle 8-bit characters in headers (which have to be
encoded) or anything else.

It will just queue your e-mail message to particular list (sending it to
possibly remote Notice Sender SOAP server just once), send it out at
reasonable rate (so that it doesn't flood your e-mail infrastructure) and
keep track replies.

It is best used to send small number of messages to more-or-less fixed
list of recipients while allowing individual responses to be examined.
Tipical use include replacing php e-mail sending code with SOAP call to
Notice Sender. It does support additional C<ext_id> field for each member
which can be used to track some unique identifier from remote system for
particular user.

It comes with command-line utility C<sender.pl> which can be used to perform
all available operation from scripts (see C<sender.pl --man>).
This command is also useful for debugging while writing client SOAP
application.

=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,
        full_hostname_in_aliases => 0,
 );

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.

C<full_hostname_in_aliases> will turn on old behaviour (not supported by Postfix
postalias) to include full hostname in aliases file.


=cut

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

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

        my (undef,$driver,$dbname) = split(/:/, $self->{dsn});
        $dbname =~ s!^dbname=!!;

        $self->{h} = Jifty::DBI::Handle->new();
        $self->{h}->connect(
                driver   => $driver,
                database => $dbname,
                host     => 'localhost',
                user     => $self->{user},
                password => $self->{passwd},
        );

        $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 create_list

Create new list. Required arguments are name of C<list>, C<email> address
and path to C<aliases> file.

 $nos->create_list(
        list => 'My list',
        from => 'Outgoing from comment',
        email => 'my-list@example.com',
        aliases => '/etc/mail/mylist',
        archive => '/path/to/mbox/archive',
 );

Returns ID of newly created list.

Calls internally C<_add_list>, see details there.

=cut

sub create_list {
        my $self = shift;

        my $arg = {@_};

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

        $arg->{'list'} = lc($arg->{'list'});
        $arg->{'email'} = lc($arg->{'email'});

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

        return $l->id;
}


=head2 drop_list

Delete list from database.

 my $ok = drop_list(
        list => 'My list'
        aliases => '/etc/mail/mylist',
 );

Returns false if list doesn't exist.

=cut

sub drop_list {
        my $self = shift;

        my $args = {@_};

        croak "need list to delete" unless ($args->{'list'});

        $args->{'list'} = lc($args->{'list'});

        my $aliases = $args->{'aliases'} || croak "need path to aliases file";

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

        my $this_list = $lists->search( name => $args->{'list'} )->first || return;

        $self->_remove_alias( email => $this_list->email, aliases => $aliases);

        $this_list->delete || croak "can't delete list\n";

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


=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",
        ext_id => 42,
 );

C<name> and C<ext_id> parametars are optional.

Return member ID if user is added.

=cut

sub add_member_to_list {
        my $self = shift;

        my $arg = {@_};

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

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

        if (defined($ext_id) && ($this_user->ext_id || '') ne $ext_id) {
                $this_user->ext_id($ext_id);
                $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 information like this:

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

If list is not found, returns false. If there is C<ext_id> in user data,
it will also be returned.

=cut

sub list_members {
        my $self = shift;

        my $args = {@_};

        my $list_name = lc($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,
                };

                my $ext_id = $user_on_list->user_id->ext_id;
                $row->{'ext_id'} = $ext_id if (defined($ext_id));

                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.

This function will delete member from all lists (by cascading delete), so it
shouldn't be used lightly.

=cut

sub delete_member {
        my $self = shift;

        my $args = {@_};

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

        $args->{'email'} = lc($args->{'email'}) if ($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 delete_member_from_list

Delete member from particular list.

 my $ok = delete_member_from_list(
        list => 'My list',
        email => 'dpavlin@rot13.org',
 );

Returns false if user doesn't exist on that particular list.

It will die if list or user doesn't exist. You have been warned (you might
want to eval this functon to prevent it from croaking).

=cut

sub delete_member_from_list {
        my $self = shift;

        my $args = {@_};

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

        $args->{'list'} = lc($args->{'list'});
        $args->{'email'} = lc($args->{'email'});

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

        my $this_user = $user->search( email => $args->{'email'} )->first || croak "can't find user: ".$args->{'email'};
        my $this_list = $list->search( name => $args->{'list'} )->first || croak "can't find list: ".$args->{'list'};

        my $this_user_list = $user_list->search_where( list_id => $this_list->id, user_id => $this_user->id )->first || return;

        $this_user_list->delete || croak "can't delete user from list\n";

        return $user_list->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 = lc($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";

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

        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

Any other driver name will try to use C<Email::Send::that_driver> module.

Default sleep wait between two messages is 3 seconds.

This method will return number of succesfully sent messages.

=cut

sub send_queued_messages {
        my $self = shift;

        my $arg = {@_};

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

        # number of messages sent o.k.
        my $ok = 0;

        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'];
        } elsif ($driver && $driver ne '') {
                $email_send_driver = 'Email::Send::' . $driver;
        } else {
                warn "dumping all messages to STDERR\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 ";

                                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
                                my $sent_status;

                                if (@email_send_options) {
                                        $sent_status = send $email_send_driver => $m_obj->as_string, @email_send_options;
                                } else {
                                        $sent_status = send $email_send_driver => $m_obj->as_string;
                                }

                                croak "can't send e-mail: $sent_status\n\nOriginal e-mail follows:\n".$m_obj->as_string unless ($sent_status);
                                my @bad;
                                @bad = @{ $sent_status->prop('bad') } if (eval { $sent_status->can('prop') });
                                croak "failed sending to ",join(",",@bad) if (@bad);

                                if ($sent_status) {

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

                                        print " - $sent_status\n";

                                        $ok++;
                                } else {
                                        warn "ERROR: $sent_status\n";
                                }

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

        return $ok;

}

=head2 inbox_message

Receive single message for list's inbox.

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

This method is used by C<sender.pl> when receiving e-mail messages.

=cut

sub inbox_message {
        my $self = shift;

        my $arg = {@_};

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

        $arg->{'list'} = lc($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})@/i) {
                        $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 => lc($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";
}

=head2 received_messages

Returns all received messages for given list or user.

 my @received = $nos->received_messages(
        list => 'My list',
        email => "john.doe@example.com",
        from_date => '2005-01-01 10:15:00',
        to_date => '2005-01-01 12:00:00',
        message => 0,
 );

If don't specify C<list> or C<email> it will return all received messages.
Results will be sorted by received date, oldest first.

Other optional parametars include:

=over 10

=item from_date

Date (in ISO format) for lower limit of dates received

=item to_date

Return just messages older than this date

=item message

Include whole received message in result. This will probably make result
array very large. Use with care.

=back

Date ranges are inclusive, so results will include messages sent on
particular date specified with C<date_from> or C<date_to>.

Each element in returned array will have following structure:

 my $row = {
        id => 42,                       # unique ID of received message
        list => 'My list',              # useful if filtering by email
        ext_id => 9999,                 # ext_id from message sender
        email => 'jdoe@example.com',    # e-mail of message sender
        bounced => 0,                   # true if message is bounce
        date => '2005-08-24 18:57:24',  # date of receival in ISO format
 }

If you specified C<message> option, this hash will also have C<message> key
which will contain whole received message.

=cut

sub received_messages {
        my $self = shift;

        my $arg = {@_} if (@_);

#       croak "need list name or email" unless ($arg->{'list'} || $arg->{'email'});

        my $sql = qq{
                        select
                                received.id as id,
                                lists.name as list,
                                users.ext_id as ext_id,
                                users.email as email,
        };
        $sql .= qq{             message,} if ($arg->{'message'});
        $sql .= qq{
                                bounced,received.date as date
                        from received
                        join lists on lists.id = list_id
                        join users on users.id = user_id
        };

        my $order = qq{ order by date asc };

        my $where;

        $where->{'lists.name'} = lc($arg->{'list'}) if ($arg->{'list'});
        $where->{'users.email'} = lc($arg->{'email'}) if ($arg->{'email'});
        $where->{'received.date'} = { '>=', $arg->{'date_from'} } if ($arg->{'date_from'});
        $where->{'received.date'} = { '<=', $arg->{'date_to'} } if ($arg->{'date_to'});

        # hum, yammy one-liner
        my($stmt, @bind)  = SQL::Abstract->new->where($where);

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

        my $sth = $dbh->prepare($sql . $stmt . $order);
        $sth->execute(@bind);
        return $sth->fetchall_hash;
}


=head1 INTERNAL METHODS

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


=head2 _add_aliases

Add or update alias in C</etc/aliases> (or equivalent) file for selected list

 my $ok = $nos->add_aliases(
        list => 'My list',
        email => 'my-list@example.com',
        aliases => '/etc/mail/mylist',
        archive => '/path/to/mbox/archive',

 );

C<archive> parametar is optional.

Return false on failure.

=cut

sub _add_aliases {
        my $self = shift;

        my $arg = {@_};

        foreach my $o (qw/list email aliases/) {
                croak "need $o option" unless ($arg->{$o});
        }

        my $aliases = $arg->{'aliases'};
        my $email = $arg->{'email'};
        my $list = $arg->{'list'};

        unless (-e $aliases) {
                warn "aliases file $aliases doesn't exist, creating empty\n";
                open(my $fh, '>', $aliases) || croak "can't create $aliases: $!";
                close($fh);
                chmod 0777, $aliases || warn "can't change permission to 0777";
        }

        die "FATAL: aliases file $aliases is not writable\n" unless (-w $aliases);

        my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";

        my $target = '';

        if (my $archive = $arg->{'archive'}) {
                $target .= "$archive, ";

                if (! -e $archive) {
                        warn "please make sure that file $archive is writable for your e-mail user (defaulting to bad 777 permission for now)";

                        open(my $fh, '>', $archive) || croak "can't create archive file $archive: $!";
                        close($fh);
                        chmod 0777, $archive || croak "can't chmod archive file $archive to 0777: $!";
                }
        }

        # resolve my path to absolute one
        my $self_path = abs_path($0);
        $self_path =~ s#/[^/]+$##;
        $self_path =~ s#/t/*$#/#;

        $target .= qq#"| cd $self_path && ./sender.pl --inbox='$list'"#;

        # remove hostname from email to make Postfix's postalias happy
        $email =~ s/@.+// if (not $self->{full_hostname_in_aliases});

        if ($a->exists($email)) {
                $a->update($email, $target) or croak "can't update alias ".$a->error_check;
        } else {
                $a->append($email, $target) or croak "can't add alias ".$a->error_check;
        }

#       $a->write($aliases) or croak "can't save aliases $aliases ".$a->error_check;

        return 1;
}

=head2 _add_list

Create new list

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

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 find_or_create {
        my $self = shift;
        my $obj = shift;
        my %args = {@_};

        my ( $id, $msg ) = $obj->load_by_cols(%args);
    unless ( $obj->{values}->{id} ) {
                warn "find_or_CREATE(",dump( \%args ), ")";
                return $obj->create(%args);
        }

        warn "FIND_or_create(",dump( \%args ), ") = $id";
        return $id;
}


sub _add_list {
        my $self = shift;

        my $arg = {@_};

        my $name = lc($arg->{'list'}) || confess "can't add list without name";
        my $email = lc($arg->{'email'}) || confess "can't add list without e-mail";
        my $aliases = lc($arg->{'aliases'}) || confess "can't add list without path to aliases file";

        my $from_addr = $arg->{'from'};

        my $lists = Nos::Lists->new( handle => $self->{h} );

        $self->_add_aliases(
                list => $name,
                email => $email,
                aliases => $aliases,
        ) || warn "can't add alias $email for list $name";

        my $l = $self->find_or_create($lists, {
                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 => lc($name) })->first;
}


=head2 _remove_alias

Remove list alias

 my $ok = $nos->_remove_alias(
        email => 'mylist@example.com',
        aliases => '/etc/mail/mylist',
 );

Returns true if list is removed or false if list doesn't exist. Dies in case of error.

=cut

sub _remove_alias {
        my $self = shift;

        my $arg = {@_};

        my $email = lc($arg->{'email'}) || confess "can't remove alias without email";
        my $aliases = lc($arg->{'aliases'}) || confess "can't remove alias without list";

        my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";

        if ($a->exists($email)) {
                $a->delete($email) || croak "can't remove alias $email";
        } else {
                return 0;
        }

        return 1;

}

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


=head2 new

Create new SOAP object

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

If you are writing SOAP server (like C<soap.cgi> example), you will need to
call this method once to make new instance of Nos::SOAP and specify C<dsn>
and options for it.

=cut

sub new {
        my $class = shift;
        my $self = {@_};

        croak "need aliases parametar" unless ($self->{'aliases'});

        bless($self, $class);

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

        $self ? return $self : return undef;
}


=head2 CreateList

 $message_id = CreateList(
        list => 'My list',
        from => 'Name of my list',
        email => 'my-list@example.com'
 ); 

=cut

sub CreateList {
        my $self = shift;

        my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";

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


=head2 DropList

 $ok = DropList(
        list => 'My list',
 ); 

=cut

sub DropList {
        my $self = shift;

        my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";

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

=head2 AddMemberToList

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

=cut

sub AddMemberToList {
        my $self = shift;

        if ($_[0] !~ m/^HASH/) {
                return $nos->add_member_to_list(
                        list => $_[0], email => $_[1], name => $_[2], ext_id => $_[3],
                );
        } 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 DeleteMemberFromList

 $member_id = DeleteMemberFromList(
        list => 'My list',
        email => 'e-mail@example.com',
 );

=cut

sub DeleteMemberFromList {
        my $self = shift;

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


=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 @_ } );
        }
}

=head2 MessagesReceived

Return statistics about received messages.

 my @result = MessagesReceived(
        list => 'My list',
        email => 'jdoe@example.com',
        from_date => '2005-01-01 10:15:00',
        to_date => '2005-01-01 12:00:00',
        message => 0,
 );

You must specify C<list> or C<email> or any combination of those two. Other
parametars are optional.

For format of returned array element see C<received_messages>.

=cut

sub MessagesReceived {
        my $self = shift;

        if ($_[0] !~ m/^HASH/) {
                die "need at least list or email" unless (scalar @_ < 2);
                return \@{ $nos->received_messages(
                        list => $_[0], email => $_[1],
                        from_date => $_[2], to_date => $_[3],
                        message => $_[4]
                ) };
        } else {
                my $arg = shift;
                die "need list or email argument" unless ($arg->{'list'} || $arg->{'email'});
                return \@{ $nos->received_messages( %{ $arg } ) };
        }
}

###

=head1 NOTE ON ARRAYS IN SOAP

Returning arrays from SOAP calls is somewhat fuzzy (at least to me). It
seems that SOAP::Lite client thinks that it has array with one element which
is array of hashes with data.

=head1 PRIVATE METHODS

Documented here because tests use them

=head2 _nos_object

  my $nos = $nos->_nos_object;

=cut

sub _nos_object {
        return $nos;
}

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