You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
gpg-ezmlm/GpgEzmlm.pm

731 lines
19 KiB

package GpgEzmlm;
use strict;
use Fcntl;
use File::Sync qw(fsync sync);
use Time::Local;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
use IPC::Open3;
use IO::Select;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(
mydie
copy
mail
runcmd
readConfig
hashaddr
issub
rfc822date
subscribe
prepare
reject
);
$VERSION = '0.3.3';
=head1 NAME
GpgEzmlm - Internal functions for the gpg-ezmlm mailing list suite
=head1 SYNOPSIS
use GpgEzmlm;
Actually, don't. This is an internal API only, not really intended
for use by non-gpg-ezmlm programs.
=head1 DESCRIPTION
Perl module containing common code for the gpg-ezmlm
mailing list suite of scripts
=head2 EXPORT
mydie - Acts like die, but the first argument sets the exit code.
mail - Used to inject mail to qmail-queue
runcmd - Runs a command, and stuffs input to it, puts output and err in
scalars. Uses select() to make sure everything moves smoothly
readConfig - Reads options from config file
hashaddr - Hashes an email addr into one character. Used to determine which
subscriber file a subscriber is/would be in.
issub - Determines if a given email addr is currently subscribed or not.
rfc822date - Returns the date in RFC 822 format
subscribe - Subscribes an email addr to the list
prepare - Decrypts and encrypts messages to the list.
reject - Sends a rejection email to the sender, explaining the reason
for rejection.
=head1 AUTHOR
Todd MacDermid <tmacd@synacklabs.net>
=head1 SEE ALSO
L<perl>.
=cut
#mydie - Just a simple wrapper that I use instead of die(), because
#qmail pays attention to exit values of the script, and this gives
#me control over that
sub mydie {
my $error = shift;
my $string = shift;
print $string;
exit $error;
}
#readConfig - opens the config file, sets a few default values, and
#sets flags and values in a hash that controls behavior of the program.
#definitions of values below:
#
#keyDir - Where are the keyrings stored?
#tempDir - Where the temporary purgatory keyring is stored
#signMessages - Should the ML sign messages
#requireSigs - Do we require content to be signed - NOT YET IMPLEMENTED
#allowKeySubmission - Do we allow users to submit keys through the mgmt
# interface
#stripMime - Should we strip out pgp-encrypted MIME headers? - NOT YET IMPLEMENTED
#encapsulateMime - Should we add in pgp-encrypted MIME headers? - NOT YET IMPLEMENTED
#allowAttach - Whether to allow only inline, or allow attachments as well. - NOT YET IMPLEMENTED
#nokeyNocrypt - Forward messaged unencrypted if no key?
#verifiedKeyReq - Require keys to be verified?
#encryptToAll - Encrypt once, to all keys on list
#requireSub - Only allow subscribers to a list to post to it.
#subList - Are we a sublist? Not set here for ezmlm compat reasons.
#archived - Whether we'll archive messages. Set outside of the main config file
# for ezmlm compatibility
#outhost - The domain hosting the mailing list. Set outside of the main
# config file for ezmlm compatibility
#outlocal - The name of the mailing list, e.g. crypt-ml. Set outside of the
# main config file for ezmlm compatibility
#sublist - If it exists, this is the main list that we are a sublist for.
# Set outside of the main config file for ezmlm compatibility
#allowUnencrypted - Whether to forward unencrypted content. - NOT YET IMPLEMENTED
sub readConfig {
my $configFile = shift;
my $configRef = shift;
#DEFAULT VALUES
$$configRef{keyDir} = ".gnupg";
$$configRef{tempDir} = "tmp";
$$configRef{gpg} = "/usr/local/bin/gpg";
$$configRef{qmailDir} = "/var/qmail/bin";
$$configRef{allowUnencrypted} = 1;
$$configRef{signMessages} = 1;
$$configRef{allowKeySubmission} = 1;
#END DEFAULTS
open OUTHOST, "<outhost" or mydie(111, "unable to open outhost: $!\n");
$$configRef{outhost} = <OUTHOST>;
chomp $$configRef{outhost};
close(OUTHOST);
open OUTLOCAL, "<outlocal" or mydie(111, "unable to open outlocal: $!\n");
$$configRef{outlocal} = <OUTLOCAL>;
chomp $$configRef{outlocal};
close(OUTLOCAL);
if(open ARCHIVED, "<archived") {
if (defined($$configRef{archived} = <ARCHIVED>)) {
chomp $$configRef{archived};
}
close(ARCHIVED);
}
if(open SUBLIST, "<sublist") {
if (defined($$configRef{sublist} = <SUBLIST>)) {
chomp $$configRef{sublist};
}
close(SUBLIST);
}
if (open CONFIG, "$configFile") {
while (defined(my $confline = <CONFIG>)) {
chomp $confline;
if ($confline =~/^\s*keyDir\s+(\S+)/i) {
$$configRef{keyDir} = $1;
} elsif ($confline =~/^\s*tempDir\s+(\S+)/i) {
$$configRef{tempDir} = $1;
} elsif ($confline =~/^\s*gnupg\s+(\S+)/i) {
$$configRef{gpg} = $1;
} elsif ($confline =~/^\s*qmailbin\s+(\S+)/i) {
$$configRef{qmailDir} = $1;
} elsif ($confline =~/^\s*signmessages\s+(\S+)/i) {
if ($1 =~ /n/i) {
$$configRef{signMessages} = 0;
}
} elsif ($confline =~/^\s*RequireSigs\s+(\S+)/i) {
if ($1 =~ /y/i) {
$$configRef{requireSigs} = 1;
}
} elsif ($confline =~/^\s*StripMime\s+(\S+)/i) {
if ($1 =~ /y/i) {
$$configRef{stripMime} = 1;
}
} elsif ($confline =~/^\s*EncapsulateMime\s+(\S+)/i) {
if ($1 =~ /y/i) {
$$configRef{encapsulateMime} = 1;
}
} elsif ($confline =~ /^\s*AllowAttach\s+(\S+)/i) {
if ($1 =~ /y/i) {
$$configRef{allowAttach} = 1;
}
} elsif ($confline =~/^\s*NokeyNocrypt\s+(\S+)/i) {
if ($1 =~ /y/i) {
$$configRef{nokeyNocrypt} = 1;
}
} elsif ($confline =~/^\s*allowKeySubmission\s+(\S+)/i) {
if ($1 =~ /n/i) {
$$configRef{allowKeySubmission} = 0;
}
} elsif ($confline =~/^\s*VerifiedKeyReq\s+(\S+)/i) {
if ($1 =~ /y/i) {
$$configRef{verifiedKeyReq} = 1;
}
} elsif ($confline =~/^\s*allowUnencrypted\s+(\S+)/i) {
if ($1 =~ /n/i) {
$$configRef{allowUnencrypted} = 0;
}
} elsif ($confline =~/^\s*EncryptToAll\s+(\S+)/i) {
if ($1 =~ /y/i) {
$$configRef{encryptToAll} = 1;
}
} elsif ($confline =~/^\s*RequireSub\s+(\S+)/i) {
if ($1 =~ /y/i) {
$$configRef{requireSub} = 1;
}
} elsif ($confline =~/^\s*strictlevel\s+(\d+)/i) {
$$configRef{strictlevel} = $1;
}
}
close(CONFIG);
}
}
#copy takes a filename and a buffer, and appends the contents of that
#file to the buffer. These files are the messages that the mailing list
#sends back. If a line consists of a !R or !A, or contains the
#tags <#l#>, <#n#>, or <#h#>, then the contents of that line are replaced.
sub copy {
my $file = shift;
my $buffer = shift;
my $isHeader = shift;
my $configRef = shift;
my $confirm = shift;
my $target = shift;
my $outmsgnum = shift;
open FILE, "<$file" or mydie(111, "unable to open $file: $!\n");
while (my $line = <FILE>) {
$line =~ s/^\!R/$confirm/;
$line =~ s/^\!A/$target/;
$line =~ s/<\#l\#>/$$configRef{outlocal}/;
$line =~ s/<\#h\#>/$$configRef{outhost}/;
$line =~ s/<\#n\#>/$outmsgnum/;
if($isHeader > 0) {
if($line =~ /\S+/) {
$$buffer .= $line;
}
} else {
$$buffer .= $line;
}
}
close(FILE);
}
#runcmd - Runs a command, pushes all the input through it, and writes
#to output and err. Select()s across reading and writing, for those
#processes that can't hold all your input before they need to be read from
#Solves a problem with large messages being pushed through gpg. Thanks to
#tcannon@noops.org for the catch.
sub runcmd {
my $cmdline = shift;
my $inputref = shift;
my $outputref = shift;
my $errref = shift;
$$outputref = "";
$$errref = "";
my $readpos = 0;
my $writepos = 0;
my $errpos = 0;
my $writeDone = 0;
my $readDone = 0;
my $errDone = 0;
my $done = 0;
my $len;
my @ready = ();
my $stringLength;
my $pid = open3(\*WRITE, \*READ, \*ERR, "$cmdline") or
mydie(100, "Cannot run $cmdline\n");
my $select = IO::Select->new();
if($$inputref) {
$select->add(\*WRITE);
$stringLength = length($$inputref);
} else {
$writeDone = 1;
close(WRITE);
}
$select->add(\*READ);
$select->add(\*ERR);
while(!$done) {
if ((!$writeDone) and (@ready = $select->can_write(0))) {
foreach my $handle (@ready) {
if($handle == \*WRITE) {
if($stringLength - $writepos > 4096) {
$len = syswrite(WRITE, $$inputref, 4096, $writepos);
} else {
$len = syswrite(WRITE, $$inputref, ($stringLength - $writepos), $writepos);
}
if ($len > 0) {
$writepos += $len;
} else {
mydie(111,"System write error: $!\n");
}
if($writepos == $stringLength) {
$writeDone = 1;
$select->remove(\*WRITE);
close (WRITE);
}
}
}
}
if (@ready = $select->can_read(0)) {
foreach my $handle (@ready) {
if($handle == \*READ) {
$len = sysread(READ, $$outputref, 4096, $readpos);
if(defined($len)) {
if($len > 0) {
$readpos += $len;
} else {
$readDone = 1;
close(READ);
$select->remove(\*READ);
}
} else {
die "System read error: $!\n";
}
}
if($handle == \*ERR) {
$len = sysread(ERR, $$errref, 4096, $errpos);
if(defined($len)) {
if($len > 0) {
$errpos += $len;
} else {
$errDone = 1;
close(ERR);
$select->remove(\*ERR);
}
} else {
die "System read error: $!\n";
}
}
}
}
# I know the below looks like an error, that it should be
# ($errDone and $readDone and $writeDone), but I've been testing this,
# and the select never lets me through to pick the EOF off the READ
# filehandle on gpg encrypts. If you know why, please enlighten me.
if(($errDone or $readDone) and $writeDone) {
$done = 1;
}
}
# OK, I actually am having issues with read not getting everything... <sigh>
# Hopefully, the below read will empty everything out of the read buffer.
while($readDone != 1) {
$len = sysread(READ, $$outputref, 4096, $readpos);
if(defined($len)) {
if($len > 0) {
$readpos += $len;
} else {
$readDone = 1;
close(READ);
$select->remove(\*READ);
}
}
}
return($pid);
}
#mail - injects the mail into the system. Headers and body contained in
#$message
sub mail {
my $qmailqueue = shift;
my $message = shift;
my $from = shift;
my @to = @_;
pipe READ0, WRITE0;
pipe READ1, WRITE1;
my $pid = fork();
if ($pid) {
close(READ0);
close(READ1);
} else {
close(WRITE0);
close(WRITE1);
fcntl READ0, &F_GETFL, 0 or mydie(111,"READ0 not open?\n");
close(STDIN);
fcntl READ0, &F_DUPFD, 0;
fcntl READ1, &F_GETFL, 0 or mydie(111,"READ1 not open?\n");
close(STDOUT);
fcntl READ1, &F_DUPFD, 1;
exec "$qmailqueue";
}
print WRITE0 "$message\n";
close (WRITE0);
print WRITE1 "F";
print WRITE1 "$from";
print WRITE1 "\0";
foreach my $to (@to) {
print WRITE1 "T";
print WRITE1 "$to";
print WRITE1 "\0";
}
print WRITE1 "\0";
close(WRITE1);
}
#ezmlm separates subscriber lists into single character files. The below
#replicates the ezmlm algorithm to determine the username to filename
#mapping, so gpg-ezmlm can convert an existing ezmlm list and not need
#to convert the subscriber list files.
sub hashaddr {
my $addr = shift;
my $h = 5381;
my $packed;
{ # Nasty nasty icky perl hack forthcoming
use integer;
my @addr = split "", $addr;
for (my $j = 0; $j < length $addr; $j++) {
$h = ($h + ($h << 5) ^ ord($addr[$j]));
$h = $h & 0xffffffff # To deal with 64 bit architectures
}
$packed = pack "l", $h;
}
my $unpacked = unpack "L", $packed;
my $ch = chr(64 + ($unpacked % 53));
return ($ch);
}
#issub checks to see if a given address is subscribed to the mailing
#list. Returns 0 if not subscribed, 1 if subscribed
sub issub {
my $address = shift;
my $addr = "T" . lc($address);
my $char = hashaddr($addr);
open FD, "<subscribers/$char" or return(0);
my $line = <FD>;
foreach my $ss (split "\0", $line) {
if ($ss =~ qq/^$addr/) {
return(1);
}
}
return(0);
}
#rfc822date returns a string containing the date in rfc822 format.
#You were expecting it to break RSA keys? ^_^
sub rfc822date {
use integer;
my $epoch = time();
my $localtime = localtime;
my $retstring;
if ($localtime =~ /^(\S+)\s+(\S+)\s+(\d+)\s+(\d+\:\d+\:\d+)\s+(\d+)/) {
$retstring = "$1, $3 $2 $5 $4 ";
}
my $tl = timelocal((localtime)[0,1,2,3,4,5]);
my $tg = timegm((localtime)[0,1,2,3,4,5]);
my $secdiff = $tg - $tl;
my $hourdiff = $secdiff / 3600;
my $mindiff = ($secdiff/60) % 60;
my $offset;
$offset = sprintf ("%.02d%.02d", $hourdiff, $mindiff);
$retstring .= $offset;
return $retstring;
}
#subscribe actually adds the subscriber email address to one of the
#subscriber list files, if it's not there already, shorter than
#400 characters, and a whole bunch of other potential error conditions.
#The subscriber files are a set of 53 single character files contained
#in the subscribers subdir. Which file a subscriber belongs in is determined
#by hashaddr
sub subscribe {
my $userhost = shift;
my $flagadd = shift;
my $LOCK_EX = 2;
open LOCK, ">lock" or mydie(111,"unable to open lock: $!\n");
flock LOCK, $LOCK_EX or mydie(111,"unable to obtain lock: $!\n");
if($userhost =~ /\n/) {
print "address contains newline\n";
return -8;
}
my $addr = "T" . lc($userhost);
if (length($addr) > 400) {
print "address is too long\n";
return -7;
}
if (!($addr =~ /\@/)) {
print "address does not contain @\n";
return -6;
}
my $ch = hashaddr($addr);
my $fn = "subscribers/$ch";
my $fnnew = $fn."n";
if (!(open FDNEW, ">$fnnew")) {
print "unable to write $fnnew: $!\n";
return -4;
}
my $flagwasthere = 0;
if (!(open FD, "$fn")) {
# print "unable to read $fn: $!\n"; # Need to separate ENOENT from other
# return -3; # errors. fix later.
} else {
my $line = <FD>;
foreach my $ss (split "\0", $line) {
if ($ss =~ qq/^$addr/) {
$flagwasthere = 1;
if (!($flagadd)) { next; }
}
print FDNEW "$ss\0";
}
close FD;
}
if ($flagadd && !$flagwasthere) {
print FDNEW "$addr\0";
}
my $fdnew = select(FDNEW);
$| = 1; # flush FDNEW's buffers
select($fdnew);
if (!(fsync(FDNEW))) {
close (FDNEW);
print "unable to write $fnnew: $!\n";
return -4;
}
close FDNEW;
if (!(rename "$fnnew", "$fn")) {
print "unable to move temporary file to $fn: $!";
return -5;
}
return ($flagadd ^ $flagwasthere);
}
# prepare takes in a raw message in the form of an array of lines, a config
# hash reference, and an array of recipients. It will return the message
# encrypted for all recipients that it has keys for, or if it has no keys,
# it will return error messages.
sub prepare {
my $messageArrayRef = shift;
my $configref = shift;
my $archived = shift;
my @recipients = shift;
my $inheader = 1;
my $flagmlwasthere = 0;
my $flagbadfield = 0;
my $flagincrypted = 0;
my $incontenttype = 0;
my %headerremovemap = ();
my @header = ();
my @cryptedmessage = ();
my @message = ();
my @decryptedmessage = ();
my $numcrypted = 0;
my $nummessage = 0;
my $gpg = "$$configref{gpg} --homedir $$configref{keyDir}";
my $mydtline = "Delivered-To: mailing list ".$$configref{outlocal}."\@".$$configref{outhost};
open HEADERRM, "<headerremove" or
mydie(111, "unable to open headerremove: $!\n");
while (<HEADERRM>) {
chomp;
/^(\S+)/;
$headerremovemap{(lc $1)} = 1;
}
close(HEADERRM);
foreach my $line (@$messageArrayRef) {
if(!($line =~ /\S+/)) {
$inheader = 0;
}
if($inheader) {
if($line =~ /^(\S+):/) {
$flagbadfield = 0;
$incontenttype = 0;
if($headerremovemap{(lc $1)}) {
$flagbadfield = 1;
} else {
$flagbadfield = 0;
}
}
if($archived) {
if ($line =~ /^subject:/i) {
$line =~ s/subject:/Subject: \[$$configref{outlocal} archive \#$archived\]/i;
}
} else {
if ($line =~ /^$mydtline/i) {
mydie(100, "this message is looping: it already has my Delivered-To line (#5.4.6): $line\n");
}
}
if ($line =~ /^mailing-list:/i) {
$flagmlwasthere = 1;
}
if(!($flagbadfield)) {
push @header, $line;
}
} else {
if (!($archived)) {
if($$configref{subList}) {
if (!($flagmlwasthere)) {
mydie(100, "sublist messages must have Mailing-List (#5.7.2)\n");
}
} else {
if ($flagmlwasthere) {
mydie(100, "message already has Mailing-List (#5.7.2)\n");
}
}
}
if ($line =~ /-----BEGIN PGP MESSAGE-----/) {
$flagincrypted = 1;
}
if($flagincrypted) {
push @{$cryptedmessage[$numcrypted]}, $line;
} else {
push @{$message[$nummessage]}, $line;
}
if ($line =~ /-----END PGP MESSAGE-----/) {
$flagincrypted = 0;
$numcrypted++;
$nummessage++;
}
}
}
for(my $i = 0; $i < $numcrypted; $i++) {
my $error;
my @signlines = ();
my $goodsig = 0;
my $trustedsig = 1;
my $ciphertext = join '', @{$cryptedmessage[$i]};
runcmd("$gpg -d", \$ciphertext, \$decryptedmessage[$i], \$error);
foreach my $errline (split /\n/, $error) {
if (($errline =~ /decryption failed/) or
($errline =~ /invalid packet/)) {
$decryptedmessage[$i] = "Unable to decrypt content";
}
# if (/signature/) {
# push @signlines, $_;
}
}
my $mail;
$mail .= $mydtline. "\n";
if (-r "headeradd") {
copy("headeradd", \$mail, 1, $configref);
}
foreach my $hline (@header) {
$mail .= $hline;
}
for (my $i = 0; $i < ($numcrypted+1); $i++) {
if ($message[$i]) {
foreach my $line (@{$message[$i]}) {
$mail .= $line;
}
}
if ($decryptedmessage[$i]) {
my $recipientline;
foreach my $recipient (@recipients) {
$recipientline .= " -r $recipient";
}
my $error;
my $plaintext = $decryptedmessage[$i];
my $ciphertext;
if ($$configref{verifiedKeyReq}) {
if ($$configref{signMessages}) {
runcmd("$gpg --no --no-tty --batch -sea $recipientline",
\$plaintext,
\$ciphertext,
\$error);
} else {
runcmd("$gpg --no --no-tty --batch -ea $recipientline",
\$plaintext,
\$ciphertext,
\$error);
}
} else {
if ($$configref{signMessages}) {
runcmd("$gpg --yes --no-tty --batch --always-trust -sea $recipientline",
\$plaintext,
\$ciphertext,
\$error);
} else {
runcmd("$gpg --yes --no-tty --batch --always-trust -ea $recipientline",
\$plaintext,
\$ciphertext,
\$error);
}
}
my $goodcrypt = 1;
foreach my $errline (split /\n/, $error) {
if (($errline =~ /public key not found/) or
($errline =~ /no valid addressees/)) {
$goodcrypt = 0;
if(!($$configref{encryptToAll})) {
if ($$configref{nokeyNocrypt}) {
$mail .= $plaintext;
} else {
$mail .= "Encrypted content not forwarded due to lack of key.\n";
}
}
}
}
if (($goodcrypt) or ($$configref{encryptToAll})) {
$mail .= $ciphertext;
}
}
}
return($mail);
}