kuvert/kuvert

#!/usr/bin/perl
#
# this file is part of kuvert, a wrapper around sendmail that
# does pgp/gpg signing/signing+encrypting transparently, based
# on the content of your public keyring(s) and your preferences.
#
# copyright (c) 1999-2005 Alexander Zangerl <az@snafu.priv.at>
#
#   This program is free software; you can redistribute it and/or modify
#   it under the terms of the GNU General Public License as published by
#   the Free Software Foundation; either version 2 of the License, or
#   any later version.
#
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#   GNU General Public License for more details.
#
#   You should have received a copy of the GNU General Public License
#   along with this program; if not, write to the Free Software
#   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#   $Id: kuvert,v 2.14 2005/02/25 22:09:21 az Exp az $
#--

use strict;
use Sys::Syslog qw(setlogsock openlog syslog closelog);
use Fcntl qw(:flock);
use Getopt::Std;
use MIME::Parser;		# for parsing the mime-stream
use Mail::Address;		# for parsing to and cc-headers
use FileHandle;
use Term::ReadKey;
use Proc::PID::File;

# some global stuff
# the version number is inserted by make install
my $version="INSERT_VERSION";
my $progname="kuvert";
# who are we gonna pretend to be today?
my($username,$home)=(getpwuid($<))[0,7];
# where is the configuration file
my $rcfile="$home/.kuvert";
# configuration directives, keyring
my (%config,@overrides,%keys);
# the passphrases are stored here if passphrase store is not a/v
my %secrets=();
my ($debug,$barfmail);
my @detailederror=();

my $piddir=($ENV{'TMPDIR'}?$ENV{'TMPDIR'}:"/tmp");
my $pidname="$progname.$<";

sub main
{
    my %options;

    if (!getopts("dkrnvb",\%options) || @ARGV)
    {
	die "usage: $progname [-n] [-d] [-v] [-b]| [-k] | [-r] 
-k: kill running $progname
-d: debug mode
-r: reload keyrings and configfile
-n don't fork
-v: output version and exit
-b: complain via mail when dying\n";
    }
    
    if ($options{'v'})
    {
	print STDERR "$progname $version\n";
	exit 0;
    }
    
    $debug=1 if ($options{"d"});
    $barfmail=1 if ($options{"b"});

    # kill a already running process
    # TERM for kill or HUP for rereading
    if ($options{"k"} || $options{"r"})
    {
	my $pid;
	my $sig=($options{"r"}?'USR1':'TERM');

	open(PIDF,"$piddir/$pidname.pid") || &bailout("cant open pidfile: $! -- exiting");
	$pid=<PIDF>;
	close(PIDF);
	chomp $pid;

	&bailout("no valid pid found, cant kill any process -- exiting")
	    if (!$pid);
	&bailout("cant kill -$sig $pid: $! -- exiting")
	    if (!kill $sig, $pid);
	exit 0;
    }

    if (! -e $rcfile)
    {
	open(F,">$rcfile") || &bailout("can't create $rcfile: $! -- exiting");
	print F "# configuration file for kuvert\n"
	    ."# see kuvert(1) for details\n";
	close(F);
	1==chmod(0600,$rcfile) || 
	    &bailout("can't chmod $rcfile: $! -- exiting");
	print STDERR "created blank configuration file $rcfile\n"
    }

    logit("$progname version $version starting");

    # read the config, setup dirs, logging, defaultkeys etc.
    &read_config;

    # get the passphrase(s) if no external passphrase store is used
    # this has to be done before a fork...
    if (!$config{secretondemand})
    {
	# get the passphrases and verify them
	# if we do ng or std, ie. keyid!=0
	get_secret("std") if ($config{stdkey});
	get_secret("ng") if ($config{ngkey});
    }

    if (!$debug && !$options{"n"})
    {
	my $res=fork;

	&bailout("fork failed: $! -- exiting")
	    if ($res == -1);
	exit 0 if ($res);
    }

    # check that we're the only instance running
    bailout("$progname: some other instance is running!")
	if (Proc::PID::File->running(dir=>$piddir,
				     name=>$pidname));

    # make things clean and ready. we're in sole command now.
    cleanup($config{tempdir},0);
    &read_keyrings;

    # install the handler for conf reread
    $SIG{'USR1'}=\&handle_reload;
    # and the termination-handler
    $SIG{'HUP'}=\&handle_term;
    $SIG{'INT'}=\&handle_term;
    $SIG{'QUIT'}=\&handle_term;
    $SIG{'TERM'}=\&handle_term;

    # the main loop, left only via signal handler handle_term
    while (1)
    {
	&bailout("cant open $config{queuedir}: $! -- exiting")
	    if (!opendir(D,"$config{queuedir}"));
	
	my $file;
	foreach $file (grep(!/^\./,readdir(D)))
	{
	    if (!open(FH,"$config{queuedir}/$file"))
	    {
		logit("huh? $file just disappeared? $!");
		next;
	    }
	    # lock it if possible
	    if (!flock(FH,LOCK_NB|LOCK_EX))
	    {
		close(FH);
		logit("$file is locked, skipping.");
		next;
	    }

	    #ok, open & locked, let's proceed
	    logit("processing $file for $username");
	    $barfmail=0; # avoid duplicate mails, we're eval()ing!
	    eval { process_file(*FH,"$config{queuedir}/$file"); };
	    $barfmail=1 if ($options{"b"});
	    if ($@)
	    {
		chomp(my $error=$@);
		
		rename("$config{queuedir}/$file","$config{queuedir}/.$file")
		    || &bailout("cant rename $config{queuedir}/$file: $! -- exiting");
		logit("failed to process $file, left as \".$file\".\n");
		send_bounce($error,$file);
	    }
	    else
	    {
		logit("done with file $file");
		unlink("$config{queuedir}/$file")
		    || &bailout("cant unlink $config{queuedir}/$file: $! -- exiting");
	    }
	    # and clean up the cruft left behind, please!
	    cleanup("$config{tempdir}",0);

	    # unlock the file
	    bailout("problem unlocking $config{queuedir}/$file: $! -- exiting")
		if (!flock(FH,LOCK_UN));
	    close(FH);
	}
	closedir(D);
	&handle_term("debug mode") if ($debug);
	sleep($config{interval});
    }
}

# processes a file in the queue, does not remove stuff from the tempdir or the queue
# exception on errors
sub process_file
{
    my ($fh,$file)=@_;

    my $parser = new MIME::Parser;

    # dump mime object to tempdir
    $parser->output_dir($config{tempdir});
    # retain rfc1522-encoded headers, please
    $parser->decode_headers(0);
    # make the parser ignore all filename info and just invent filenames.
    $parser->filer->ignore_filename(1);

    my $in_ent;

    eval { $in_ent=$parser->read(\$fh); };
    bailout("could not parse MIME stream, last header was ".$parser->last_head)
	if ($@);

    # add version header
    $in_ent->head->add('X-Mailer',"$progname $version")
	if ($config{identify});

    # extract and delete instruction header
    my $custom_conf=lc($in_ent->head->get("x-kuvert"));
    $in_ent->head->delete("x-kuvert");

    # strip trailing and leading whitespace from the custom header
    $custom_conf =~ s/^\s*(\S*)\s*$/$1/;
    
    # check the custom header for validity
    undef $custom_conf 	
	unless ($custom_conf=~/^(none|std(sign)?|ng(sign)?|fallback)(-force)?$/);

    # extract a possible resend-request-header, if set call mta immediately
    if ($custom_conf eq "none" || $in_ent->head->get("resent-to"))
    {
	logit(($custom_conf eq "none"?"resending ":"")
	       ."sign/encrypt disabled, calling $config{mta} -t");
	# we do not send the original file here because this file possibly
	# holds the instruction header...
	&send_entity($in_ent,"-t");
	$in_ent->purge;
	return;
    }

    my (@recip_all,@recip_bcc);

    # get the recipients
    map { push @recip_all, lc($_->address); } 
    Mail::Address->parse($in_ent->head->get("To"),
			 $in_ent->head->get("Cc"));
    
    map { push @recip_bcc, lc($_->address); } 
    Mail::Address->parse($in_ent->head->get("Bcc"));
    # but don't leak Bcc...
    $in_ent->head->delete("Bcc");

    # cry out loud if there is a problem with the submitted mail 
    # and no recipients were distinguishable...
    # happens sometimes, with mbox-style 'From bla' lines in the headers...
    bailout("no recipients found! the mail headers seem to be garbled.")
	if (!@recip_all && !@recip_bcc);

    # figure out what to do for specific recipients
    my %actions=findaction($custom_conf,\@recip_all,\@recip_bcc);

    my $orig_header;
    my $input="$config{tempdir}/.input";

    # take care of raw mails, before mangling the headers
    my @recips=grep($actions{$_} eq "none",keys %actions);
    if (@recips)
    {
	logit("sending mail (raw) to ".join(",",@recips));
	&send_entity($in_ent,@recips);
    }
    
    # prepare various stuff we need only when encrypting or signing
    if(grep(/(ng|std)/,values(%actions)))
    {
	# copy (mail)header, split header info
	# in mime-related (remains with the entity) and non-mime
	# (is saved in the new, outermost header-object)
	$orig_header=$in_ent->head->dup;

	# content-* stays with the entity and the rest moves to orig_header
	foreach my $headername ($in_ent->head->tags)
	{
	    if ($headername !~ /^content-/i)
	    {
		# remove the stuff from the entity
		$in_ent->head->delete($headername);
	    }
	    else
	    {
		# remove this stuff from the orig_header
		$orig_header->delete($headername);
	    }
	}

	# any text/plain parts of the entity have to be fixed with the
	# correct content-transfer-encoding (qp), since any transfer 8->7bit
	# on the way otherwise will break the signature.
	# this is not necessary if encrypting, but done anyways since
	# it doesnt hurt and we want to be on the safe side.

	qp_fix_parts($in_ent);

	# now we've got a $in_entity which is ready to be encrypted/signed
	# and the mail-headers are saved in $orig_header

	# since old pgp has problems with stuff signed/encrypted
	# by newer software that uses partial-length headers when fed
	# data via pipe, we write out our $in_entity to a tempfile 
	# which is then used in the relevant signing/encryption operations.

	bailout("cant open >$input: $!")
	    if (!open(F,">$input"));
	$in_ent->print(\*F);
	close(F);
    }

    foreach my $action qw(ng ngsign std stdsign bcc-ng bcc-std)
    {
	my @recips=grep($actions{$_} eq $action,keys %actions);
	next if (!@recips);

	my $type=($action=~/ng/?"ng":"std");

	if ($action=~/bcc/)
	{
	    # send stuff single file, one completely separate mail per bcc recipient...ugly and slow
	    # but the Right Thing, otherwise we leak encryption key information
	    # (only necessary for encryption)
	    foreach (@recips)
	    {
		logit("sending mail (bcc,crypt,$type) to $_");
		&crypt_send($in_ent,$input,$type,$orig_header,[$keys{$type}->{$_}],$_);
	    }
	    next;
	}
	
	if ($action=~/sign/)
	{
	    logit("sending mail (sign,$type) to ".join(",",@recips));
	    &sign_send($in_ent,$input,$type,$orig_header,@recips);
	    next;
	}
	else
	{
	    my @recipkeys;
	    map { push @recipkeys,$keys{$type}->{$_}; } @recips;
	    logit("sending mail (crypt,$type) to ".join(",",@recips));
	    &crypt_send($in_ent,$input,$type,$orig_header,\@recipkeys,@recips);
	}
    }
}

# sign an entity and send the resulting email to the listed recipients
# args: entity, location of dump of entity, type, outermost headers, recipients
# exception on errors
sub sign_send
{
    my ($ent,$dumpfile,$type,$header,@recips)=@_;
    my $output="$config{tempdir}/.signout";

    # generate a new top-entity to be mailed
    my $newent=new MIME::Entity;
    # make a private copy of the main header and set this one
    $newent->head($header->dup);
    # make it a multipart/signed
    # and set the needed content-type-fields on this top entity
    $newent->head->mime_attr("MIME-Version"=>"1.0");
    $newent->head->mime_attr("Content-Type"=>"multipart/signed");
    $newent->head->mime_attr("Content-Type.Boundary"=>
			     &MIME::Entity::make_boundary);
    $newent->head->mime_attr("Content-Type.Protocol"=>
			     "application/pgp-signature");
    $newent->head->mime_attr("content-Type.Micalg" => ($type eq "ng"?"pgp-sha1":"pgp-md5"));

    $newent->preamble(["This is a multi-part message in MIME format.\n",
		       "It has been signed conforming to RFC3156.\n",
		       "You need GPG or PGP to check the signature.\n"]);

    # add the passed entity as part
    $newent->add_part($ent);

    # generate the signature, repeat until proper passphrase given
    while (&sign_encrypt(0,$type,$dumpfile,$output,undef))
    {
	# get rid of broken passphrase and lets try again
	if ($config{secretondemand})
	{
	    $debug && logit("bad passphrase, retry");
	    my $cmd=sprintf($config{delsecret},$config{$type."key"});
	    my $res=0xffff & system("$cmd >$config{tempdir}/subproc 2>&1");
	    bailout("error deleting broken passphrase from store: $res",
		    "$config{tempdir}/subproc")
		if ($res);		
	}
	else
	{
	    # bad passphrase but we're on our own -> cant recover
	    bailout("bad passphrase, but no passphrase store to query!");
	}
    }
    # attach the signature
    $newent->attach(Type => "application/pgp-signature",
		    Path => "$output",
		    Filename => undef,
		    Disposition => "inline",
		    Encoding => "7bit");
    # and send the resulting thing, not cleaning up
    &send_entity($newent,@recips);
}

# encrypt and sign an entity, send the resulting email to the listed recipients
# args: entity, location of dump of entity, type, outermost headers, recipient keys, recipient addresses
sub crypt_send
{
    my ($ent,$dumpfile,$type,$header,$rec_keys,@recips)=@_;
    my $output="$config{tempdir}/.encout";

    # generate a new top-entity to be mailed
    my $newent=new MIME::Entity;
    # make a private copy of the main header and set this one
    $newent->head($header->dup);
    # make it a multipart/encrypted
    # and set the needed content-type-fields on this top entity
    $newent->head->mime_attr("MIME-Version"=>"1.0");
    $newent->head->mime_attr("Content-Type"=>"multipart/encrypted");
    $newent->head->mime_attr("Content-Type.Boundary"=>
			     &MIME::Entity::make_boundary);
    $newent->head->mime_attr("Content-Type.Protocol"=>
			     "application/pgp-encrypted");
    # set the new preamble
    $newent->preamble(["This is a multi-part message in MIME format.\n",
		       "It has been encrypted conforming to RFC3156.\n",
		       "You need PGP or GPG to view the content.\n"]);

    # attach the needed dummy-part
    $newent->attach(Type=>"application/pgp-encrypted",
		    Data=>"Version: 1\n",
		    Encoding=>"7bit");

    # generate the encrypted data, repeat until proper passphrase given
    while (&sign_encrypt(1,$type,$dumpfile,$output,@{$rec_keys}))
    {
	# get rid of broken passphrase and lets try again
	if ($config{secretondemand})
	{
	    $debug && logit("bad passphrase, retry");
	    my $cmd=sprintf($config{delsecret},$config{$type."key"});
	    my $res=0xffff & system("$cmd >$config{tempdir}/subproc 2>&1");
	    bailout("error deleting broken passphrase from store: $res",
		    "$config{tempdir}/subproc")
		if ($res);		
	}
	else
	{
	    # bad passphrase but we're on our own -> cant recover
	    bailout("bad passphrase, but no passphrase store to query!");
	}
    }
    
    # attach the encrypted data
    $newent->attach(Type => "application/octet-stream",
		    Path => "$output",
		    Filename => undef,
		    Disposition => "inline",
		    Encoding=>"7bit");

    # and send the resulting thing
    &send_entity($newent,@recips);
}


# send entity to $mta, passing $args to $mta
# ent is a MIME::Entity and args is either "-t" or a list of recipients
# exception on errors
sub send_entity
{
    my ($ent,@args)=@_;

    my $pid=open(TOMTA,"|-");
    bailout("cant open pipe to $config{mta}: $!") if (!defined $pid);
    if ($pid)
    {
	$ent->print(\*TOMTA);
	close(TOMTA) || bailout("error talking to child $config{mta}: $?");
    }
    else
    {
	my @cmd=split(/\s+/,$config{mta});
	exec(@cmd,@args) || bailout("error execing $cmd[0]: $!");
    }
}

# remove temporary stuff left behind in directory $what
# remove_what set: remove the dir, too.
# exception on error, no retval
sub cleanup
{
    my ($what,$remove_what)=@_;
    my ($name,$res);

    opendir(F,$what) || bailout("cant opendir $what: $!");
    foreach $name (readdir(F))
    {
	next if ($name =~ /^\.{1,2}$/o); 
	(-d "$what/$name")?&cleanup("$what/$name",1):
	    (unlink("$what/$name") || bailout("cant unlink $what/$name: $!"));
    }
    closedir(F);
    $remove_what && (rmdir("$what") || bailout("cant rmdir $what: $!"));
    return 0;
}

# log termination, cleanup, exit
sub handle_term
{
    my ($sig)=@_;

    logit("got termination signal SIG$sig, cleaning up");
    my $res=&cleanup($config{tempdir},1);
    logit("problem cleaning up $config{tempdir}: $res")
	if ($res);

    # wipe keys
    if ($config{secretondemand})
    {
	foreach ($config{ngkey},$config{stdkey})
	{
	    next if (!$_);
	    my $cmd=sprintf($config{delsecret},$_);
	    my $res=0xffff & system $cmd;
	    &logit("problem deleting secret for $_: $res")
		if ($res);
	}
    }
    close $config{logfh} if ($config{logfh});
    exit 0;
}

# reread configuration file and keyrings
# no args or return value; intended as a sighandler.
sub handle_reload
{
    logit("rereading config file");
    &read_config;
    &read_keyrings;
}

# read keyrings into global hashes
# note: this must happen after the config is read, so that
# the right tools are used (gpg vs. pgp)
sub read_keyrings
{
    my ($lastkey,$lasttype,@tmp,$name,$now,@info);
    my %badcauses=('i'=>'invalid, no selfsig','d'=>'disabled',
		   'r'=>'revoked','e'=>'expired');
    %{$keys{std}}=();

    if ($config{usepgp})
    {
	if (!$config{stdkey})
	{
	    logit("ignoring std keyring, no key a/v.");
	}
	else
	{
	    logit("reading std keyring.");
	    $now=time;
	    
	    #get the keys and dump the trailer and header lines
	    # this does not care if pgp is not existent...but then, we're not
	    # needing the pgp keyring
	    @tmp=`$config{pgppath} -kv 2>$config{tempdir}/subproc`;
	    bailout("failure reading keyring with $config{pgppath}: $?",
		    "$config{tempdir}/subproc") if ($?);
	    foreach (@tmp)
	    {
		if (/^pub\s+\d+\/(\S+)\s+(.+)$/)
		{
		    my ($key,$userspec)=($1,$2);
		    
		    if ($userspec =~ /(\s|<)([^\s<]+\@[^\s>]+)>?/)
		    {
			$name=lc($2);
		    }
		    else
		    {
			undef $name;
		    }
		    
		    if ($name)
		    {
			$keys{std}->{$name}="0x$key";
			$lastkey=$key;
			&logit("got stdkey 0x$key for $name") if ($debug);
		    }
		    else
		    {
			$lastkey=$key;
			&logit("saved stdkey 0x$key, no address known yet")
			    if ($debug);
		    }
		    next;
		}
		if (/^\s+.*(\s|<)([^\s<]+\@[^\s>]+)>?\s*$/)
		{
		    my $name=lc($2);
		    $keys{std}->{$name}="0x$lastkey";
		    &logit("got stdkey (uid) 0x$lastkey for $name") if ($debug);
		}
	    }
	}
    }

    %{$keys{ng}}=();

    if ($config{ngkey} || !$config{usepgp} && $config{stdkey})
    {
	logit("reading ".(!$config{usepgp} && $config{stdkey}?"combined":"ng")." keyring.");

	# this does not care if gpg is not existent...but then, we're not
	# needing the gpg keyring
	@tmp=`$config{gpgpath} -q --batch --list-keys --with-colons --no-expensive-trust-checks 2>$config{tempdir}/subproc`;
	bailout("failure reading keyring with $config{gpgpath}: $?",
		"$config{tempdir}/subproc") if ($?);
	foreach (@tmp)
	{
	    @info=split(/:/);
	    # only public keys and uids are of interest
	    next if ($info[0] ne "pub" && $info[0] ne "uid");
	    
	    $info[4] =~ s/^.{8}//;	# truncate key-id
	    
	    # rsa-keys only if !$usepgp
	    # and be sure to skip these uid's, too
	    if ($config{usepgp} && $info[3] eq "1")
	    {
		&logit("ignoring stdkey 0x$info[4]") if ($debug && $info[4]);
		undef $lastkey;
		next;
	    }
	    elsif (!$config{ngkey} && $info[3] ne "1")
	    {
		&logit("ignoring ngkey 0x$info[4]") if ($debug && $info[4]);
		undef $lastkey;
		next;
	    }
	    
	    $info[9] =~ s/\\x3a/:/g; # re-insert colons, please
	    
	    # remember the email address
	    # if no address given: remember this key 
	    # but go on to the uid's to get an email address to
	    # work with
	    if ($info[9] =~ /(\s|<)([^\s<]+\@[^\s>]+)>?/)
	    {
		$name=lc($2);
	    }
	    else
	    {
		undef $name;
	    }
	    
	    # check the key: public part or uid?
	    if ($info[0] eq "pub")
	    {
		# lets associate this key with the current email address
		# if an address is known
		$lastkey=$info[4];
		$lasttype=$info[3]==1?"std":"ng";
		
		if ($name)
		{
		    # ignore expired, revoked and other bad keys
		    if (defined $badcauses{$info[1]})
		    {
			&logit("ignoring ".($info[3]==1?"std":"ng")
			       ." key 0x$info[4], reason: "
			       .$badcauses{$info[1]});
			next;
		    }
		    
		    $keys{$lasttype}->{$name}="0x$lastkey";
		    
		    &logit("got $lasttype key 0x$lastkey for $name")
			if ($debug);
		}
		else
		{
		    &logit("saved $lasttype key 0x$lastkey, no address known yet")
			if ($debug);
		}
		next;
	    }
	    else
	    {
		# uid: associate the current address with the key 
		# given in the most recent public key line
		# if no such key saved: the pub key was an rsa key &
		# we're set to ignore those
		if (!$lastkey)
		{
		    $name="<no valid address>" if (!$name);
		    &logit("ignoring uid $name, belongs to std key?")
			if ($debug);
		}
		else
		{
		    if ($name)
		    {
			# ignore expired, revoked and other bad keys
			if (defined $badcauses{$info[1]})
			{
			    &logit("ignoring ".($info[3]==1?"std":"ng")
				   ." uid $name for 0x$lastkey, "
				   ."reason: ".$badcauses{$info[1]});
			    next;
			}
			
			$keys{$lasttype}->{$name}="0x$lastkey";
			&logit("got $lasttype key (uid) 0x$lastkey for $name")
			    if ($debug);
		    }
		    else
		    {
			&logit("ignoring uid without valid address")
			    if ($debug);
		    }
		}
	    }
	}
    }
    else
    {
	logit("ignoring ng keyring, no key a/v.");
    }
}

# reads the configuration file, sets config variables
# exception on major problems
# no retval. changes %config and @overrides on success.
sub read_config
{
    my @over;

    # default settings
    my $defaction="none";
    my %newconf=(ngkey=>undef,
		 stdkey=>undef,
		 pgppath=>"/usr/bin/pgp",
		 gpgpath=>"/usr/bin/gpg",
		 usepgp=>0,
		 getsecret=>undef,
		 delsecret=>undef,
		 mta=>"/usr/lib/sendmail -om -oi -oem",
		 secretondemand=>0,
		 alwaystrust=>0,
		 interval=>60,
		 tempdir=>($ENV{'TMPDIR'}?$ENV{'TMPDIR'}:"/tmp")."/kuvert.$username.$$",
		 queuedir=>"$home/.kuvert_queue",
		 logfile=>undef,
		 logfh=>undef,
		 identify=>0);
    
    &bailout("cant open $rcfile: $! -- exiting")
	if (!open (F,$rcfile));
    logit("reading config file");
    while (<F>)
    {
	chomp;
	next if (/^\#/ || /^\s*$/); # strip comments and empty lines

	if (/^(\S+)\s+((none|std(sign)?|ng(sign)?|fallback)(-force)?)\s*$/)
	{
	    my ($key,$action)=(lc($1),lc($2));
	    if ($key eq "default")
	    {
		$defaction=$action;
		$debug && logit("changing default action to $action");
	    }
	    else
	    {
		push @over,{"key"=>$key,
			    "re"=>qr/$key/,
			    "action"=>$action};
		$debug && logit("got conf $action for $key");
	    }
	}
	elsif (/^([[:upper:]]+)\s+(\S.*)\s*$/)
	{
	    my ($key,$value)=(lc($1),$2);

	    if (grep($_ eq $key, keys %newconf))
	    {
		$newconf{$key}=$value;
		$debug && logit("set config $key to $value");
	    }
	    else
	    {
		&bailout("bad config entry \"$_\" -- exiting");
	    }
	}
	else
	{
	    &bailout("bad config entry \"$_\" -- exiting");
	}
    }
    close F;

    # last per-address override is the catch-all default
    push @over,{"key"=>"default",
		"re"=>qr/.*/,
		"action"=>"$defaction"};

    # generate queuedir if not existing
    if (!-d $newconf{queuedir})
    {
	unlink "$newconf{queuedir}";
	&bailout("cant mkdir $newconf{queuedir}: $! -- exiting")
	    if (!mkdir($newconf{queuedir},0700));
    }
    # check queuedir owner & perm
    elsif ((stat($newconf{queuedir}))[4] != $<)
    {
	&bailout("$newconf{queuedir} is not owned by you  -- exiting");
    }
    elsif ((stat($newconf{queuedir}))[2] & 0777 != 0700)
    {
	&bailout("$newconf{queuedir} does not have mode 0700 -- exiting");
    }
    
    # make tempdir
    if (!-d $newconf{tempdir})
    {
	unlink "$newconf{tempdir}";
	if (!mkdir($newconf{tempdir},0700))
	{
	    &bailout("cant mkdir $newconf{tempdir}: $! -- exiting");
	}
    }
    elsif ((stat($newconf{tempdir}))[4] != $<)
    {
	&bailout("$newconf{tempdir} is not owned by you -- exiting");
    }
    elsif ((stat($newconf{tempdir}))[2]&0777 != 0700)
    {
	&bailout("$newconf{tempdir} does not have mode 0700 -- exiting");
    }

    # close old logfile if there is one
    close($config{logfile})
	if ($config{logfile} && $config{logfile} ne $newconf{logfile});
    
    if ($newconf{logfile})
    {
	&bailout("cant open logfile $newconf{logfile}: $! -- exiting")
	    if (!open($newconf{logfh},">>$newconf{logfile}"));
	$newconf{logfh}->autoflush(1);
    }

    # secret on demand is only possible with both a get and a del command
    $newconf{secretondemand}=0 
	if (!$newconf{getsecret} || !$newconf{delsecret});

    # sanity checks: external executables
    &bailout("bad executable '$newconf{mta}' -- exiting")
	if ($newconf{mta}=~/^(\S+)/ && ! -x $1);
    if ($newconf{secretondemand})
    {
	&bailout("bad executable '$newconf{getsecret}' -- exiting")
	    if ($newconf{getsecret} 
		&& $newconf{getsecret}=~/^(\S+)/ && ! -x $1);
	&bailout("bad executable '$newconf{delsecret}' -- exiting")
	    if ($newconf{delsecret} 
		&& $newconf{delsecret}=~/^(\S+)/ && ! -x $1);
    }
    &bailout("bad executable '$newconf{pgppath}' -- exiting")
	if ($newconf{usepgp} && $newconf{stdkey} ne "0" 
	    && (!$newconf{pgppath} || $newconf{pgppath}=~/^(\S+)/ && ! -x $1));
    &bailout("bad executable '$newconf{gpgpath}' -- exiting")
	if ($newconf{ngkey} ne "0" 
	    && ( !$newconf{gpgpath} || $newconf{gpgpath}=~/^(\S+)/ && ! -x $1));
    # figure out the default keys if none were supplied, check them
    if ($newconf{ngkey})
    {
	my $res=0xffff & system("$newconf{gpgpath} -q --batch --list-secret-keys --with-colons $newconf{ngkey} >$newconf{tempdir}/subproc 2>&1");
	bailout("bad ngkey spec '$newconf{ngkey}' -- exiting","$newconf{tempdir}/subproc") if ($res);
    }
    elsif (!defined $newconf{ngkey})
    {
	open(F,"$newconf{gpgpath} -q --batch --list-secret-keys --with-colons 2>$newconf{tempdir}/subproc |") || bailout("cant fork $newconf{gpgpath} to list sec keys: $! -- exiting");
	while (<F>)
	{
	    my @list=split(/:/);
	    next if ($list[0] ne "sec" || $list[3] ne "17");
	    $list[4] =~ s/^.{8}//;	# truncate key-id
	    $newconf{ngkey}="0x$list[4]";
	    $debug && logit("set ngkey to $newconf{ngkey}");
	    last;
	}
	close F;
	bailout("error running $newconf{gpgpath}: $? -- exiting","$newconf{tempdir}/subproc") if ($?);
	bailout("could not find ngkey -- exiting") if (!$newconf{ngkey});
    }

    if ($newconf{stdkey})
    {
	if ($newconf{usepgp})
	{
	    my $res=0xffff & system("$newconf{pgppath} -kv $newconf{stdkey} $home/.pgp/secring.pgp >$newconf{tempdir}/subproc 2>&1");
	bailout("bad stdkey spec \"$newconf{stdkey}\" -- exiting","$newconf{tempdir}/subproc") if ($res);
	}
	else
	{
	    my $res=0xffff & system("$newconf{gpgpath} -q --batch --list-secret-keys --with-colons $newconf{stdkey} >$newconf{tempdir}/subproc 2>&1");
	    bailout("bad stdkey spec \"$newconf{stdkey}\" -- exiting","$newconf{tempdir}/subproc")
		if ($res);
	}
    }
    elsif (!defined $newconf{stdkey})
    {
	if ($newconf{usepgp})
	{
	    open(F,"$newconf{pgppath} -kv $home/.pgp/secring.pgp 2>$newconf{tempdir}/subproc |") 
		|| bailout("cant fork $newconf{pgppath} to list sec keys: $! -- exiting");
	    while (<F>)
	    {
		if (/^sec\s+\d+\/(\S+)\s+/)
		{
		    $newconf{stdkey}="0x$1";
		    $debug && logit("set stdkey to $newconf{stdkey}");
		    last;
		}
	    }
	    close F;
	    bailout("error running $newconf{pgppath}: $? -- exiting","$newconf{tempdir}/subproc")
		if ($?);
	}
	else
	{
	    open(F,"$newconf{gpgpath} -q --batch --list-secret-keys --with-colons 2>$newconf{tempdir}/subproc|")
		|| bailout("cant run $newconf{gpgpath} to list sec keys: $! -- exiting","$newconf{tempdir}/subproc");
	    while (<F>)
	    {
		my @list=split(/:/);
		next if ($list[0] ne "sec" || $list[3] ne "1");
		$list[4] =~ s/^.{8}//;	# truncate key-id
		$newconf{stdkey}="0x$list[4]";
		$debug && logit("set stdkey to $newconf{stdkey}");
		last;
	    }
	    close F;
	    bailout("error running $newconf{gpgpath}: $? -- exiting","$newconf{tempdir}/subproc")
		if ($?);
	}
	bailout("could not find stdkey -- exiting") if (!$newconf{stdkey});
    } 

    # finally make sure that no action conflicts with the keys we may lack
    bailout("no keys whatsoever a/v! -- exiting") if (!$newconf{stdkey} && !$newconf{ngkey});

    bailout("config specifies ng but no ng key a/v -- exiting")
	if (!$newconf{ngkey} && grep($_->{action} =~ /^ng/, @over));
    bailout("config specifies std but no std key a/v -- exiting")
	if (!$newconf{stdkey} && grep($_->{action} =~ /^std/, @over));

	
    # everything seems ok, overwrite global vars config and override 
    %config=%newconf;
    @overrides=@over;
    return;
}

# traverses the entity and sets all parts with
# type == text/plain, charset != us-ascii, transfer-encoding 8bit
# to transfer-encoding qp.
# input: entity, retval: none
sub qp_fix_parts
{
    my ($entity)=@_;

    if ($entity->is_multipart)
    {
	foreach ($entity->parts)
	{
	    &qp_fix_parts($_);
	}
    }
    else
    {
	if ($entity->head->mime_type eq "text/plain"
	    && $entity->head->mime_encoding eq "8bit"
	    && lc($entity->head->mime_attr("content-type.charset"))
	    ne "us-ascii")
	{
	    bailout("changing Content-Transfer-Encoding failed")
		if ($entity->head->mime_attr("content-transfer-encoding"
					     => "quoted-printable")!="quoted-printable");
	}
    }
}

# notifies the sender of a problem, via email
# retrieves the detailed error message from @detailederror
# no return value, exception on problems
sub send_bounce
{
    my ($res,$file)=@_;

    open(F,"|$config{mta} $username") || 
	bailout("cant fork $config{mta}: $! -- exiting");
    print F "From: $username\nTo: $username\nSubject: $progname Mail Sending Failure\n\n"
	."Your mail $config{queuedir}/$file could not be sent to some or all recipients.\n\n"
	."The error message was:\n\n$res\n\n\n";
    print F "Detailed error message:\n\n"
	.join("",@detailederror)."\n\n\n" if (@detailederror);
    print F "$progname has no reliable way of figuring out whether this failure did affect\n"
	."all recipients of your mail, so please look into the log for further error indications.\n\n"
	."$progname has backed the failed mail up as $config{queuedir}/.$file;\n"
	."If you wish to retry again for all original recipients, just rename the file back to\n"
	."$config{queuedir}/$file or otherwise remove the backup file.\n";
    close F;
    bailout("error running $config{mta}: $? -- exiting") if ($?);
}

 
# get, verify and store a secret
# input: what kind of secret
# retval: none, changes %secrets, exception on major errors 
# note: only used when secretondemand is unset.
sub get_secret
{
    my ($type)=@_;
    my $id=$config{($type eq "std"?"stdkey":"ngkey")};
    my $res;
   
    do 
    {
	# do-it-yourself
	
	# the previous attempt failed...
	print "wrong passphrase, try again.\n"
	    if ($res);
	
	print "enter secret for key $id:\n";
	ReadMode("noecho");
	chomp (my $phrase=<STDIN>);
	ReadMode("restore");
	bailout("error reading $type passphrase: $!")
	    if (!defined($phrase));
	print "\n";
	$secrets{$id}=$phrase;
	$phrase="x" x 64; 
	$res=sign_encrypt(0,$type,undef,undef);
    }
    while ($res);
}

# sign/encrypt a file, or test the passphrase if infile and outfile are undef.
# input: encrypt, type std/ng, infile and outfile path, recipient keys if encrypt.
# returns: 0 if ok, 1 if bad passphrase,  exception on other errors
sub sign_encrypt
{
    my ($enc,$type,$infile,$outfile,@recips)=@_;
    my ($passphrase,$passphrase_cmd,$cmd);
        
    # passphrase issues
    if ($config{secretondemand})
    {
	$cmd="|".sprintf($config{getsecret},
			 ($type eq "std"?$config{stdkey}:$config{ngkey}));
    }
    else
    {
	$passphrase=$secrets{$config{($type eq "std"?"stdkey":"ngkey")}};
    }

    # how to arrange the command
    if (!$enc)
    {
	if ($type eq "std" && $config{usepgp})
	{
	    $cmd.="|PGPPASSFD=0 $config{pgppath} +batchmode -u $config{stdkey} -sbat";
	}
	else
	{
	    $cmd.="|$config{gpgpath} -q -t --batch --armor --detach-sign --passphrase-fd 0 --status-fd 1 --default-key";
	    if ($type eq "std")
	    {
		$cmd.=" $config{stdkey} --rfc1991 --cipher-algo idea --digest-algo md5 --compress-algo 1";
	    }
	    else
	    { 
		$cmd.=" $config{ngkey}";
	    }
	}
	
	# only check the passphrase: pgp needs -f(ilter) flag then
	if (!$infile && !$outfile)
	{
	    $cmd.=" -f" if ($type eq "std" && $config{usepgp});
	}
	else
	{
	    $cmd.=" -o $outfile $infile";
	}
    }
    else			# encrypt and sign
    {
	if ($type eq "std" && $config{usepgp})
	{
	    $cmd.="|PGPPASSFD=0 $config{pgppath} +batchmode "
		."-u $config{stdkey} -seat -o $outfile $infile "
		.join(" ",@recips);
	}
	else
	{
	    # gpg: normal mode...
	    if ($type ne "std")
	    {
		$cmd.="|$config{gpgpath} -q -t --batch --armor --passphrase-fd 0 "
		    ."--status-fd 1 --default-key $config{ngkey} -r "
		    .join(" -r ",@recips)
		    .($config{alwaystrust}?" --always-trust":"")
		    ." --encrypt --sign -o $outfile $infile";
	    }
	    else
	    {
		# or compatibility-mode, bah
		
		# very elaborate but working procedure, found by
		# Gero Treuner <gero@faveve.uni-stuttgart.de>
		# http://muppet.faveve.uni-stuttgart.de/~gero/gpg-2comp

		# first, generate the signature and store it
		$cmd.="|$config{gpgpath} --batch -q --detach-sign "
		    ."--default-key $config{stdkey} "
		    ."--passphrase-fd 0 --status-fd 1 -o $outfile $infile";
		# the rest is done later on
	    }
	}
    }

    $cmd.=" >$config{tempdir}/subproc 2>&1";

    unlink($outfile) if (-e $outfile);

    open(F,$cmd) || bailout("cannot open pipe $cmd: $!");
    print F "$passphrase\n" if ($passphrase);
    $passphrase="x" x 64;
    close F;

    # compatibility mode? there's more to do, unfortunately
    return 0
	if (!$? && !($enc && $type eq "std" && !$config{usepgp})) ;
    
    if ($?)
    {
	# hmm, things went wrong: try to figure out what happened.
	# if it's just the passphrase, return 1.
	# if it's something else, bailout...won't get better with retries.
	
	# pgp's way of saying "bad passphrase".
	return 1 if ($type eq "std" && $config{usepgp} && ($?>>8) eq 20);
	
	# with gpg we'll have to look at the output
	if ($type eq "ng" || !$config{usepgp})
	{
	    open F,"$config{tempdir}/subproc";
	    my @result=<F>;
	    close F;
	
	    return 1 if (grep(/^\[GNUPG:\] BAD_PASSPHRASE/,@result));
	}
    
	bailout("error running sign prog: $?","$config{tempdir}/subproc") if ($? == 0xff00);
	bailout("sign prog died from signal " . ($? & 0x7f),"$config{tempdir}/subproc") if ($? <= 0x80);
	bailout(("sign prog returned error ".($?>>8)),"$config{tempdir}/subproc") if ($?>>8);
    }

    # ok, must be in compat mode...let's complete the nasty construction
    
    # next, convert the cleartext to the internal literal structure
    unlink("$outfile.inter1") if (-e "$outfile.inter1");
    my $res=0xffff
	    & system("$config{gpgpath} --batch -q --store --batch -z 0 -o $outfile.inter1 "
		     ."$infile >$config{tempdir}/subproc 2>&1");
    bailout("error running gpg","$config{tempdir}/subproc") if ($res);
    
    # now compress signature and literal in the required order
    open(F,"$outfile") || bailout("cant open $outfile: $!");
    open(G,"$outfile.inter1") || bailout("cant open $outfile.inter1: $!");
    
    unlink("$outfile.inter2") if (-e "$outfile.inter2");;
    open(H,"|$config{gpgpath} --no-literal --store --batch  --compress-algo 1 "
	 ."-o $outfile.inter2 >$config{tempdir}/subproc 2>&1")
	|| bailout("cant open pipe to $config{gpgpath}: $!");
    print H <F>;
    print H <G>;
    close F;
    close G;
    close H;
    bailout("error running $config{gpgpath}: $?","$config{tempdir}/subproc") if ($?);
	    
    # and finally encrypt all this for the wanted recipients.
    unlink($outfile);
    $cmd="$config{gpgpath} --no-literal --batch --encrypt --rfc1991 --cipher-algo idea "
	.($config{alwaystrust}?"--always-trust ":"")
	."--armor -o $outfile -r "
	.join(" -r ",@recips)
	." $outfile.inter2 >$config{tempdir}/subproc 2>&1";

    $res=0xffff & system($cmd);
    bailout("error running $config{gpgpath}: $res","$config{tempdir}/subproc") if ($res);
    return 0;
}

# find the correct action for a given email address
# input: addresses and custom-header, bcc-addresses
# result: hash with address as key and action as value
# the fallback and -force options are expanded into atoms, ie.
# resulting actions are: ng, ngsign, std, stdsign, none,
# or bcc-{ng,std}.
# note: ng and std means encryption here, no check for keys necessary anymore
sub findaction    
{
    my ($custom,$allref,$bccref)=@_;
    my(@affected,%actions,$addr);

    # lookup addresses in configured overrides
    foreach $addr (@{$allref},@{$bccref})
    {
	foreach (@overrides)
	{
	    if ($addr =~ $_->{re})
	    {
		$actions{$addr}=$_->{action};
		$debug && logit("found directive: $addr -> $actions{$addr}");
		last;
	    }
	}
	# custom set? then override the config except where action=none
	if ($custom && $actions{$addr} ne "none")
	{
	    $debug && logit("custom conf header: overrides $addr -> $custom");
	    $actions{$addr}=$custom;
	    next;
	}
	&bailout("internal error, no action found for $addr") if (!exists $actions{$addr});
    }

    # no -force options for bcc
    foreach $addr (@{$bccref})
    {
	$actions{$addr}=~s/^(\S+)-force$/$1/;
    }

    # check the found actions: anyone with -force options?
    # note: normal addresses only, bcc don't count here
    foreach $addr (@{$allref})
    {
	next if ($actions{$addr} !~ /^(\S+)-force$/);
	my $force=$1;
	$debug && logit("found force directive: $addr -> $actions{$addr}");

	# yuck, must find affected addresses: those with action=none
	# have to be disregarded and unchanged.
	
	@affected = grep($actions{$_} ne "none",@{$allref});

	# (almost) unconditionally apply the simple force options:
	# none,ngsign,stdsign; others need more logic
	if ($force eq "std")
	{
	    # downgrade to sign if not all keys a/v
	    $force="stdsign" if (grep(!exists $keys{std}->{$_}, @affected));
	}
	elsif ($force eq "ng")
	{
	    $force="ngsign" if (grep(!exists $keys{ng}->{$_}, @affected));
	}
	elsif ($force eq "fallback")
	{
	    # fallback-logic: ng-crypt or std-crypt, otherwise ngsign or stdsign
	    # -force: ng- or std-crypt for all, otherwise ngsign or stdsign
	    $force="ngsign" 	
		if (grep(!exists $keys{ng}->{$_} 
			 && !exists $keys{std}->{$_}, @affected));
	}

	# apply forced action to the affected addresses
	map { $actions{$_}=$force; } (@affected);	 
	$debug && logit("final force directive: $force");
	# the first force-option wins, naturally.
	last;
    }

    # check the actions for fallback, ng or std and expand that
    # also bail out if no suitable keys available!
    foreach $addr (@{$allref},@{$bccref})
    {
	if ($actions{$addr} eq "fallback")
	{
	    ($config{ngkey} && $keys{ng}->{$addr} && ($actions{$addr}="ng")) 
		|| ($config{stdkey} && $keys{std}->{$addr} && ($actions{$addr}="std"))
		|| ($config{ngkey} && ($actions{$addr}="ngsign"))
		|| ($config{stdkey} && ($actions{$addr}="stdsign"))
		|| &bailout("oooops. no keys available for fallback action for $addr");
	}
	elsif ($actions{$addr} =~ /^ng(sign)?$/)
	{
	    bailout("no ng key available but ng action required for $addr") 
		if (!$config{ngkey});
	    $actions{$addr}="ngsign" if ($actions{$addr} eq "ng" && !$keys{ng}->{$addr});
	} 
	elsif ($actions{$addr} =~ /^std(sign)?$/)
	{
	    bailout("no std key available but std action required for $addr") 
		if (!$config{stdkey});
	    $actions{$addr}="stdsign" if ($actions{$addr} eq "std" && !$keys{std}->{$addr});

	} 
	$debug && logit("final action: $addr -> $actions{$addr}");
    }

    # tag ng and std actions for bcc recipients:
    # those must be handled separately (separate encryption step...)
    foreach $addr (@{$bccref})
    {
	$actions{$addr}=~s/^(ng|std)$/bcc-$1/;
    }
    return %actions;
}

# logging and dying with a message
# does not return
# if barfmail is set, then a mail with the log information is sent (message and detailfn-content)
# args: the message to spit out, path to a file with details.
# the details from the file are logged only, not printed in the die-message
sub bailout
{
    my ($msg,$detailfn)=@_;

    if ($detailfn && open(DF,$detailfn))
    {
	push @detailederror,<DF>;
	close DF;
    }

    if ($barfmail)
    {
	# i'd like to call bailout without looping.
	my $oldbarfmail=$barfmail;
	$barfmail=0;	
	my $mta=$config{mta}||"/usr/lib/sendmail"; # this could run before the config is read
	open (F,"|$mta $username") || 
	    bailout("cant fork $mta: $!");
	print F "From: $username\nTo: $username\nSubject: $progname General Failure\n\n"
	    ."$progname has encountered a serious/fatal failure.\n\n"
	    ."The error message was:\n\n$msg\n\n\n";
	print F "Detailed error message:\n\n"
	    .join("",@detailederror)."\n\n\n" if (@detailederror);
	close F;
	bailout("error running $mta: $?") if ($?);
	$barfmail=$oldbarfmail;
    }
    
    logit($msg,$detailfn);
    die($msg."\n");
}


# log the msg(s) to syslog or the logfile
# the detailed info is put into @detailederror
# args: message, path to file with details
# no retval.
sub logit
{
    my ($msg,$detailfn)=@_;

    if ($detailfn)
    {
	@detailederror=();
	if (open(DF,$detailfn))
	{
	    push @detailederror,<DF>;
	    close DF;
	}
    }

    if ($config{logfh})
    {
	# logfile is opened with autoflush set to 1, 
	# so no extra flushing needed
	# we're more or less emulating the syslog format here...
	print { $config{logfh} } scalar(localtime)." $progname\[$$\] $msg\n";
    }
    else
    {
	setlogsock('unix');
	openlog($progname,"pid,cons","mail");
	syslog("notice",$msg);
	closelog;
    }
}

    
&main;