A script to create lists (piping an email command).

2 files changed, 252 insertions, 0 deletions

diff --git a/misc/mklist/config b/misc/mklist/config
new file mode 100644
index 0000000..e913ecd
--- /dev/null
+++ b/misc/mklist/config
@@ -0,0 +1,20 @@
+# A comma-separated list of public keys that are allowed to ask for
+# a list creation. (Note: the key have to be in the user's public
+# keyring.)
+authorized_pubkeys = AF910D26
+
+# Postfix configuration directory.
+postfix_config_dir = /etc/postfix/
+
+# Where to put the lookup transport tables.
+#postfix_data_dir = /etc/postfix/
+postfix_data_dir = /tmp
+
+# The domain to be appended to *local* aliases.
+mydestination = lists.fripost.org
+
+# LDAP configuration
+ldap_uri = ldap://127.0.0.1:389
+ldap_suffix = ou=virtual,o=mailHosting,dc=fripost,dc=dev
+ldap_bind_dn = cn=ListCreator,ou=services,o=mailHosting,dc=fripost,dc=dev
+ldap_bind_pw = listcreator
diff --git a/misc/mklist/mklist.pl b/misc/mklist/mklist.pl
new file mode 100755
index 0000000..105178a
--- /dev/null
+++ b/misc/mklist/mklist.pl
@@ -0,0 +1,232 @@
+#!/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