#!/usr/bin/perl

use 5.010_000;
use strict;
use warnings;
use utf8;

our $VERSION = '0.01';

=head1 NAME

mklist.pl - Create a new list 

=head1 SYNOPSIS

B<mklist.pl> {B<mailman>|B<schleuder>} < email

=cut


#######################################################################
#

use Mail::GnuPG;
use MIME::Parser;
use File::Spec::Functions;
use Fcntl qw/:flock SEEK_END/;
use POSIX qw/setuid setgid/;
use Pod::Usage;
use Config::Auto;
use lib '../../../panel/lib';
use Fripost::Schema;

my $transport = shift;
pod2usage(2) unless defined $transport and
                    grep { $transport eq $_}
                         qw/mailman schleuder/;
                         use Cwd;

my $config = Config::Auto::parse( './config', format => "equal" );

# Drop root privileges
unless ($<) {
    chdir File::Spec::Functions::tmpdir or die "Cannot chdir: $!";
    my $user = $transport eq 'mailman' ? 'list' :
               $transport eq 'schleuder' ? 'schleuder' :
               die "I will not let root run this script.\n";
    my @record = getpwnam $user;
    setgid($record[3]) or die "Cannot setgid: $!\n";
    setuid($record[2]) or die "Cannot setuid: $!\n";
}
my ($list, $owner, $password);


#######################################################################
#
# Read the (signed) email from STDIN, and ensure that the signing key
# is authorized to create new lists.
{
    my $parser = MIME::Parser::->new;
    $parser->output_to_core(1);
    my $msg = $parser->parse( \*STDIN );

    die "Error: Not a multipart/signed message.\n"
      unless $msg->is_multipart and
             $msg->mime_type eq 'multipart/signed' and
             $msg->parts;

    my $gpg = Mail::GnuPG::->new;
    die "Error: The message is not GPG/MIME signed.\n"
        unless $gpg->is_signed( $msg );

    my ($ret, $key, $addr) = $gpg->verify( $msg );
    if ($ret) {
        map { print STDERR $_ } @{$gpg->{last_message}};
        exit $ret;
    }

    die "Error: 0x$key ($addr) is not authorized to create lists.\n"
        unless grep { $key eq $_ }
                    (ref $config->{authorized_pubkeys} eq 'ARRAY' ? 
                         @{$config->{authorized_pubkeys}} :
                         $config->{authorized_pubkeys}
                    );


    # The first non-blank line in the email body is the list's email
    # address.
    my @body = grep { !/^\s*$/ }
                    (split /\s*\n\s*/, $msg->parts(0)->stringify_body);
    $list = shift @body;
    $owner = shift @body;
    $password = shift @body;
    # TODO: idealy the email would be encrypted (at least for schleuder),
    # since it contains a password.
}
my ($l,$d) = split /\@/, $list, 2;


#######################################################################
#
# Ensure that the root DN has been created, otherwise doing the below is
# useless. 

{
    # It's pointless to have a global variable here, since after the list
    # creation the connection may not be still alive.
    my $fp = &auth();
    $fp->list->is_pending($list)
        or die "Error: $list is not pending for creation.\n";
    $fp->done;
}


#######################################################################
#
# Create the list

#if ($transport eq 'mailman') {
#    system ( '/var/lib/mailman/bin/newlist', '-q'
#           , '-u', 'smtp.fripost.org' # TODO: that should be $mydestination
#           , $list
#           , $owner 
#           , $password
#    );
#    die "newlist exited with status $?\n" if $?;
#}
#
#elsif ($transport eq 'schleuder') {
#    system ( '/usr/bin/schleuder-newlist'
#           , $list
#           , '-email', $list
#           , '-realname', $l
#           , '-nointeractive'
#           , '-adminaddress', $owner
#           , '-initmember', $owner
#           , '-initmemberkey', # TODO: that needs to be a file
#    );
#    die "schleuder-newlist exited with status $?\n" if $?;
#    system ( '/usr/bin/ruby', '/opt/webschleuder/contrib/enable_webschleuder.rb'
#           , $list
#           , $password
#    );
#    # TODO: try not to use the password in the command argument
#    die "enable_webschleuder exited with status $?\n" if $?;
#}

# List the commands that are to be added to the LDAP directory and the lookup table.
my @cmds = $transport eq 'mailman' ? qw/admin bounces confirm join leave owner request subscribe unsubscribe/ :
           $transport eq 'schleuder' ? qw/bounce sendkey/ :
           die 'Unknown transport';


#######################################################################
#
# Add the LDAP commands under the list's root DN, and remove the
# 'pending' status.
{
    my $fp = &auth();
    $fp->list->add_commands($list, \@cmds);
    $fp->done;
}


#######################################################################
#
# Create/update the Postfix lookup table.

{
    
    my $db = File::Spec::Functions::catfile( $config->{postfix_data_dir},
                                             'transport_'.$transport );
    my $new = not (-e $db);
    open my $fh, '>>', $db or die "Cannot open $db: $!";
    flock $fh, LOCK_EX or die "Cannot lock $db: $!";
    seek $fh, 0, SEEK_END or die "Cannot seek $db: $!";
    if ($new) {
        print $fh "# Do not modify this file! Use $0 to create lists instead.\n"
            or die "Cannot print: $!";
    }
    
    
    print $fh  "\n# ".$list."  -  ".localtime."\n";
    &print_transport($fh, undef);
    foreach (@cmds) { &print_transport($fh, $_); }
    
    close $fh or die "Cannot close $db: $!";
    
    # Compile the lookup table (Postfix takes care of the race condition here).
    system ('/usr/sbin/postmap', '-c', $config->{postfix_config_dir}, $db);
    die "postmap exited with status $?\n" if $?;
}


# Append a list command to the lookup table.
sub print_transport {
    my $fh = shift;
    my $cmd = shift;
    my $l = $l;
    $l .= '-'.$cmd if defined $cmd and $cmd ne '';
    $l .= '#'.$d if defined $d;
    printf $fh "%-63s %s:\n", $l.'@'.$config->{mydestination}, $transport
        or die "Cannot printf: $!";
}

# Authenticate
sub auth {
    Fripost::Schema::->auth( undef, $config->{ldap_bind_pw}
             , ldap_bind_dn => join(',',@{$config->{ldap_bind_dn}})
             , ldap_uri => $config->{ldap_uri}
             , ldap_suffix => $config->{ldap_suffix}
             );
}


#######################################################################
#

=head1 AUTHOR

Guilhem Moulin C<< <guilhem at fripost.org> >>

=head1 COPYRIGHT

Copyright 2012 Guilhem Moulin.

=head1 LICENSE

This program is free software; you can redistribute it and/or modify it
under the same terms as perl itself.

=cut