#!%PERL%
# Copyright (c) vhffs project and its contributors
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without 
# modification, are permitted provided that the following conditions 
# are met:
#
# 1. Redistributions of source code must retain the above copyright 
#   notice, this list of conditions and the following disclaimer.
#2. Redistributions in binary form must reproduce the above copyright
#   notice, this list of conditions and the following disclaimer in 
#   the documentation and/or other materials provided with the 
#   distribution.
#3. Neither the name of vhffs nor the names of its contributors 
#   may be used to endorse or promote products derived from this 
#   software without specific prior written permission.
#
#THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 
#"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 
#LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 
#FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 
#COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 
#INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 
#BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 
#LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 
#CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 
# ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 
# POSSIBILITY OF SUCH DAMAGE.


# This file is a part of VHFFS4 software, a hosting platform suite
# Please respect the licence of this file and whole program

=pod

=head1 NAME

Vhffs::Services::MailingList - Handle mailing lists in VHFFS.

=head1 SYNOPSIS

TODO

=head1 METHODS

=cut

use strict;
use utf8;

package Vhffs::Services::MailingList;

use base qw(Vhffs::Object);
use DBI;

=pod

=head2 create

    my $ml = Vhffs::Services::MailingList::create($local, $domain, $description, $user, $group);
    die('Unable to create list') unless defined $ml;

Creates a new mailing list in database and returns the corresponding fully functional object.
Returns undef if an error occurs (box, forward or mailing list with the same address already
exists, domain not found, ...).

=cut
sub create
{
    my ($main, $local, $domain, $description, $user, $group) = @_;
    
    return undef unless(defined $user && defined $group);
    return undef unless($local =~ /^[a-z0-9\_\-]+$/);
    return undef unless(Vhffs::Functions::check_domain_name($domain));
    return undef if(Vhffs::Services::Mail::address_exists($main, $local, $domain));

    my $ml;

    my $dbh = $main->get_db_object();
    local $dbh->{RaiseError} = 1;
    local $dbh->{PrintError} = 0;
    $dbh->begin_work;

    eval {
        # Group must be the mail domain owner or use default mail domain.
        my $sql = 'SELECT mxdomain_id FROM vhffs_mxdomain m INNER JOIN vhffs_object o ON o.object_id = m.object_id WHERE m.domain = ? AND o.owner_gid = ?';
        die('Mail domain not found') unless($domain eq $main->get_config()->get_service("mailinglist")->{'default_domain'} ||
                            $dbh->do($sql, undef, $domain, $group->get_gid) > 0);

        my $parent = Vhffs::Object::create($main, $user->get_uid, $group->get_gid, $description, undef, Vhffs::Constants::TYPE_ML);
        die('Unable to create parent object') unless(defined $parent);

	# open sub, post members only
        $sql = 'INSERT INTO vhffs_ml(local_part, domain, prefix, object_id, open_archive, reply_to, sub_ctrl, post_ctrl) VALUES(?, ?, ?, ?, FALSE, TRUE, ?, ? )';
        my $sth = $dbh->prepare($sql);
        $sth->execute($local, $domain, $local, $parent->get_oid, Vhffs::Constants::ML_SUBSCRIBE_NO_APPROVAL_REQUIRED, Vhffs::Constants::ML_POSTING_MEMBERS_ONLY);
        $dbh->commit;
        $ml = get_by_mladdress($main, $local, $domain);
    };

    if($@) {
        warn "Unable to create mailing list $local\@$domain: $@\n";
        $dbh->rollback;
    }

    return $ml;

}

=pod

=head2 get_by_mladdress

    my $ml = Vhffs::Services::MailingList::get_by_mladdress($main, $local_part, $domain);
    die("Mailing list $localpart\@$domain not found\n") unless(defined $ml);

Fetches the mailing list $local_part@$domain.

=cut

sub get_by_mladdress {
    my ($main, $local, $domain) = @_;
    
    my $dbh = $main->get_db_object();
    my $sql = 'SELECT ml.ml_id, ml.local_part, ml.domain, ml.prefix, o.owner_gid, ml.open_archive, ml.reply_to, ml.sub_ctrl, ml.post_ctrl, ml.signature, o.object_id, o.owner_uid, o.date_creation, o.state, o.description FROM vhffs_ml ml INNER JOIN vhffs_object o ON o.object_id = ml.object_id WHERE domain = ? and local_part = ?';
    my $sth = $dbh->prepare($sql);
    return undef unless ($sth->execute($domain, $local) > 0);
    my @params = $sth->fetchrow_array;

    push @params, fetch_subs($dbh, $params[0]);
    return _new Vhffs::Services::MailingList($main, @params);
}

=head2 fetch_subs

    my $subs = fetch_subs($dbh, $ml_id);

Returns an hashref of hashrefs containing all subscribers indexed on their
mail addresses.

Internal module use only.

=cut

sub fetch_subs {

    my ($dbh, $ml_id) = @_;

    my $sql = q{SELECT sub_id, member, perm, hash, ml_id, language
        FROM vhffs_ml_subscribers WHERE ml_id = ?};
    return $dbh->selectall_hashref($sql, 'member', undef, $ml_id);
}

=head2 fill_object

See C<Vhffs::Object::fill_object>.

=cut

sub fill_object {
    my ($class, $obj) = @_;
    my $sql = q{SELECT ml_id, local_part, domain, prefix, open_archive,
        reply_to, sub_ctrl, post_ctrl, signature FROM vhffs_ml
        WHERE object_id = ?};
    $obj = $class->SUPER::_fill_object($obj, $sql);
    if($obj->isa('Vhffs::Services::MailingList')) {
        $obj->{subs} = fetch_subs($obj->get_db_object, $obj->{ml_id});
    }
    return $obj;
}

sub _new {
    my ($class, $main, $ml_id, $local_part, $domain, $prefix, $owner_gid, $open_archive, $reply_to, $sub_ctrl, $post_ctrl, $signature, $oid, $owner_uid, $date_creation, $state, $description, $subs) = @_;

    my $self = $class->SUPER::_new($main, $oid, $owner_uid, $owner_gid, $date_creation, $description, '', $state, Vhffs::Constants::TYPE_ML);
    return undef unless defined($self);

    $self->{ml_id} = $ml_id;
    $self->{local_part} = $local_part;
    $self->{domain} = $domain,
    $self->{prefix} = $prefix;
    $self->{open_archive} = $open_archive;
    $self->{reply_to} = $reply_to;
    $self->{sub_ctrl} = $sub_ctrl;
    $self->{post_ctrl} = $post_ctrl;
    $self->{signature} = $signature;
    $self->{subs} = $subs;

    return $self;
}

# Commit all changes of the current instance in the database
sub commit
{
    my $self = shift;	

    my $sql = 'UPDATE vhffs_ml SET prefix = ?, open_archive = ?, reply_to = ?, sub_ctrl = ?, post_ctrl = ?, signature = ? WHERE ml_id = ?';
    my $dbh = $self->get_main->get_db_object();
    $dbh->do($sql, undef, $self->{prefix}, $self->{open_archive}, $self->{reply_to}, $self->{sub_ctrl}, $self->{post_ctrl}, $self->{signature}, $self->{ml_id});

    return -3 if( $self->SUPER::commit < 0 );

    return 1;
}

sub change_right_for_sub
{
    my ($self, $subscriber, $right) = @_;

    my $sql = 'UPDATE vhffs_ml_subscribers SET perm = ? WHERE ml_id = ? AND member = ?';
    my $dbh = $self->get_main->get_db_object();
    # FIXME compatibility hack, we should return a boolean
    return -1 unless($dbh->do($sql, undef, $right, $self->{ml_id}, $subscriber) > 0);
    $self->{subs}->{$subscriber}->{perm} = $right;
    return 1;
}


sub add_sub
{
    my $self = shift;
    my $subscriber = lc shift;
    my $right = shift;

    return -1 unless( Vhffs::Functions::valid_mail( $subscriber ) );
    return -2 if( $subscriber =~ /[<>\s]/ );
    return -3 if( ! ( $right =~ /^[\d]+$/ ) );

    my $sql = 'INSERT INTO vhffs_ml_subscribers (member, perm, hash, ml_id, language) VALUES (?, ?, NULL, ?, NULL)';
    my $dbh = $self->get_main->get_db_object();
    $dbh->do($sql, undef, $subscriber, $right, $self->{ml_id}) or return -4;

    my $id = $dbh->last_insert_id(undef, undef, 'vhffs_ml_subscribers', undef);

    $self->{subs}->{$subscriber} = {
        sub_id => $id,
        member => $subscriber,
        perm => $right,
        hash => undef,
        ml_id => $self->{ml_id},
        language => undef
    };

    return 1;
}



#add a subscriber, return undef if already exists
sub add_sub_with_reply
{
    my $self = shift;
    my $subscriber = lc shift;

    return undef unless( Vhffs::Functions::valid_mail( $subscriber ) );
    return undef if( $subscriber =~ /.*<.*/ );
    return undef if( $subscriber =~ /.*>.*/ );
    return undef if( $subscriber =~ /.*\s.*/ );

    my $pass = Vhffs::Functions::generate_random_password;

    my $sql = 'INSERT INTO vhffs_ml_subscribers(member, perm, hash, ml_id, language) VALUES(?, ?, ?, ?, NULL)';
    my $dbh = $self->get_main->get_db_object();
    $dbh->do($sql, undef, $subscriber, Vhffs::Constants::ML_RIGHT_SUB_WAITING_FOR_REPLY, $pass, $self->{ml_id}) or return undef;

    my $id = $dbh->last_insert_id(undef, undef, 'vhffs_ml_subscribers', undef);

    $self->{subs}->{$subscriber} = {
        sub_id => $id,
        member => $subscriber,
        perm => Vhffs::Constants::ML_RIGHT_SUB_WAITING_FOR_REPLY,
        hash => $pass,
        ml_id => $self->{ml_id},
        language => undef
    };

    return $pass;
}



sub del_sub
{
    my $self = shift;
    my $subscriber = shift;

    my $sql = 'DELETE FROM vhffs_ml_subscribers WHERE ml_id = ? AND member = ?';
    # FIXME we should return a boolean
    return -1 unless($self->get_main->get_db_object->do($sql, undef, $self->{ml_id}, $subscriber) > 0);

    delete $self->{subs}->{$subscriber};
    return 1;
}

# FIXME useless
sub change_state_for_sub
{
    return change_right_for_sub(@_);
}

sub set_randomhash
{
    my $self = shift;
    my $subscriber = shift;
    my $pass = Vhffs::Functions::generate_random_password;

    my $sql = 'UPDATE vhffs_ml_subscribers SET hash = ? WHERE ml_id = ? AND member = ?';
    return undef unless($self->get_main->get_db_object->do($sql, undef, $pass, $self->{ml_id}, $subscriber) > 0);
    
    $self->{subs}->{$subscriber}->{hash} = $pass;
    return $pass;
}


sub clear_hash
{
    my $self = shift;
    my $subscriber = shift;

    my $sql = 'UPDATE vhffs_ml_subscribers SET hash = NULL WHERE ml_id = ? AND member = ?';
    # FIXME we should return a boolean
    return -1 unless($self->get_main->get_db_object->do($sql, undef, $self->{ml_id}, $subscriber) > 0);
    
    $self->{subs}->{$subscriber}->{hash} = undef;
    return 1;
}

=head2 address_exists

    print("A mailing list with the same address already exists\n")
        if Vhffs::Mailing::address_exists($vhffs, $local_part, $domain);

Return true if a mailing list C<$local_part>@C<$domain> already exists.

=cut

sub address_exists($$$) {
    my ($vhffs, $local_part, $domain) = @_;

    my $sql = 'SELECT COUNT(*) FROM vhffs_ml WHERE local_part = ? AND domain = ?';
    my $dbh = $vhffs->get_db_object();
    my $res = $dbh->selectrow_array($sql, {}, $local_part, $domain);
    return (defined($res) && $res > 0);
}

sub del_sub_with_reply
{
    use Digest::MD5;

    my $self = shift;
    my $subscriber = shift;

    
    my $hash = Digest::MD5::md5_hex( Vhffs::Functions::generate_random_password );

    my $sql = 'UPDATE vhffs_ml_subscribers SET perm = ?, hash = ? WHERE ml_id = ? AND member = ? AND perm IN (?, ?)';
    # FIXME we should return a boolean
    return undef unless($self->get_main->get_db_object->do($sql, undef, Vhffs::Constants::ML_RIGHT_SUB_WAITING_FOR_DEL, $hash, $self->{ml_id}, $subscriber, Vhffs::Constants::ML_RIGHT_SUB, Vhffs::Constants::ML_RIGHT_ADMIN) > 0);

    $self->{subs}->{$subscriber}->{hash} = $hash;
    $self->{subs}->{$subscriber}->{perm} = Vhffs::Constants::ML_RIGHT_SUB_WAITING_FOR_DEL;
    return $hash;
}

sub get_language_for_sub
{
    my ($main, $sub) = @_;

    my $sql = 'SELECT language FROM vhffs_ml_subscribers WHERE member = ?';
    my $lang = $main->get_db_object->selectrow_array($sql, undef, $sub);
    return $lang;
}

sub set_language_for_sub
{
    my ($main, $sub, $language) = @_;

    $language = 'en_US' unless( $language =~ /^\w+$/ );
    my $sql = 'UPDATE vhffs_ml_subscribers SET language = ? WHERE member = ?';
    $main->get_db_object->do($sql, undef, $language, $sub) or return -1;
}

sub get_localpart
{
    my $self = shift;
    return $self->{'local_part'};
}

sub get_signature
{
    my $self = shift;
    return $self->{signature} if defined $self->{signature} and $self->{signature} !~ /^\s*$/;
    return undef;
}

sub set_signature
{
    my ($self, $sig) = @_;
    $sig =~ s/\r\n/\n/;
    $self->{signature} = $sig;
}

sub get_open_archive
{
    my $self = shift;
    return $self->{'open_archive'};
}

sub get_sub_ctrl
{
    my $self = shift;
    return $self->{'sub_ctrl'};
}

sub get_post_ctrl
{
    my $self = shift;
    return $self->{'post_ctrl'};
}

sub get_replyto
{
    my $self = shift;
    return $self->{'reply_to'};
}

sub get_domain
{
    my $self = shift;
    return $self->{'domain'};
}

sub get_prefix
{
    my $self = shift;
    return $self->{'prefix'};
}

sub get_members
{
    my $self = shift;
    return $self->{subs};
}

sub set_replytolist
{
    my $self;
    my $string = $self->{'local_part'} ."\@" . $self->{'domain'} ;
    return $self->set_replyto( $string );
}

sub set_replyto
{
    my( $self , $value ) = @_;
	return -2 if( ( $value != 0 ) && ( $value != 1 ) );
    $self->{'reply_to'} = $value;
    return 1;
}

sub set_open_archive
{
    my( $self , $value ) = @_;
    $self->{'open_archive'} = $value;
}

sub set_sub_ctrl
{
	my( $self , $value ) = @_;
	return -1 unless ( $value =~ /\d+/ );
	return -2 if( $value < Vhffs::Constants::ML_SUBSCRIBE_NO_APPROVAL_REQUIRED || $value > Vhffs::Constants::ML_SUBSCRIBE_CLOSED );
	$self->{'sub_ctrl'} = $value;
	return 0;
}

sub set_post_ctrl
{
	my( $self , $value ) = @_;
	return -1 unless ( $value =~ /\d+/ );
	return -2 if ( $value < Vhffs::Constants::ML_POSTING_OPEN_ALL || $value > Vhffs::Constants::ML_POSTING_ADMINS_ONLY );
	$self->{'post_ctrl'} = $value;
	return 0;
}

sub set_prefix
{
    my( $self , $value ) = @_;

    $self->{'prefix'} = $value;
}

sub getall_subs
{
    my $self = shift;
    return ( keys %{$self->{subs}} );
}

sub getall
{
    my ($vhffs, $state, $name, $group, $domain) = @_;

    return undef if( ! defined $vhffs );

    my $mls = [];
    my @params;
    my $sql = 'SELECT local_part, domain FROM vhffs_ml ml, vhffs_object o WHERE o.object_id = ml.object_id';

    if(defined $state) {
        $sql .= ' AND o.state = ?';
        push @params, $state;
    }
    if(defined $group) {
        $sql .= ' AND o.owner_gid = ?';
        push @params, $group->get_gid;
    }
    if(defined $name) {
        $sql .= ' AND ( local_part LIKE ? OR domain LIKE ?)';
        push @params, '%'.$name.'%', '%'.$name.'%';
    }
    if(defined $domain) {
        $sql .= ' AND domain = ?';
        push @params, $domain;
    }

    $sql .= ' ORDER BY local_part, domain';

    my $dbh = $vhffs->get_db_object;
    my $sth = $dbh->prepare($sql);
    $sth->execute(@params) or return -3;

    while(my @ml = $sth->fetchrow_array) {
        push @$mls, get_by_mladdress($vhffs, @ml);
    }
    return $mls;
}



#Returns all the lists for a group
# FIXME useless
sub getall_by_group
{
    my $vhffs = shift;
    my $group = shift;

    return getall($vhffs, undef, undef, $group);
}

=head2 get_label

See C<Vhffs::Object::get_label>.

=cut

sub get_label {
    my $self = shift;
    return $self->{local_part}.'@'.$self->{domain};
}



sub get_listname
{
    my $self = shift;
    return $self->get_localpart.'@'.$self->get_domain;
}


sub get_listrequestname
{
    my $self = shift;
    return $self->get_localpart.'-request@'.$self->get_domain;
}

1;

__END__

=head1 AUTHORS

Julien Delange < god at gunnm dot org >
Sebastien Le Ray < beuss at tuxfamily dot org >
Sylvain Rochet < gradator at gradator dot net >
