1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
|
#!/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
|
