#!/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>} [size] < email

=cut


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

use File::Spec::Functions qw/catfile catdir/;
use Fcntl qw/:flock SEEK_END/;
use POSIX qw/setuid setgid/;
use Pod::Usage;
use Config::Auto;
use lib 'lib';
use Mail::GnuPG;
use MIME::Parser;
use MIME::QuotedPrint;
use Net::IDN::Encode 'email_to_ascii';
use Fripost::Schema;

my $transport = shift;
pod2usage(2) unless defined $transport and
                    grep { $transport eq $_}
                         qw/mailman schleuder/;
my $configdir = catdir(qw(/ etc mklist));
my $config = Config::Auto::parse( catfile($configdir, 'config'),
                                  format => "equal" );

my $size = shift;
die "Email size $size is bigger than the maximum authorized (".$config->{max_size}.").\n"
    if defined $config->{max_size} and defined $size and $size > $config->{max_size};

# 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( keydir => catdir($configdir,'gnupg-'.$transport) );
    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 = decode_qp(shift @body);
    Encode::_utf8_on($list); $list = email_to_ascii($list);
    $owner = decode_qp(shift @body);
    $password = decode_qp(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 died with status $?\n" if $?;
}

elsif ($transport eq 'schleuder') {
    system ( '/usr/bin/schleuder-newlist'
           , $list
           , '-email', $list
           , '-realname', $l
           , '-nointeractive'
           , '-adminaddress', $owner
    );
    die "schleuder-newlist died with status $?\n" if $?;
    my $pid = open PW, '|-', '/opt/webschleuder/contrib/enable_webschleuder.rb', $list
              or die "Cannot open: $!";
    print PW $password or die "Cannot print: $!";
    close PW;
    my $r = $? >> 8;
    die "enable_webschleuder died with status $r\n" if $r;
}

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


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

{
    my $db = 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 died with status $?\n" if $?;
}


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


#######################################################################
#
# 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 to the LDAP directory.
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