#!/usr/bin/perl

my $RCS = '$Id: hashcash-sendmail,v 1.18 2004/08/07 18:36:16 kyle Exp $';

#
# hashcash-sendmail -- queues messages for later delivery after adding hashcash
# This is meant to be a program called AS sendmail from a MUA.
#
# An up-to-date version is normally here:
# http://www.toehold.com/~kyle/hashcash/
#

# Consider this ALPHA software.  It works for me, but it has not been through
# much real testing.

#
# Copyright (C) 2004  Kyle Hasselbacher <kyle@toehold.com>
#
# 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 (at your
# option) 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.,
# 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
#

#
# This script is supposed to be a stand-in for sendmail.  It records the
# arguments its given and the standard input it receives, and those are
# eventually passed on to sendmail.  Typically the arguments are passed
# faithfully to sendmail, but we meddle with them if there's a Bcc.  The
# message is always modified by adding X-Hashcash to the end of the headers.
#

use strict;
use Data::Dumper;
use File::Copy;
use Fcntl qw(:DEFAULT :flock);
use POSIX qw( setsid );
use IO::File;
use vars qw( @rcpt @args );
use IPC::Open3;

my $home = $ENV{'HOME'} || $ENV{'LOGDIR'} || (getpwid($<))[7];

#
# The workdir is expected to have a queue directory and a tmp directory.
# hashcash-sendmail looks for bitconf there later.
# All messages that I haven't seen yet are in queue/*.msg files, and they
# each have a corresponding *.dat file with instructions.  The .msg file
# is exactly the standard input for sendmail.  The *.dat file is a Perl
# parsable file which contains two arrays.  One is the exact argument list
# for sendmail.  The other is instructions for what hashcash to add to the
# message.  The .dat files never move from the queue, but the .msg files
# move to tmp/ when they're being worked on.
#
my $workdir = "$home/.hashcash";

END {
    cleanup();
}

# When I get a signal, cleanup() is called twice.  I use this flag to avoid
# doing anything the second time.  It also serves to keep from doing cleanup
# if I die before even entering the queue.
my $need_cleanup = 0;

# Where to write log messages.
my $logfile = "$workdir/hashcash-log";

# Where to find the recipients file. See read_bitconf() comments for format.
my $conffile = "$workdir/bitconf";

# Create my directories if they're not there already.
foreach my $dir ( $workdir, "$workdir/queue", "$workdir/tmp" ) {
    if ( ! -d $dir && ! mkdir( $dir ) ) {
	die "Can't make nonexistant workdir '$dir': $!\n";
    }
}

my @bitconf = read_bitconf();

# This is the number of bits we use if nothing else is specified.
my $bits_to_compute = 20;

# Part of the filename used for output.
my $filebase = time() . ".$$";

my $extra_expense = 0; # Whether this message is extra expensive (low priority)
my $confirmed = 0;     # Whether this is a confirmed message (needing no cash)

# This is used for the Received: line I add to messages, and it gets logged
# by the daemon when it starts.
my $hostname = `hostname -f 2> /dev/null`;
$hostname =~ s/\s//g;

# If there are no args, read a request and queue that.
# hashcash-request just opens a pipe to hashcash-sendmail and ships
# in a Data::Dumper file.

if ( ! @ARGV ) {
    my $rcptcode = join( '', <STDIN> );
    eval $rcptcode;
    if ( $@ ) {
	fatal( "input request does not parse: $@\n" );
    }
    queue( $filebase, undef, \@rcpt, \@bitconf );
}
else {
    my @args = @ARGV;

# This will be all the sendmail arguments BEFORE the list of envelope
# recipients (so that we can meddle with them later).
    my @pre_args = ();

# Try to figure out our envelope recipients.
# This is probably NOT close enough to sendmail compatibility for prime time.
    my @env_recip = ();

    process_args( \@args, \@pre_args, \@env_recip );

    my @to = ();           # According-to-headers message recipients.

    my $msgfh = new IO::File;
    if ( ! open( $msgfh, ">$workdir/tmp/$filebase.msg" ) ) {
	die "Can't write $workdir/tmp/$filebase.msg: $!\n";
    }
    else {
	process_msg( $msgfh, \@to );
	close( $msgfh );
    }

    queue_messages( \@args, \@env_recip, \@to, \@pre_args );

# Done with the temp file.
    unlink( "$workdir/tmp/$filebase.msg" ) || die "Can't unlink '$workdir/tmp/$filebase.msg': $!\n";
}

####
#### DAEMON STARTS HERE
####

#
# At this point, the incoming message/request has been queued.  We're about
# to fork away from the caller to work on processing the queue in the
# background.  If there's already an earlier daemon doing this, we just
# send it a wake-up call and die.
#

# For now, at least, the daemon code and the sendmail code are distinct.
# They haven't needed to call the other's functions.  That having been
# said, I haven't really marked which functions are which.  If you're
# doing some work in here, make sure that the daemon calls fatal() and
# complain() rather than 'die' and 'warn'.  There's nothing stopping
# sendmail from using those (and logline), but it hasn't yet.

use sigtrap qw( handler cleanup normal-signals );

#
# Ignore the USR1 signal for now.  We toggle this on and off.  When waiting
# for a token to finish, we set a handler that will process the interrupt
# (by rescanning the queue for a better job to do).  When working (not
# waiting), we ignore the hangup.
#
$SIG{ USR1 } = 'IGNORE';

# Separate myself from the shell.
# It's important to do this before doing the pidfile stuff
# because daemonize() forks, and we want to get the right PID in the pidfile.
daemonize();

# $pidfile is where we store the daemon's process ID.
my $pidfile = "$workdir/daemon.pid";
handle_pidfile( $pidfile );

# Check for leftover queue items.
recover_dead_queue();

if ( $hostname =~ /\S/ ) {
    logline( "daemon started on $hostname; computing $bits_to_compute bits" );
}
else {
    logline( "daemon started; computing $bits_to_compute bits" );
}
logline( $RCS );

#
# This is our stack of tasks.  Whatever we're working on right now is always
# at the end of this list.  When we see something more important, we SIGSTOP
# the process and start a new one, adding the new task to the stack.
# Each element of the stack is a reference to a hash of stuff we need to
# retain.  Its elements are:
#
# 'msg'          -- the name of the file that has the message
# 'dat'          -- the name of the job's .dat file
# 'sendmailfh'   -- where I write the message
# 'sendmailpid'  -- the sendmail PID
# 'msgfh'        -- whence I read the message
# 'hashcashfh'   -- whence I read a token
# 'hashcashpid'  -- what to signal with STOP and CONT
# 'blankline'    -- the line between the headers and the body
# 'cashinfo'     -- a string describing the hashcash we're making
#                   It looks like 12:3456:x@example.com where the fields
#                   are bits:expiry:resource
#
my @stack = ();

# At this point we'll need to do a cleanup if we die.
$need_cleanup = 1;

# How many seconds to sleep when waiting.
my $sleep_time = 60 * 60;

# If this is true, we'll just process what's in the queue and then go away.
# The daemon won't wait around polling for something else to show up.
my $run_queue_and_die = 1;

while ( 1 ) {
    # This looks for messages in the queue that we haven't processed yet.
    opendir( QUEUE, "$workdir/queue" ) || fatal( "Can't opendir queue: $!\n" );
    my @messages = sort prioritize grep( /\.(msg|req)$/, readdir( QUEUE ) );
    closedir( QUEUE );

    # Nothing to do.  Look again in a while, or after an interrupt.
    if ( ! @messages && ! @stack ) {
	if ( $run_queue_and_die ) {
	    logline( "queue is empty; exiting." );
	    exit 0;
	}
	$SIG{ USR1 } = sub { logline( "awoke on $_[0]" ); die; };
	eval {
	    sleep( $sleep_time );
	};
	$SIG{ USR1 } = 'IGNORE';
	next;
    }

    if ( @messages ) {
	# This is the most important message that's not being worked on.
	my $msg = $messages[ 0 ];

	if ( ! @stack ) {
	    # If there's nothing on the stack, we don't have to worry about
	    # priorities or stopping any current process.  Just go to work.
	    begin_delivery( $msg, \@stack );
	}
	else {
	    my $topstate = $stack[ -1 ];

	    # First we check if the new message we found is more important
	    # than what we're working on right now.
	    my @check = ( $msg, $$topstate{ 'msg' } );
	    @check = sort prioritize @check;

	    if ( $check[ 0 ] eq $msg ) {
		# The new best message is better than the previous.
		# Stop the current job and push a new one on the stack.
		interrupt_with( $msg, \@stack );
	    }
	}
    }

    # The only way the stack is empty at this point is if we had nothing
    # to work on and found a message with no recipients.  In that case,
    # it's already been delivered.
    if ( @stack ) {
	my $topstate = $stack[ -1 ];

	# I'm doing this here because there's probably time.  We're waiting
	# on some token to mint.  I'd do this when I'm about to exit, but I
	# don't want to fool some baby daemon into thinking that I'm on the
	# job when I'm not.
	expire_premade();

	# We're going to wait for a short time for the hascash process
	# to be ready to read (i.e., it gave us our token).  Once it
	# does, we continue delivery.  If it turns out delivery is
	# finished, we pop the task off the stack and try to continue
	# anything that's left.
	my $rin = fhbits( $$topstate{ 'hashcashfh' } );
	my $finished_token = 0; # If this stays zero, no token was finished.

	$SIG{ USR1 } = sub { logline( "awoke on $_[0]" ); die; };
	eval {
	    $finished_token = select( $rin, undef, undef, $sleep_time );
	};
	$SIG{ USR1 } = 'IGNORE';

	if ( $finished_token && ! continue_delivery( $topstate ) ) {
	    # Delivery finished.  Throw away the state
	    pop( @stack );

	    while ( @stack ) {
		$topstate = $stack[ -1 ];
		my $restart = $$topstate{ 'hashcashpid' };
		logline( "continuing $$topstate{ 'msg' }" );

		last if kill( 'CONT', $restart );

		logline( "failed to restart $$topstate{ 'msg' } (pid $restart)" );
		pop( @stack );
	    }
	}
    }
}

####
#### SUBROUTINES START HERE
####

#
# This converts a resource name to something that's appropriate to a filename.
# It's basically URL encoding with '-' instead of '%'.  You can decode what
# the original resource was, but we never actually need to do that.  This is
# just so I can find files that contain tokens for the resource I want.
#
sub res2file {
    my ( $resource ) = @_;

    my $filename = $resource;

    $filename =~ s/(\W)/uc sprintf( "-%02x", ord( $1 ) )/eg;

    return $filename;
}

#
# We know the addresses for the envelope (@env_recip),
# and the addresses listed in the headers (@to).
# For which do we compute hashcash?  (@hash_to)
#
# This figures out what messages to queue and does the queueing.  Though
# only one message was given, we may queue several, depending on Bccs.
#
sub queue_messages {
    my ( $args, $env_recip, $to, $pre_args ) = @_;

    my @hash_to = ();
    if ( scalar @$env_recip == 1 ) {
	# There's only one envelope recipient.  That's who gets hashcash!
	@hash_to = @$env_recip;
    }
    else {
	# This looks for the intersection of envelope recipients and header
	# recipients.  An envelope recipient who's not listed in headers is
	# a Bcc, and we don't want to leak that otherwise private info.
	# A recipient in the headers who's not on the envelope isn't really
	# getting the message, so there's no point wasting our time.
	my %envelope_map = ();
	foreach my $arg ( @$env_recip ) {
	    $arg =~ tr/A-Z/a-z/;
	    $envelope_map{ $arg }++;
	}
	foreach my $addr ( @$to ) {
	    my $flat = $addr;
	    $flat =~ tr/A-Z/a-z/;
	    if ( $envelope_map{ $flat } ) {
		delete( $envelope_map{ $flat } );
		push( @hash_to, $addr );
	    }
	}
	# Anything left here is a Bcc.
	# We need to strip them out of the arguments list that we're about to
	# write, and we need to queue separate messages for each of them.
	# This is the only case where we change the argument list from what we
	# got to something else.
	if ( %envelope_map ) {
	    foreach my $bcc ( keys %envelope_map ) {
		my $shortarg = [ @$pre_args, $bcc ];
		queue( $filebase, $shortarg, [ msgrcpt( [ $bcc ] ) ], \@bitconf );
	    }
	    @$args = ( @$pre_args, @hash_to );
	}
    }

# This queues the "main" message.
# It's possible to send a message of all Bcc and no header recipients,
# in which case, everything's been queued already.
    if ( @hash_to ) {
	queue( $filebase, $args, [ msgrcpt( \@hash_to ) ], \@bitconf );
    }
}

# Try to figure out my time zone.
sub time_zone {
    my @lt = localtime();
    my @gt = gmtime();

    my $tz = $lt[ 2 ] - $gt[ 2 ];

    if ( $gt[ 7 ] > $lt[ 7 ] || $gt[ 5 ] > $lt[ 5 ] ) {
	$tz -= 24;
    }
    if ( $gt[ 7 ] < $lt[ 7 ] || $gt[ 5 ] < $lt[ 5 ] ) {
	$tz += 24;
    }

    $tz .= "00";
    $tz =~ s/^(-)?(\d)00$/${1}0${2}00/;
    $tz =~ s/^(\d)/+$1/;

    return $tz;
}

# RFC2821, section 4.4
sub add_trace_line {
    my ( $msgfh ) = @_;

    my $progname = $0;
    $progname =~ s:^.*/([^/]+)$:$1:;

    print $msgfh "Received: ";
    print $msgfh "by $hostname " if ( $hostname =~ /\S/ );
    print $msgfh "($progname, from uid $>);\n";

    # Format this produces:
    # Wed, 25 Feb 2004 16:37:30 -0600

    print $msgfh "\t";
    my @lt = localtime;
    my @days = qw( Sun Mon Tue Wed Thu Fri Sat );
    print $msgfh $days[ $lt[ 6 ] ] . ", ";
    print $msgfh $lt[ 3 ];
    print $msgfh " ";
    my @months = qw( Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec );
    print $msgfh $months[ $lt[ 4 ] ];
    print $msgfh " ";
    print $msgfh $lt[ 5 ] + 1900;
    print $msgfh " ";
    foreach my $n ( @lt[ 0, 1, 2 ] ) {
	$n = "0$n" while ( length( $n ) < 2 );
    }
    print $msgfh join( ':', @lt[ 2, 1, 0 ] );
    print $msgfh " ";
    print $msgfh time_zone();

    print $msgfh "\n";
}

#
# This copies the incoming message to the filehandle given and in
# the process picks out what addresses are referenced as recipients in
# the headers of the message.
#
sub process_msg {
    my ( $msgfh, $toref ) = @_;

    add_trace_line( $msgfh );

    my $in_headers = 1;    # Whether we're still in the headers of the message.
    my $in_to = 0;         # Whether we're in a To: or Cc: line

    while ( <STDIN> ) {
	print $msgfh $_;

	$in_to = 0 if ( $in_to && ! /^\s/ );
	$in_headers = 0 if ( $in_headers && !/\S/ );

	my $line = $_;

	# This is a challenge sent to an unknown party.  I make it extra
	# expensive so it's "last in line" for processing.
	if ( $in_headers && ( $line =~ /^Reply-To: kyle-cnf-/ ) ) {
	    $extra_expense = 1;
	}
	# This is a message on its way to me locally.  It needs no cash.
	if ( $in_headers && ( $line =~ /^X-TMDA-Confirm-Done: / ) ) {
	    $confirmed = 1;
	}
	# Pull addresses off Cc: and To: lines.  This is used to tell
	# which envelope recipients are blind carbon copies.
	if ( $in_headers && ( $in_to || $line =~ s/^(Cc|To): // ) ) {
	    # Get rid of all whitespace
	    $line =~ s/\s+//g;

	    # Get rid of any quoted text
	    $line =~ s/\"[^\"]*\"//g;

	    foreach my $addr ( split( ',', $line ) ) {
		next if ( $addr =~ m/undisclosed-recipients/i );
		next if ( $addr =~ m/recipientlistsuppressed/i );

		# Does it contain a route-addr?
		if ($addr =~ m/<(.*)>/) {
		    # Use the route-addr
		    $addr = $1;
		}

		# Does it have single quotes around it?
		# Microsoft Exchange sometimes does this
		$addr =~ s/^\'//;
		$addr =~ s/\'$//;

		# Get rid of comments in ()'s
		$addr =~ s/\(.*\)//g;

		if ( defined( $addr ) && $addr =~ m/^[-_.+\w]+\@[-_.+\w]+$/ ) {
		    push( @$toref, $addr );
		}
	    }

	    $in_to = 1;
	}
    }
}

#
# This looks at the arguments that were passed in (meant for sendmail)
# and tries to pick out the envelope recipients and the "pre args" that
# I should maintain if I end up meddling with the evenlope recipients.
#
sub process_args {
    my ( $args, $pre_args, $env_recip ) = @_;

    if ( @$env_recip = grep( /^--$/ .. undef, @$args ) ) {
	shift( @$env_recip );

	my @tmp = @$args;
	while ( my $t = shift( @tmp ) ) {
	    push( @$pre_args, $t );
	    last if ( $t eq '--' );
	}
    }
    else {
	# There's no '--' argument.
	my @a = @$args;
	while ( my $arg = shift( @a ) ) {
	    if ( $arg eq '-f' ) {
		push( @$pre_args, $arg );
		push( @$pre_args, shift( @a ) );
		next;
	    }
	    if ( $arg =~ /^-/ ) {
		push( @$pre_args, $arg );
	    }
	    else {
		push( @$env_recip, $arg );
	    }
	}
    }
}

#
# Interrupt the currently running hashcash to deliver a more important message.
# If the interruption is successful, this calls begin_delivery() for the
# specified message and puts it on the stack.
#
sub interrupt_with {
    my ( $msg, $stackr ) = @_;

    # This is what's running right now.
    my $topstate = $$stackr[ -1 ];

    my $stoppid = $$topstate{ 'hashcashpid' };
    if ( kill( 'STOP', $stoppid ) ) {
	logline( "interrupted $$topstate{ 'msg' } for $msg" );

	if ( ! begin_delivery( $msg, $stackr ) ) {
	    # In this case, the message was delivered without any work done.
	    # We need to restart the message we just interrupted.
	    logline( "continuing $$topstate{ 'msg' }" );
	    if ( ! kill( 'CONT', $stoppid ) ) {
		fatal( "failed to restart $$topstate{ 'msg' } (pid $stoppid)" );
	    }
	}
    }
}

#
# This is used to sort the messages.  We expect two filenames of the form:
# 1234-1234567890.1234.msg
# The first number is the expense, the second is when it entered the queue,
# and the third is just the PID of the queue writer.
# Above all, a .msg comes before a .req.
# Then we compare expenses and dates, and lower number wins for each.
# If they're equal on all counts, we just string compare the names, which
# probably means we're deciding based on a PID.
#
sub prioritize {
    my ( $ap, $ad, $bp, $bd ) = ( undef, undef, undef, undef );
    my ( $ae, $be ) = ( undef, undef );

    if ( $a =~ /\.(\w{3})$/ ) {
	$ae = $1;
    }
    if ( $b =~ /\.(\w{3})$/ ) {
	$be = $1;
    }

    if ( defined( $ae ) && defined( $be ) && $ae ne $be ) {
	# It just so happens that ( 'msg' cmp 'req' ) comes out "right".
	# If not, I'd have to be explicit about which I wanted first.
	return $ae cmp $be;
    }

    if ( $a =~ /^(\d+)-(\d+)\./ ) {
	$ap = $1; #priority (expense)
	$ad = $2; #date
    }
    if ( $b =~ /^(\d+)-(\d+)\./ ) {
	$bp = $1;
	$bd = $2;
    }
    if ( defined( $bp ) && defined( $ap ) && $bp != $ap ) {
	return ( $ap <=> $bp );
    }
    if ( defined( $bd ) && defined( $ad ) && $bd != $ad ) {
	return ( $ad <=> $bd );
    }

    return ( $a cmp $b );
}


#
# Call begin_delivery with a message to deliver.
# From there, everything spawns and runs.
# When hashcashfh is ready, call continue_delivery( $state )
# Delivery is finished when *_delivery() returns zero.
#

#
# begin_delivery takes a filename (of a message to work on) and returns
# a $state hash reference.  It returns zero if the message is already
# delivered (i.e., when it had no hashcash to compute).
#
# Its job is basically to set up the process.  It does everything up to
# where we need to invoke the hashcash executable, and then it calls
# continue_delivery() which does that invocation.
#
# This pushes a state onto the stack and it expects it to stay on top.
# If it calls continue_delivery() and finds that the message is all done,
# it pops the top item off the stack.
# XXX Perhaps I should verify it's the same state I pushed.
#
sub begin_delivery {
    my ( $msg, $stackr ) = @_;

    # The state we'll eventually return.
    my $state = { 'msg' => $msg };

    logline( "found $msg\n" );

    # Move the message out of the queue and into the tmp directory.
    # If this fails, we skip it.  Maybe some other daemon got it first?
    if ( rename( "$workdir/queue/$msg", "$workdir/tmp/$msg" ) ) {

	push( @$stackr, $state );

	# Get the name of the corresponding .dat file and import its data.
	my $dat = "$workdir/tmp/$msg";
	# If $msg is a .req, $dat isn't changed.
	$dat =~ s:/tmp/(.*)\.msg$:/queue/$1.dat:;

	# XXX It might be nice to handle errors in the dat file.
	require "$dat";

	$$state{ 'dat' } = $dat;
	$$state{ 'recip' } = [ @rcpt ]; # This was read from .dat

	# A .req doesn't need all this sendmail and stuff.
	if ( $msg =~ /\.msg$/ ) {
	    # Open the message for reading.
	    my $msgfh = new IO::File;
	    open( $msgfh, "$workdir/tmp/$msg" ) || fatal( "Can't read $workdir/tmp/$msg: $!\n" );
	    $$state{ 'msgfh' } = $msgfh;

	    # Build the sendmail command line.
	    my $com = "|/usr/sbin/sendmail";
	    foreach my $arg ( @args ) {
		$com .= " \"" . shell_escape( $arg ) . "\"";
	    }

	    # Open the pipe to sendmail.
	    spawn_sendmail( $state, $com );
	    my $sendmailfh = $$state{ 'sendmailfh' };

	    # Read the header of the message and send it to sendmail.
	    my $line = '';
	    while ( $line = $msgfh->getline ) {
		last if ( $line !~ /\S/ );
		print $sendmailfh $line;
	    }
	    # Remember exactly what the blank line was.
	    $$state{ 'blankline' } = $line;
	}

	# go get some hashcash
	my $out = continue_delivery( $state );
	if ( ! $out ) {
	    pop( @$stackr );
	}
	return $out;
    }

    return 0;
}

#
# This starts up the sendmail process and puts the writable filehandle in
# the given $state for later.  We also open sendmail's stdout/stderr for
# reading, and this function forks to read what it has to say without
# blocking.  Whatever sendmail outputs is logged.
#
sub spawn_sendmail {
    my ( $state, $com ) = @_;

    # Open3 knows this is a pipe; it's an error to have it there.
    $com =~ s/^\|//;

    my $smin = new IO::File;
    my $smout = new IO::File;

# XXX Doc says failures don't return; they raise an exception.  What?
    my $smpid = open3( $smin, $smout, $smout, $com );

    if ( ! $smpid ) {
	fatal( "Can't open sendmail: $!\n" );
    }

    $$state{ 'sendmailfh' }  = $smin;
    $$state{ 'sendmailpid' } = $smpid;

    # Now, fork a reader just to get and log sendmail's error messages.

    my $pid;
    if ( $pid = fork() ) {
	# parent
	close( $smout ); # parent does not read
	$$state{ 'loggerpid' } = $pid;

	return;
    }
    elsif ( ! defined( $pid ) ) {
	# child
	$need_cleanup = 0;
	fatal( "Can't fork: $!\n" );
    }
    # This should NOT do cleanup.  It's not THE daemon, just a little logger.
    $need_cleanup = 0;

    close( $smin ); # child does not write

    while ( my $line = $smout->getline ) {
	logline( "sendmail[$smpid] said: $line" );
    }
    close( $smout );

    exit;
}

#
# There's a hashcash subprocess with a token ready.  Read it, and do the
# right thing with it.  We'll either feed it to waiting sendmail or put
# it in a premade token file for later.  If it does not go to sendmail,
# we return 0 so the caller knows to call finish_delivery() and clean up.
#
sub take_new_token {
    my ( $state ) = @_;

    my $hc = $$state{ 'hashcashfh' };
    my $tok = join( '', $hc->getlines );
    close( $hc );
    waitpid( $$state{ 'hashcashpid' }, 0 );

    logline( "made token $tok" );

    if ( exists( $$state{ 'sendmailfh' } ) ) {
	my $sm = $$state{ 'sendmailfh' };
	print $sm $tok if ( $tok );
    }
    else {
	# If there's no sendmailfh, this is a request, not a message.

	my ( $bits, $expiry, $r ) = ( $$state{ 'cashinfo' } =~ /^(\d+):(\d*):(.*)/ );
	# Take the expiry on the token regardless of what we thought
	# it would be.
	# v0 = 0:date
	# v1 = 1:bits:date
	if ( $tok =~ /X-Hashcash: (?:0|1:\d+):(\d+):/ ) {
	    $expiry = $1;
	}

	# Make sure the premade directory exists
	if ( ! -d "$workdir/premade" && ! mkdir( "$workdir/premade" ) ) {
	    fatal( "Can't create $workdir/premade: $!\n" );
	}

	# Initial filename.  That '0' on the end gets incremented until
	# we find one that's not taken.
	my $prefile = "$workdir/premade/" . res2file( $r ) . ".$expiry.$bits.0";
	my $fh = new IO::File;
	while ( -e $prefile ||
		! sysopen( $fh, $prefile, O_RDWR|O_CREAT ) ||
		! flock( $fh, LOCK_EX|LOCK_NB ) )
	{
	    $prefile =~ s/\.(\d+)$/"." . ($1 + 1)/e;
	}
	logline( "saving to $prefile" );

	if ( ! truncate( $fh, 0 ) ) {
	    fatal( "Can't truncate $prefile: $!\n" );
	}
	print $fh $tok if ( $tok );
	close( $fh );

	# Multiple recipients in one .req not supported.
	return 0;
    }
}

#
# continue_delivery takes a state as an argument and returns a state.  It
# returns zero if the delivery is finished.
#
# What this does is invoke hashcash and then return the state information
# used to keep track of the job.  If there's a job already in progress, it
# pulls in the token and adds it to the outgoing message.  The caller is
# responsible for making sure the job is ready to read.
#
sub continue_delivery {
    my ( $state ) = @_;

    # If there's hashcash to read, read it and add it to the outgoing
    # message.  This won't happen the first time continue_delivery is
    # called for a message.
    if ( exists( $$state{ 'hashcashfh' } ) && ! take_new_token( $state ) ) {
	return finish_delivery( $state );
    }

    # Look through the recip list to find a recipient.
    my $recipient = undef;
    my $expiry = undef;
    my $bits = $bits_to_compute;
    my $r = undef;
    while ( @{ $$state{ 'recip' } } && ! defined( $recipient ) ) {
	$recipient = shift( @{ $$state{ 'recip' } } );
	if ( defined( $recipient ) ) {
	    if ( $$recipient{ 'bits' } ) {
		$bits = $$recipient{ 'bits' };
	    }
	    if ( exists( $$recipient{ 'expiry' } ) ) {
		$expiry = $$recipient{ 'expiry' };
	    }

	    # The guess is used in places where I always want to have
	    # something.  The $expiry is used for the command line.
	    my $expguess = $expiry ? $expiry : expire_today();

	    $$state{ 'cashinfo' } = "$bits:$expguess:$$recipient{ 'addr' }";

	    if ( exists( $$state{ 'sendmailfh' } ) ) {
		my $tok = get_premade( $bits, $expguess, $$recipient{ 'addr' },
				       $$state{ 'sendmailfh' } );
		if ( $tok ) {
		    # Using this means we don't need to process this recipient
		    # any further, so pretend we didn't find it.
		    $recipient = undef;
		}
	    }
	}
    }
    # If there are no more recipients, call finish_delivery(),
    # which always returns zero.
    if ( ! defined( $recipient ) ) {
	return finish_delivery( $state );
    }

    # Figure out the command line for hashcash.
    if ( defined( $$recipient{ 'reso' } ) ) {
	$r = shell_escape( $$recipient{ 'reso' } );
    }
    else {
	$r = shell_escape( $$recipient{ 'addr' } );
    }
    my $nice = ( $$recipient{ 'nice' } > 0 ) ? "nice -$$recipient{ 'nice' }" : '';
    my $ex = defined( $expiry ) ? "-t $expiry" : '';

    logline( "making token for $r ($bits bits)" );

    # Spawn the hashcash executable to do the grunt work.
    # We retain the PID and filehandle for later communication.
    my $rdfh = new IO::File;
    my $pid = open( $rdfh, "$nice hashcash -qm $ex -b $bits -r \"$r\" -X|" );
    if ( ! $pid ) {
	complain( "failed to execute hashcash: $!\n" );
	# Go on to next recipient.
	return continue_delivery( $state );
    }

    # Search the stack for another message that's making the same stamp
    my $steal = undef;
    foreach my $s ( @stack ) {
	next if ( $s == $state );

	if ( $$state{ 'cashinfo' } eq $$s{ 'cashinfo' } ) {
	    $steal = $s;
	    last;
	}
    }

    if ( ! $steal ) {
	# We're not stealing an existing process.  Just store the
	# PID and filehandle and go.
	$$state{ 'hashcashpid' } = $pid;
	$$state{ 'hashcashfh' } = $rdfh;
    }
    else {
	# This can most easily happen if the daemon is processing a .req
	# but hasn't finished.  We'll steal the request's work-so-far
	# and have it start over.
	# This can also happen if there's one message with many recipients,
	# and the recipient being computed right now gets another message
	# addressed just to that one recipient.  The new message will be
	# lower cost than the old, and it'll take its work.
	# Otherwise this only happens if you edit the bitconf between
	# messages, which is how I tested (meddle with the nice value).
	# NOTE that in the first and third case, the 'nice' level of the
	# process we steal is not necessarily what we want.
	logline( "using PID $$steal{ 'hashcashpid' } in progress for $r" );

	# Stop the new one.
#	logline( "stopping $pid" );
	if ( ! kill( 'STOP', $pid ) ) {
	    fatal( "Can't stop hashcash (pid $pid): $!\n" );
	}

	# Take the PID and filehandle of the (stopped) one already in progress.
	$$state{ 'hashcashpid' } = $$steal{ 'hashcashpid' };
	$$state{ 'hashcashfh' } = $$steal{ 'hashcashfh' };

	# The one in progress becomes the one we just started.
	$$steal{ 'hashcashpid' } = $pid;
	$$steal{ 'hashcashfh' } = $rdfh;

	# Restart the old one.
#	logline( "starting $$state{ 'hashcashpid' }" );
	if ( ! kill( 'CONT', $$state{ 'hashcashpid' } ) ) {
	    fatal( "Can't restart hashcash: $!\n" );
	}
    }

    return $state;
}

# What the 'expire' part of a token will look like for something made now.
sub expire_today {
    my ( $sec,$min,$hour, $mday,$mon,$year, $wday,$yday, $isdst ) = gmtime;

    $year =~ s/^\d*(\d\d)$/$1/;
    $mon++;

    $year = "0$year" while ( length( $year ) < 2 );
    $mon  = "0$mon"  while ( length( $mon )  < 2 );
    $mday = "0$mday" while ( length( $mday ) < 2 );

    return "$year$mon$mday";
}

sub get_recipient_premade {
    my ( $recipient, $outfh ) = @_;

    return unless ( $recipient );
    return unless ( $outfh );

    my $bits = $bits_to_compute;
    if ( $$recipient{ 'bits' } ) {
	$bits = $$recipient{ 'bits' };
    }

    my $expiry = undef;
    if ( exists( $$recipient{ 'expiry' } ) ) {
	$expiry = $$recipient{ 'expiry' };
    }

    # The guess is used in places where I always want to have
    # something.  The $expiry is used for the command line.
    my $expguess = $expiry ? $expiry : expire_today();

#    $$state{ 'cashinfo' } = "$bits:$expguess:$$recipient{ 'addr' }";

    return get_premade( $bits, $expguess, $$recipient{ 'addr' }, $outfh );
}

#
# Look through the premade tokens to find one that satisfies the given
# requirements.  The expiry and resource must match, but we'll take any
# token with the given bits or more.
#
sub get_premade {
    my ( $bits, $expiry, $r, $outfh ) = @_;

    my $out = undef;

    if ( $outfh && opendir( PREMADE, "$workdir/premade" ) ) {
	# This sorts the premade files by their cost in bits.
	# This way I can take the cheapest token that matches.
	my $bybits = sub {
	    if ( $a =~ /^[\w-]*\.\d*\.(\d+)\./ ) {
		my $abits = $1;
		if ( $b =~ /^[\w-]*\.\d*\.(\d+)\./ ) {
		    my $bbits = $1;
		    return ( $abits <=> $bbits );
		}
	    }
	    return ( $a cmp $b );
	};

	my $sha = res2file( $r );
	# All premade tokens for this recipient, sorted by bits.
	my @premade_files = sort $bybits readdir( PREMADE );
	closedir( PREMADE );

	foreach my $premade ( @premade_files ) {
	    my ( $fsha, $fexpiry, $fbits ) = ( $premade =~ /^([\w-]*)\.(\d*)\.(\d+)\./ );
	    next if ( $fsha    ne $sha );
	    next if ( $fexpiry ne $expiry );
	    next if ( $fbits   < $bits );

	    my $pfh = undef;
	    # If I'm able to rename the file, that ensures no other daemon
	    # got a hold of it first.
	    if ( rename( "$workdir/premade/$premade", "$workdir/tmp/$premade" ) ) {
		if ( ! open( $pfh, "$workdir/tmp/$premade" ) ) {
		    complain( "Can't open $workdir/tmp/$premade: $!\n" );
		    next;
		}
		$out = join( '', $pfh->getlines );
		close( $pfh );
		if ( ! unlink( "$workdir/tmp/$premade" ) ) {
		    complain( "Can't unlink $workdir/tmp/$premade: $!\n" );
		}
		# Look at no more files.
		last;
	    }
	}
    }

    if ( $out ) {
	# If we have a premade token, use it.
	logline( "using premade token $out" );
	print $outfh $out;
    }

    return $out;
}

#
# finish_delivery() takes a state as an argument and returns zero.
# This function's job is just to push the message body out to sendmail.
#
sub finish_delivery {
    my ( $state ) = @_;

    my $msg   = $$state{ 'msg' };
    my $sm    = $$state{ 'sendmailfh' };
    my $msgfh = $$state{ 'msgfh' };

    if ( $sm ) {
	if ( exists( $$state{ 'blankline' } ) ) {
	    print $sm $$state{ 'blankline' };
	    delete( $$state{ 'blankline' } );
	}

	if ( $msgfh ) {
	    while ( my $line = $msgfh->getline ) {
		print $sm $line;
	    }
	}

	# This checks sendmail's exit status.  If something's wrong, we
	# put the message back in the queue, whine, and abort with the same
	# exit code that sendmail gave.
	if ( ! close( $sm ) && ! $! ) {
	    # Propogate the exit code.
	    my $exit_code = $?;

	    logline( "putting $msg back in queue" );
	    rename( "$workdir/tmp/$msg", "$workdir/queue/$msg" );
	    complain( "sendmail exited with $exit_code\n" );
	    exit( $exit_code );
	}

	# Reap my subprocesses properly.
	if ( $$state{ 'sendmailpid' } ) {
	    waitpid( $$state{ 'sendmailpid' }, 0 );
	}
	if ( $$state{ 'loggerpid' } ) {
	    waitpid( $$state{ 'loggerpid' }, 0 );
	}
    }
    close( $msgfh ) if ( $msgfh );

    # Delete the message and the dat file.
    if ( ! unlink( "$workdir/tmp/$msg", $$state{ 'dat' } ) ) {
	fatal( "Can't unlink: $!\n" );
    }

    if ( $msg =~ /^\d+-(\d+)\.\d+\.msg/ ) {
	my $intime = $1;
	my $qtime = time() - $intime;
	logline( "delivered $msg about $qtime seconds since it was queued" );
    }
    else {
	logline( "delivered $msg" );
    }

    %{ $state } = ();

    return 0;
}

# It's a 'warn' that logs as well.
sub complain {
    my ( $line ) = @_;

    logline( $line );
    warn $line;
}

# It's a 'die' that logs as well.
sub fatal {
    my ( $line ) = @_;

    logline( "FATAL: $line" );
    die $line;
}

# Writes a line to the log.  It does nice stuff like add a datestamp
# and the program name and such.
sub logline {
    my ( $line ) = @_;

    if ( $line =~ /\S/ ) {
	my $out = scalar localtime();

	my $name = $0;
	$name =~ s:^/.*/([^/]+)$:$1:;

	$out .= " $name\[$$]: ";
	
	$line =~ tr/\r\n/ /;
	$line =~ s/^\s+//;
	$line =~ s/\s+$//;

	$out .= "$line\n";

	lograw( $out );
    }
}

# Logs stuff.  It does locking on the log file, but it does no formatting.
sub lograw {
    my @logstuff = @_;

    my $fh = new IO::File;
    sysopen( $fh, $logfile, O_RDWR|O_CREAT ) || die "Can't write $logfile: $!\n";
    flock( $fh, LOCK_EX ) || die "Can't LOCK_EX $logfile: $!\n";
    seek( $fh, 0, SEEK_END ) || die "Can't seek on $logfile: $!\n";

    print $fh @logstuff;

    close( $fh );
}

# Camel book, 3rd ed, page 782
sub fhbits {
    my @fhlist = @_;
    my $bits;
    for ( @fhlist ) {
	vec( $bits, fileno( $_ ), 1 ) = 1;
    }
    return $bits;
}

# This is called any time we're about to die.  Its job is to put .msg
# files back in the queue and kill lingering hashcash jobs.
sub cleanup {
    my ( $sig ) = @_;

    my $sigmess = ( $sig ) ? " on signal $sig" : '';

    if ( ! $need_cleanup ) {
	logline( "exit$sigmess" ) if ( $sigmess );
    }
    else {
	$need_cleanup = 0;

	logline( "cleanup$sigmess" );
	foreach my $state ( @stack ) {
	    my $pid = $$state{ 'sendmailpid' };
	    if ( $pid ) {
		logline( "TERM sendmail PID $pid" );
		kill( 'TERM', $pid );
	    }
	    # This was 'TERM', but that didn't get it.
	    $pid = $$state{ 'hashcashpid' };
	    logline( "KILL hashcash PID $pid" );
	    kill( 'KILL', $pid );

	    my $msg = $$state{ 'msg' };
	    logline( "putting $msg back in queue" );
	    rename( "$workdir/tmp/$msg", "$workdir/queue/$msg" );
	}
	# It's tempting to unlink $pidfile here, but it's possible
	# someone has it open for reading.  If I unlink it, they'll
	# write to a file that disappears when they close it.
    }
    exit;
}

# This looks through premade tokens looking for things that are expired.
sub expire_premade {
    if ( opendir( PREMADE, "$workdir/premade" ) ) {
	my $now = expire_today();
	while ( my $premade = readdir( PREMADE ) ) {
	    if ( $premade =~ /^[\w-]*\.(\d+)\./ ) {
		my $e = $1;
		if ( $e < $now ) {
		    logline( "discarding expired premade token in $premade" );
		    if ( ! unlink( "$workdir/premade/$premade" ) ) {
			complain( "Can't unlink $premade: $!\n" );
		    }
		}
	    }
	}
	closedir( PREMADE );
    }
}

#
# Look for a .msg or .req in tmp/ and return it to the queue/
# This is called after we've determined that this is to be the one and only
# daemon but before we start processing messages, so we know tmp/ SHOULD
# be empty.  Messages might be left in tmp/ if hashcash-sendmail was running
# during a power failure, for instance.
#
sub recover_dead_queue {
    if ( ! opendir( TMP, "$workdir/tmp" ) ) {
	complain( "Can't opendir( $workdir/tmp ): $!\n" );
	return;
    }
    my @replace = grep( !/^\./ && /\.(req|msg)$/, readdir( TMP ) );
    closedir( TMP );

    if ( @replace ) {
	complain( "Earlier hashcash daemon must have died; replacing lost queue items." );
	foreach my $file ( @replace ) {
	    if ( -f "$workdir/queue/$file" ) {
		complain( "'$file' exists in both tmp and queue!" );
		next;
	    }
	    rename( "$workdir/tmp/$file", "$workdir/queue/$file" ) || complain( "Can't rename tmp/$file to queue: $!\n" );
	}
    }
}

#
# This checks if another daemon is running and exits if there is.
# If not, we write our PID to the pidfile.
#
sub handle_pidfile {
    my ( $pidfile ) = @_;

# Open for read and write, create if not there.
    my $pidfh = new IO::File;
    if ( ! sysopen( $pidfh, "$pidfile", O_RDWR|O_CREAT ) ) {
	fatal( "Can't write $pidfile: $!\n" );
    }

# Locking avoids race conditions.  I can share a lock with someone else
# who's also trying to read, but I can't share with a writer.
    flock( $pidfh, LOCK_SH ) || fatal( "Can't LOCK_SH $pidfile: $!\n" );
    my $oldpid = $pidfh->getline;

# Check if the old daemon is still alive.
    if ( $oldpid && kill( 0, $oldpid ) ) {
	# There's already a daemon running.
	logline( "waking PID $oldpid" );
	kill( 'USR1', $oldpid );
	exit 0;
    }

# Truncate the file and write my own PID there.
    flock( $pidfh, LOCK_EX|LOCK_NB ) || fatal( "Can't lock $pidfile: $!\n" );
    seek( $pidfh, 0, SEEK_SET )      || fatal( "Can't seek on $pidfile: $!\n" );
    truncate( $pidfh, 0 )            || fatal( "Can't truncate $pidfile: $!\n" );
    print $pidfh "$$\n";
    close( $pidfh );
}

# This is to disconnect from the shell that ran me.
sub daemonize {
    my $pid;

    # Doing this instead of just closing them makes some oddball case work.
    # I wish I knew why.
    open( STDIN,   "/dev/null" ) || fatal( "Can't reopen STDIN: $!\n" );
    open( STDOUT, ">/dev/null" ) || fatal( "Can't reopen STDOUT: $!\n" );
    open( STDERR, ">/dev/null" ) || fatal( "Can't reopen STDERR: $!\n" );

    # Ignore the fact that the parent dies.
    $SIG{ HUP } = sub { logline( "ignored $_[0]" ); };

    if ( $pid = fork() ) {
	# Parent exits immediately.
	exit 0;
    }
    elsif ( ! defined( $pid ) ) {
	complain( "Can't fork: $!\n" );
    }

    setpgrp( 0, $$ );
    setsid();
}

# Escapes shell meta characters, so I can safely use it on the command line.
# This does NOT escape spaces.  What you get from this is meant to be put in
# double quotes on the command line.
sub shell_escape {
    my ( $string ) = @_;

    $string =~ s/\\/\\\\/g;
    $string =~ s/\"/\\\"/g;
    $string =~ s/\$/\\\$/g;
    $string =~ s/\`/\\\`/g;

    return $string;
}

#
# Given a reference to a list of hashcash recipients, this will construct a
# simple @rcpt list, which is just a bunch of references to hashes.  Each
# hash this produces will have JUST the recipient set, but other things will
# be added to those hashes later.
#
sub msgrcpt {
    my ( $hashref ) = @_;

    my @rcpt = ();
    if ( ! $confirmed ) {
	foreach my $addr ( @$hashref ) {
	    my $add = { 'addr' => $addr };
	    push( @rcpt, $add );
	}
    }

    return @rcpt;
}

#
# Given a reference to a @rcpt list, and a reference to a @bitconf, this
# will add missing information to the @rcpt list.  For each thing in the
# @rcpt list, we add 'bits' and 'nice' if they're not there.
#
sub heed_bitconf {
    my ( $rcptref, $confref ) = @_;

    foreach my $add ( @$rcptref ) {
	next unless ( defined( $$add{ 'addr' } ) );

	my $addr = $$add{ 'addr' };
	my $need_bitconf = 0;

	$need_bitconf = 1 if ( ! defined( $$add{ 'bits' } ) );
	$need_bitconf = 1 if ( ! defined( $$add{ 'nice' } ) );
	$need_bitconf = 1 if ( ! defined( $$add{ 'reso' } ) );

	next unless ( $need_bitconf );

	foreach my $pair ( @$confref ) {
	    # These are the fields in the bitconf, separated by colons.
	    # $pat  -- a regular expression
	    # $bits -- how many bits to compute
	    # $nice -- what nice value to run at.
	    # $reso -- non-standard resource (optional)
	    my ( $pat, $bits, $nice, $reso ) = split( /:/, $pair );

	    # If this address matches the pattern, we treat it as the
	    # config says.
	    if ( $addr =~ /$pat/i ) {
		if ( ! defined( $$add{ 'bits' } ) ) {
		    $$add{ 'bits' } = $bits;
		}
		if ( ! defined( $$add{ 'nice' } ) ) {
		    $$add{ 'nice' } = $nice;
		}
		if ( ! defined( $$add{ 'reso' } ) && defined( $reso ) ) {
		    $$add{ 'reso' } = $reso;
		}
		last;
	    }
	}

	# It's possible that $addr does not match any pattern.
	# I'd still like to have some defaults in that case.
	$$add{ 'bits' } = $bits_to_compute if ( ! defined( $$add{ 'bits' } ) );
#	$$add{ 'nice' } = 19               if ( ! defined( $$add{ 'nice' } ) );
    }
}

#
# Given a reference to a @rcpt list, this computes the expense of the message.
# Assumes that heed_bitconf was called, so there's 'nice' and 'bits' for all.
#
sub message_expense {
    my ( $rcptref ) = @_;

    # For each recipient, we take log-base-2 of the number of bits we need
    # and multiply by 100.  Without the multiplier, lots of values for
    # $bits would be indistinguishable.  Then we multiply by the nice value
    # assigned because I figure the less we want to hog the CPU, the less
    # we care about this recipient, and the more "expensive" we should
    # consider it.  The cost of all the recipients are summed.

    my $expense = 0;

    foreach my $add ( @$rcptref ) {
	next if ( ! defined( $add ) );

	my $bits = $$add{ 'bits' } || $bits_to_compute;

	my $exp = int( 100 * log( $bits ) / log( 2 ) );
	$exp *= $$add{ 'nice' } if ( $$add{ 'nice' } );

	$expense += $exp;
    }

    $expense *= 10 if ( $extra_expense );

    return $expense;
}

#
# This queues one message.
# $filebase -- the name of the temp file that has the message text.
# $argsref  -- (ref to) the arguments that'll be passed to sendmail.
# $rcptref  -- list of refs to hashes with recipient info.
# $confref  -- the config file we read in
#
# $filebase will be COPIED, so the caller is responsible for unlinking it.
# This function computes the expense of the message and writes out
# everything that will go to the queue.
#
# If $argsref is false or points to an empty list, queue() thinks this is
# a request for a premade token.  In that case, $filebase doesn't exist,
# and we do things a little differently to queue the .req
#
sub queue {
    my ( $filebase, $argsref, $rcptref, $confref ) = @_;

    # Add bitconf info to the recipients.
    heed_bitconf( $rcptref, $confref );

    my $is_req = ( $argsref && @$argsref ) ? 0 : 1;
    my $ext = $is_req ? 'req' : 'msg';

    my $tmpfile = "$workdir/tmp/msgcopy$$";
    if ( ! $is_req ) {
	if ( ! copy_with_premade( "$workdir/tmp/$filebase.msg", "$tmpfile",
				  $rcptref ) )
	{
	    unlink( "$workdir/tmp/$filebase.msg" );
	    die "Can't copy $filebase.msg: $!\n";
	}
    }

    # Compute expense based on the recipients who need hashcash.
    my $expense = message_expense( $rcptref );

    # Make sure we're not about to overwrite something.  If so, we
    # increment $expense until we find a place to write.
    my $outbase = "$workdir/queue/$expense-$filebase";
    while ( -e "$outbase.$ext" ) {
	$expense++;
	$outbase = "$workdir/queue/$expense-$filebase";
    }

    # This is where we'll write the metadata for the message.
    # For requests, this is the only thing we'll write.
    my $dat = ( $is_req ) ? "$workdir/tmp/$expense-$filebase.req" : "$outbase.dat";


# Now we write our .dat file with the stuff the daemon will need.
# If this is a request, we're writing the final .req file that will go in the
# queue.  We write it to tmp so we can do a nice atomic rename() later.
    if ( ! open( META, ">$dat" ) ) {
	die "Can't write $dat: $!\n";
    }

    $Data::Dumper::Useqq = 1;
    my $dump;
    if ( $argsref && @$argsref ) {
	$dump = Data::Dumper->Dump( [ $argsref, $rcptref ],
				    [ qw( *args *rcpt ) ] );
    }
    else {
	$dump = Data::Dumper->Dump( [ $rcptref ],
				    [ qw( *rcpt ) ] );
    }
    $dump .= "\n1;\n";

    print META $dump;
    close( META );

# Put the message in the queue.
# This is the point at which it's "live" and ready for processing.
# Make no more modifications to the message after this!  The daemon may
# already be working on it.

    if ( $is_req ) {
	$tmpfile = $dat;
    }

    # I use a temp file to avoid a race condition where the daemon starts
    # reading the message before copy() is done writing it.
    if ( rename( $tmpfile, "$outbase.$ext" ) ) {
	my $rpt = "$outbase.$ext";
	$rpt =~ s:^.*/([^/]+)$:$1:;
	logline( "queued $rpt" );
    }
    else {
	unlink( $tmpfile );
	if ( ! $is_req ) {
	    unlink( $dat, "$workdir/tmp/$filebase.msg" );
	}
	die "Can't rename $tmpfile: $!\n";
    }

    return;
}

#
# This makes a copy of a message (for queueing) and also adds any premade
# hashcash that is available.  Pass in a recipient list reference so it
# knows what recipients need hashcash.  It will remove from that list
# any recipients it was able to find premade tokens for.  Returns 1 for
# success and undef for failure.
#
sub copy_with_premade {
    my ( $msgfile, $outfile, $rcptref ) = @_;

    # Open the input message for reading.
    my $msgfh = new IO::File;
    if ( ! open( $msgfh, $msgfile ) ) {
	complain( "Can't read $msgfile: $!\n" );
	return undef;
    }

    # Open the output file for writing.
    my $outfh = new IO::File;
    if ( ! open( $outfh, ">$outfile" ) ) {
	complain( "Can't write $outfile: $!\n" );
	close( $msgfh );
	return undef;
    }

    # Copy the headers (everything up to a line that does not contain
    # any non-whitespace characters).
    my $line;
    while ( $line = $msgfh->getline ) {
	last if ( $line !~ /\S/ );
	print $outfh $line;
    }

    # Finished copying headers.  Now loop through recipients and add what
    # hashcash we can.
    my @leftover = ();
    foreach my $r ( @$rcptref ) {
	if ( ! $r || ! get_recipient_premade( $r, $outfh ) ) {
	    push( @leftover, $r );
	}
    }

    # @leftover is just the ones for which we didn't have a premade token.
    # So @$rcptref is now smaller if we found premade tokens for things in it.
    @$rcptref = @leftover;

    print $outfh $line;  # The blank line we read at the end of headers.

    # Copy the rest of the message.
    while ( $line = $msgfh->getline ) {
	print $outfh $line;
    }

    close( $outfh );
    close( $msgfh );

    return 1;
}

#
# Read in the config file.
#
# Example line:
# kyle\@(.+\.)*toehold\.com:20:0:kyleha
#
# It's three or four fields separated by colons.
#
# The first field is a Perl regular expression to match.
# The second is how many bits to compute for that recipient.
# The third is the nice level to run at for that recipient.
# The fourth is a resource value to use instead of the email address.
#
# The fourth field is optional.  Such an entry looks like this:
#
# kyle\@(.+\.)*toehold\.com:20:0
#
# Comments start with a "#".
# Any line that doesn't match the format is ignored.
#
# First match wins.  It's probably good to have a "default" at the end of the
# file like this:
#
# ^:26:19
#
# ...which means anyone not listed gets 26 bits running at nice -19 (lowest
# priority).
#
sub read_bitconf {
    my @bitconf = ();
    if ( open( BITCONF, $conffile ) ) {
	while ( <BITCONF> ) {
	    next if /^#/;
	    next unless /^[^:]+:\d+:\d+(:[^:]*)?$/;
	    chomp;
	    push( @bitconf, $_ );
	}
	close( BITCONF );
    }

    return @bitconf;
}

# $Log: hashcash-sendmail,v $
# Revision 1.18  2004/08/07 18:36:16  kyle
# Check for queue items in tmp in case of crash.
# Read multi-line tokens.
#
# Revision 1.17  2004/06/24 16:13:39  kyle
# Check for and complaint about not disconnecting from parent doesn't work
# and isn't needed.
#
# Revision 1.16  2004/06/11 15:27:25  kyle
# Daemonize better.
# Use SIGUSR1 for IPC instead of SIGHUP.
#
# Revision 1.15  2004/06/02 17:18:56  kyle
# Bitconf can specify an arbitrary resource for any address.
# If hashcash gave us a v1 stamp, hashcash-sendmail finds the date correctly.
#
# Revision 1.14  2004/04/13 18:58:02  kyle
# Make sure time zone always has either a + or a - before the digits.
#
# Revision 1.13  2004/04/12 20:27:19  kyle
# Fix a bug related to the new Recieved: headers I'm inserting (thanks to
# Jason Mastaler for finding it).
#
# Revision 1.12  2004/04/06 16:59:15  kyle
# Avoid crashing via log( $bits = 0 ).
# Create the premade token directory if it doesn't exist.
# Use premade tokens at queue time to speed up delivery.
#
# Revision 1.11  2004/04/02 20:55:45  kyle
# Add a Received: line on the way through.
# Properly reap a couple of child processes.
# Log my hostname and RCS ID when the daemon starts.
#
# Revision 1.10  2004/04/02 18:57:45  kyle
# Fixed a bug where premade tokens would clobber each other.
# Better error reporting when sendmail complains.
# Fixed a bug where the daemon would hang (I think).
#
# Revision 1.9  2004/03/31 05:14:59  kyle
# hashcash-daemon has been incorporated into hashcash-sendmail now.  After
# messages are queued, it disconnects from the caller and tries to process
# the queue.  All the code from hashcash-daemon has been basically pasted in
# and adapted slightly.
# If hashcash-sendmail is invoked with no arguments, it expects a token
# request on standard input.  There's been lots of reorganization to support
# the new dual purpose.
# This also fixes a bug where the daemon wouldn't die properly if it had a
# hashcash-in-progress when it received the kill signal.
#
# Revision 1.8  2004/03/19 20:36:46  kyle
# Fix a possible race condition when copying the message to the queue.
# Invoke the daemon right before exit.
#
# Revision 1.7  2004/03/16 01:47:58  kyle
# Make sure not to overwrite a message I just queued in the case where I'm
# handling a Bcc by making multiple copies.  Thanks to Gerhard A. Blab for
# pointing this out.
# Also fix a bug where a failed queue() call would stop future queue() calls
# from working.
#
# Revision 1.6  2004/03/09 06:01:59  kyle
# Correctly handle the case where we have ALL Bcc and NO visible header
# recipients.  Also did some comment maintenance.
#
# Revision 1.5  2004/03/08 21:38:49  kyle
# Queue separate messages for Bcc recipients so they still get hashcash but
# don't get revealed to other recipients.  Thanks to Adam Back for the
# suggestion.
#
# Revision 1.4  2004/03/08 17:40:10  kyle
# Fix the env_recip grep line (thanks Adam Back for figuring out the problem)
# so that it works on other versions of Perl.
# Add my email address and URL to the comments.
#
# Revision 1.3  2004/03/08 02:03:32  kyle
# Create the working directories if they don't exist.
#
# Revision 1.2  2004/03/07 22:20:14  kyle
# Make the working directory less hardcoded.
#
# Revision 1.1  2004/03/07 22:14:24  kyle
# Initial revision
#
