#!/usr/pkg/bin/perl -w

eval 'exec /usr/pkg/bin/perl -w -S $0 ${1+"$@"}'
    if 0; # not running under some shell

# egd.pl: The Entropy Gathering Daemon
#  by Brian Warner <warner@lothar.com>
#  Released Version 0.8
#
#  $Id: egd.pl,v 1.48 2000/05/14 01:50:17 warner Exp $

# This is a perl program to collect entropy from a running Unix-like system,
# mostly through various stats calls (vmstat and friends). The output is
# hashed into a pool, stirred with an SHA1 hash, and used to provide
# (theoretically) high-quality random data to callers over a UNIX- or TCP-
# socket interface. This aims to provide functionality similar to the Linux
# /dev/random device, but implemented in a fairly-portable user-space daemon
# so that it can run on many unix-like systems. See the README for common
# usage details.

# This program requires perl5 (5.004 should do), and the SHA module (available
# from any CPAN mirror: see www.perl.org for details).

# The code was originally inspired by the rndunix.c entropy gatherer in
# Cryptlib, by Peter Gutmann et al. The basic list of entropy sources used
# here was copied from that code. Everything else is original.

# Copyright (C) 1999,2000 Brian Warner <warner@lothar.com>
# Released under the GNU General Public License
# For details, see the file COPYING provided in the source archive


use SHA;
use IO::Select;
use IO::Socket;
use IO::File;
use Getopt::Long;

sub Usage {
    print STDERR <<'EOF';
egd.pl [options] /tmp/entropy
Options:
 --debug: display entropy count, sleep time on each loop pass
 --debug-select: print STDERR status of fds used in select() loop
 --debug-gather: print STDERR stats of gatherers started and reaped
 --debug-client: print STDERR info about client requests
 --debug-pool: print STDERR size, contents of entropy pool
 --bottomless: for testing, don't decrement entropy count
 --nofork: do not put self in background: remain in foreground
 --quit-after=30: terminate after 30 minutes

 --kill: kill off the local daemon on other side of the socket

 socket is either a TCP socket (8000 or localhost:8000), or a pathname to a
 UNIX-domain socket (/tmp/entropy, ~/.gnupg/entropy, foo.entropy).
EOF
    exit(0);
}

$POOLSIZE = 520; #*1024; # in bytes. Make this a multiple of the hash size
$MIN_ENTROPY = $POOLSIZE*8* 0.30; # dip below this, and we gather more
$MAX_ENTROPY = $POOLSIZE*8; # go above this, stop gathering
$REFRESH_TIME = 1*60; $DECAY = 20;
$pool_entropy = 0;
$MAX_GATHERERS = 2;
$DIGEST_SIZE = 20;

$help = 0;
$debug = 0;
$debug_select = 0;
$debug_gather = 0;
$debug_client = 0;
$debug_pool = 0;
$bottomless = 0;
$kill_mode = 0;
$quit_after = 0;
$nofork = 0;

GetOptions(
	   "help" => \$help,
	   "debug" => \$debug,
	   "debug-select" => \$debug_select,
	   "debug-gather" => \$debug_gather,
	   "debug-client" => \$debug_client,
	   "debug-pool" => \$debug_pool,
	   "bottomless" => \$bottomless,
	   "quit-after=i" => \$quit_after,
	   "nofork" => \$nofork,
	   "kill" => \$kill_mode,
	  ) or &Usage();
&Usage if $help;

sub get_pid_from_remote {
    my($socket) = @_;
    my $s = new IO::Socket::UNIX('Peer' => $socket);
    return undef unless $s;
    my $msg = pack("C", 0x04); # get PID
    $s->syswrite($msg, length($msg));
    my $nread = $s->sysread($msg, 1);
    return undef unless $nread == 1;
    my $count = unpack("C", $msg);
    $nread = $s->sysread($msg, $count);
    return undef unless $nread == $count;
    my $pid = $msg;
    return $pid;
}

if ($kill_mode) {
    foreach my $socket (@ARGV) {
	if ($socket =~ /^\d+$/ or $socket =~ /:/) {
	    print STDERR " cannot --kill across TCP sockets for '$socket'\n";
	    next;
	}
	my $pid = get_pid_from_remote($socket);
	next unless $pid;
	print STDERR "killing process $pid\n";
	kill 1, ($pid);
	sleep(1);
	kill 9, ($pid);
    }
    exit(0);
}

unless (@ARGV) {
    print STDERR "No sockets to read entropy: not very useful.\n";
    print STDERR "Try running as:  egd.pl ~/.gnupg/entropy\n";
    print STDERR "Terminating.\n";
    exit(0);
}

@lsockets = (
#	     ["11111", 1],
#	     ["/home/warner/.gnupg/entropy", 0],
);

# check to see if a daemon is already running on a socket. If so, remove that
# socket from the list
foreach my $socket (@ARGV) {
    if ($socket =~ /^\d+$/ or $socket =~ /:/) {
	# TCP socket
	push(@lsockets, [$socket,0]);
    } else {
	# unix socket
	my $pid = get_pid_from_remote($socket);
	push(@lsockets, [$socket,0]) unless $pid; # already running
    }
}

if (!@lsockets) {
    # terminate quietly: daemon is already running
    exit(0);
}

# each socket is as follows:
#  $s[0]: a pathname for a unix socket if it begins with a /
#         else [name:]socket  (name allowed to bind to a particular interface)
#  $s[1]: nonzero if this is a control interface (allows writes), 0 otherwise
# these are added once the daemon starts up:
#  $s[2]: the IO::Socket object

$pool = "\x00" x $POOLSIZE;

$next_source = 0;

# [0] cmd
# [1] minimum repeat time (0 if unused)
# [2] entropy_per_byte (bits per byte)
#      use 1.0 for dense sources, 0.1 or less for fluffy sources
# [3] max_bits
# [4] timeout
# [5] [inuse]
# [6] [skip]

$MAX_BITS_PER_SOURCE = 800;
$SOURCE_TIMEOUT = 10;
$REUSE_TIMER = 60;

@dirs = qw(/bin /usr/bin /usr/ucb /sbin /usr/sbin /usr/etc /usr/bsd
	   /usr/local/bin /usr/local/sbin);

# format of the sources:
#  blank lines and comments (lines starting with #) are ignored
#  all other lines look like one of:
#   flags=foo,flags,moreflags /path/command args args args
#    /path/command args args args
#  each flag not specified explicitly picks up the previous value used
#  flags are all numerical (flag=value)
#  known flags:
#   bpb=#  bits of entropy per byte of [filtered] output
#   filter=1/0: if 1, filter (ignore) all non-numerical output from program
#   maxbits=# : maximum amount of entropy that will be accepted from this prog
#   timeout=# : seconds after which program is killed off
#   reuse=# : seconds, do not run program more frequently than this
#  if the command does not start with a '/', each of @dirs is searched for it
# the sources are tested at startup for executability, and any that can't be
# found or which aren't executable are dropped.
# while running, any sources which produce no stdout are dropped

$sources = <<'EOF';
bpb=0.5,filter=1
 vmstat -s
 vmstat -c

bpb=0.4,filter=1
 pfstat
 vmstat -i

bpb=0.5,filter=1
 netstat -s
 nfsstat

bpb=0.3,filter=1
 netstat -m
 netstat -in

bpb=0.3,filter=0
# UDP in
 snmp_request localhost public get 1.3.6.1.2.1.7.1.0
# UDP out
 snmp_request localhost public get 1.3.6.1.2.1.7.4.0
# IP ?
 snmp_request localhost public get 1.3.6.1.2.1.4.3.0
# TCP ?
 snmp_request localhost public get 1.3.6.1.2.1.6.10.0
# TCP ?
 snmp_request localhost public get 1.3.6.1.2.1.6.11.0
# TCP ?
 snmp_request localhost public get 1.3.6.1.2.1.6.13.0

bpb=0.3,filter=0
 mpstat
 w

bpb=0.3,filter=1
 df

bpb=0.3,filter=0
 portstat

bpb=0.1,filter=1
 iostat
 uptime
 vmstat -f
 vmstat

bpb=0.3,filter=0
 netstat -n

bpb=0.2,filter=0
 lsof

#if defined( __sgi ) || defined( __hpux )
bpb=0.1,filter=0 /bin/ps -el
#endif				/* __sgi || __hpux */

bpb=0.1,filter=0
 ps aux

bpb=0.1,filter=1
# Unreliable source, depends on system usage
 ipcs -a

bpb=0.1,filter=0
 pstat -p

bpb=0.1,filter=1
 pstat -S

bpb=0.1,filter=0
 pstat -v
 pstat -x

bpb=0.05,filter=0
 pstat -t
# pstat is your friend

bpb=0.1,filter=0
 last -n 50
 last -50

bpb=0.1,filter=0
 snmp_request localhost public get 1.3.6.1.2.1.5.1.0
# ICMP ?

bpb=0.1,filter=0
 snmp_request localhost public get 1.3.6.1.2.1.5.3.0
# ICMP ?

bpb=0.1,filter=0
 arp -a

bpb=0.1,filter=0
 ripquery -nw 1 127.0.0.1

bpb=0.1,filter=0
 lpstat -t

bpb=1.0,filter=0
 tcpdump -c 5 -efvvx
# This is very environment-dependant.  If network traffic is low, it'll
# probably time out before delivering 5 packets, which is OK because
# itll probably be fixed stuff like ARP anyway


# This is a complex and screwball program.  Some systems have things
# like rX_dmn, x = integer, for RAID systems, but the statistics are
# pretty dodgy
bpb=0.1,filter=0 advfsstat -b usr_domain
bpb=0.2,filter=0 advfsstat -l 2 usr_domain
bpb=0.1,filter=0 advfsstat -p usr_domain

# The following aren't enabled since they're somewhat slow and not very
# unpredictable, however they give an indication of the sort of sources
# you can use (for example the finger might be more useful on a
# firewalled internal network)

#bpb=0.3 finger @ml.media.mit.edu

#bpb=8.0 wget -O - http://lavarand.sgi.com/block.html
# (bpb=8 means pure entropy)

#bpb=0.5 cat /usr/spool/mqueue/syslog

EOF

# parse the sources list
{
    my(@sources_lines) = split(/\n/,$sources);
    my($min_reuse_time, $bits_per_byte, $max_bits, $timeout, $source);
    my(%flags) = (
		  bpb => 2, filter => 0,
		  maxbits => $MAX_BITS_PER_SOURCE,
		  timeout => $SOURCE_TIMEOUT,
		  reuse => $REUSE_TIMER,
		 );

    foreach my $line (@sources_lines) {
	next if $line =~ /^\s*#/;
	next if $line =~ /^\s*$/;
	my(@words) = split(/\s+/, $line);
	if (length($words[0])) {
	    # new flags
	    my(@flags) = split(/,/,$words[0]);
	    foreach (@flags) {
		/^([^=]+)=([^=]+)$/;
		die "bad flag $_ on source line '$line'" unless $1;
		$flags{$1} = $2;
	    }
	}
	next unless (@words > 1);
	# find the executable
	my $exec = $words[1];
	my(@execs);
	if ($exec !~ m!^/!) {
	    # not an absolute path. search @dirs
	    foreach my $dir (@dirs) {
		if (-x "$dir/$exec" or -X "$dir/$exec") {
		    push(@execs, "$dir/$exec");
		    last;
		}
	    }
	} else {
	    if (-x $exec or -X $exec) {
		push(@execs, $exec);
	    }
	}
	next unless @execs;
	foreach $exec (@execs) {
	    my(%s);
	    $s{'cmd'} = join(' ', $exec, @words[2 .. $#words]);
	    foreach (keys(%flags)) {
		$s{$_} = $flags{$_};
	    }
	    $s{'last_started'} = 0;
	    push(@sources, \%s);
	    #push(@sources, [ $_, $min_reuse_time, $bits_per_byte, $max_bits,
	    #		 $timeout, 0, 0 ]);
	}
    }
    die "bad source list: no sources" unless @sources;
    print STDERR scalar(@sources)," sources found\n";
}

if (0) {
    print STDERR "SOURCES:\n";
    foreach my $s (@sources) {
	print STDERR join(',', 
		   map {"$_->$s->{$_}"} sort(keys(%$s)) ),"\n";
    }
}

# ok, now put ourselves in the background if that's what we're going to do
unless ($nofork) {
    # things we ought to do (according to perlipc):
    # open /dev/tty and TIOCNOTTY it
    # chdir("/");
    # reopen stdin,out,err so they're not connected to the old tty
    # background ourselves

    print STDERR "forking into background...\n";

    # for now, just do the last one. I'd like some error/debug messages to
    # have somewhere to go for a while, and the sockets might be relative
    # to the current directory.
    fork && exit(0);
}

sub add_entropy {
    my($data, $entropy) = @_;
    $pool_entropy += $entropy;
    # stir in data
    while(length($data)) {
	my $chunk = substr($data, 0, $DIGEST_SIZE);
	$pool ^= $chunk;
	stir();
	substr($data, 0, $DIGEST_SIZE) = "";
    }
}

$total_bytes_sucked = 0;

sub get_entropy {
    my($bytes) = @_;
    return "" unless $bytes;
    $total_bytes_sucked += $bytes;
    $pool_entropy -= $bytes * 8
      unless $bottomless;
    my $data = "";
    my $c = new SHA;
    my $left = $bytes;
    while ($left > 0) {
	stir();
	$c->reset();
	$c->add($pool);
	$data .= $c->digest();
	$left -= $DIGEST_SIZE;
    }
    return (substr($data, 0, $bytes));
}

sub stir {
    my $c = new SHA;
    for ($i = 0; $i < $POOLSIZE; $i += $DIGEST_SIZE) {
	$c->reset();
	$c->add($pool);
	my $d = $c->digest();
	substr($pool, $i, $DIGEST_SIZE) = substr($pool, $i, $DIGEST_SIZE) ^ $d;
    }
    print STDERR "pool: ",unpack("H*",$pool),"\n" if $debug_pool;
}

sub shutdown_thing {
    my($c) = @_;
    return unless $c->{'active'}; # skip duplicate shutdowns
    $c->{'active'} = 0;
    print STDERR "shutdown_thing($c)\n" if $debug_select;
    if ($c->{'type'} eq 'gatherer') {
	print STDERR "reaping pid ",$c->{'pid'}," source ",$c->{'source'},"\n"
	   if $debug_gather;
	kill 9, $c->{'pid'};
	waitpid($c->{'pid'},0); # portability check: &WNOHANG?
	# mark it as no longer in use
	$sources[$c->{'source'}]->{'inuse'} = 0;
	if ($?) {
	    # non-zero exit: error. Mark that source as non-usable
	    $sources[$c->{'source'}]->{'unusable'} = 1;
	    print STDERR " marked as nonusable, rc == $?\n" if $debug_gather;
	} elsif (!defined($c->{'incoming'}) or !length($c->{'incoming'})) {
	    # no stdout, probably all stderr, mark unusable
	    $sources[$c->{'source'}]->{'unusable'} = 1;
	    print STDERR " marked as nonusable, empty stdout\n" 
	      if $debug_gather;
	} else {
	    # add in the entropy from that source
	    #  possibly filter it first
	    if ($sources[$c->{'source'}]->{'filter'}) {
		print STDERR " filtered from ",length($c->{'incoming'}),
		  " bytes\n" if $debug_gather;
		$c->{'incoming'} =~ s/\D//g;
	    }
	    my $bytes = length($c->{'incoming'});
	    my $source = $sources[$c->{'source'}];
	    my $entropy = $bytes * $source->{'bpb'};
	    print STDERR " returned $bytes bytes, $entropy bits\n" 
	      if $debug_gather;
	    $entropy = $source->{'maxbits'}
	      if $entropy > $source->{'maxbits'};
	    print STDERR " accepted $entropy bits\n" if $debug_gather;
	    add_entropy($c->{'incoming'}, $entropy);
	    print STDERR scalar(@want_entropy)," clients want entropy\n"
	      if $debug_client;
	    foreach my $w (@want_entropy) {
		my $bytes = $w->{'wanted'};
		if ($bytes * 8 > $pool_entropy) {
		    $bytes = int($pool_entropy / 8);
		}
		$w->{'outgoing'} .= get_entropy($bytes);
		$w->{'wanted'} -= $bytes;
		if (!$w->{'wanted'}) {
		    # remove it from the want_entropy list
		    foreach my $w1 (0 .. $#want_entropy) {
			if ($w == $want_entropy[$w1]) {
			    # remove it
			    splice(@want_entropy, $w1, 1);
			    last;
			}
		    }
		}
	    }
	    if (@want_entropy) {
		# be fair: round-robin rotate those who want entropy
		my $w = shift(@want_entropy);
		push(@want_entropy, $w);
	    }
	}
	# remove it from the gatherers set
	foreach my $c1 (0 .. $#gatherers) {
	    if ($c == $gatherers[$c1]) {
		# remove it
		splice(@gatherers, $c1, 1);
		last;
	    }
	}
    } else {
	foreach my $c1 (0 .. $#clients) {
	    if ($c == $clients[$c1]) {
		# remove it
		splice(@clients, $c1, 1);
		last;
	    }
	}
    }
    $read_select->remove($c->{'fd'});
    $write_select->remove($c->{'fd'});
    $error_select->remove($c->{'fd'});
}

$quit_time = 0;
if ($quit_after) {
    $quit_time = time() + $quit_after * 60;
}
$refresh_time = time() + $REFRESH_TIME;

$read_select = new IO::Select;
$error_select = new IO::Select;

print STDERR "server starting\n";
foreach my $lsocket (@lsockets) {
    my $where = $lsocket->[0];
    my $s;
    if ($where =~ /^\d+$/) {
	print STDERR "listening on tcp socket at $where\n" if $debug_client;
	$s = new IO::Socket::INET (
				   'LocalAddr' => $where,
				   'Proto' => 'tcp',
				   'Listen' => 5,
				   'Timeout' => 0,
				   'Reuse' => 1,
				  );
    } elsif ($where =~ /:/) {
	print STDERR "listening on tcp socket port $where\n" if $debug_client;
	$s = new IO::Socket::INET (
				   'LocalPort' => $where,
				   'Proto' => 'tcp',
				   'Listen' => 5,
				   'Timeout' => 0,
				   'Reuse' => 1,
				  );
    } else {
	print STDERR "listening on unix socket at $where\n" if $debug_client;
	unlink($where);
	$s = new IO::Socket::UNIX (
				   'Type' => SOCK_STREAM,
				   'Local' => $where,
				   'Listen' => 1,
				  );
    }
    die "can't create socket $where : $!" unless $s;
    $s->listen or die("couldn't listen on socket $where : $!");
    $lsocket->[2] = $s;
    $read_select->add([$s, $lsocket]);# readable when new connections are made
    $error_select->add([$s, $lsocket]);
}


$SIG{'PIPE'} = 'IGNORE';

my $gathering = 0;
# main loop
while (1) {
    $write_select = new IO::Select; # replaces old one
    # read,error always have lsockets and all gatherers and clients
    foreach (@clients) {
	$write_select->add([$_->{'fd'}, $_]) if $_->{'outgoing'};
    }

    # determine if we need entropy. If so, we need to spawn off a gatherer.
    $gathering = 1 if $pool_entropy < $MIN_ENTROPY;
    $gathering = 0 if $pool_entropy > $MAX_ENTROPY;
    my $next_available; # if defined, sleep until this time for more sources
    # to become runnable again
    if ($gathering) {
	# choose a gatherer, fork it off, add the read fd to @gatherers
	# each gatherer gets a fixed amount of time to produce anything,
	# after which it is killed off. The @gatherers list is kept sorted
	# by expire time, and the next-to-expire gatherer is used to
	# determine the timeout for the select call
	if (@gatherers > $MAX_GATHERERS) {
	    print STDERR "throttling gatherers\n" if $debug_gather;
	    goto done_spawn;
	}
	my $start = $next_source;
	$next_source = ($next_source +1) % @sources;
	while ($sources[$next_source]->{'inuse'} # inuse
	       or $sources[$next_source]->{'unusable'} # unusable
	       or ($sources[$next_source]->{'last_started'} +
		   $sources[$next_source]->{'reuse'}) > time  # used too much
	      )
	{
	    $next_source = ($next_source +1) % @sources;
	    if ($next_source == $start) {
		# we've wrapped around. Nothing is available. If something is
		# running, don't spawn anything, assuming that we'll wake up
		# shortly. If nothing is, then we either have no sources (bad
		# but should be caught elsewhere) or we've used the sources too
		# much. In that case, arrange to sleep until one of the sources
		# becomes useable again.
		print STDERR "ran out of sources\n" if $debug_gather;
		if (@gatherers) {
		    goto done_spawn;
		}
		# find out how long we have to wait until we can run a new
		# source
		print STDERR " waiting for a source to become usable again\n" 
		  if $debug_gather;
		$next_source = ($next_source +1) % @sources;
		while ($next_source != $start) {
		    if (!$sources[$next_source]->{'unusable'}) {
			my $will_be_available = 
			  $sources[$next_source]->{'last_started'} +
			    $sources[$next_source]->{'reuse'};
			$next_available = $will_be_available
			  if (!defined($next_available) or
			      $will_be_available < $next_available);
		    }
		    $next_source = ($next_source +1) % @sources;
		}
		# If you are running EGD without any gatherers (i.e. just as
		# an entropy repository for data written in by clients
		# with the 0x03 write command), then remove this die(),
		# because you're ok with the lack of sources
		die "all sources are unusable. aborting.."
		  unless defined($next_available);
		print STDERR " next available is in ",
		  ($next_available - time()),"\n" if $debug_gather;
		goto done_spawn;
	    }
	}
	my $s = $next_source;
	my $g = { 'source' => $s,
		  # 'fd' filled in by open
		  # 'pid' filled in by fork
		  'expire' => time() + $sources[$s]->{'timeout'},
		  'type' => 'gatherer',
		  'active' => 1,
		};
	$sources[$s]->{'inuse'} = 1;
	$sources[$s]->{'last_started'} = time;
	my $fd = new IO::File;
	my $pid = $fd->open("-|");
	unless (defined $pid) {
	    # problem, not related to the particular command
	    die "bailing out, couldn't fork: $!";
	}
	if ($pid) {
	    # parent
	    $g->{'pid'} = $pid;
	    $g->{'fd'} = $fd;	# make this nonblocking
	    $read_select->add([$fd, $g]);
	    $error_select->add([$fd, $g]);
	} else {
	    # child
	    $SIG{'PIPE'} = 'IGNORE';
	    exec($sources[$s]->{'cmd'} . ' 2>/dev/null')
	      || exit(1);	#die "can't exec program: $!"; # not so noisy
	}
	push(@gatherers, $g);
	print STDERR "spawned src $s (",$sources[$s]->{'cmd'}
	  if $debug_gather;
	print STDERR ") at ",time(),", expire in ",$sources[$s]->{'timeout'}
	  if $debug_gather;
	print STDERR " at ",$g->{'expire'},", fd $fd\n" if $debug_gather;
      done_spawn:
    }

    # select on the set. The timeout is set to return one second after the
    # first gatherer is set to expire, or the refresh time, or the quit time,
    # whichever comes first.
    my $timeout = $refresh_time - time();
    $timeout = $quit_time - time() 
      if ($quit_time and $quit_time < $refresh_time);
    @gatherers = sort { $a->{'expire'} <=> $b->{'expire'} } @gatherers;
    if (@gatherers) {
	my $expire = $gatherers[0]->{'expire'} - time();
	print STDERR "gatherer ",$gatherers[0]->{'source'},
	  " is next to expire " if $debug_gather;
	print STDERR "in $expire secs\n" if $debug_gather;
	$timeout = $expire if $timeout > $expire;
    }
    if (defined($next_available)
	and ($next_available - time() < $timeout)) {
	$timeout = $next_available - time();
	print STDERR " next_available being used\n" if $debug_gather;
    }
    $timeout += 1;

    if ($debug_select) {
	print STDERR "select: r(",join(',',
				$read_select->handles()),"), ";
	print STDERR "w(",join(',',$write_select->handles()),"), ";
	print STDERR "e(",join(',',$error_select->handles()),"),";
	print STDERR "t=$timeout, entropy=$pool_entropy\n";
    }

    if ($debug) {
	print STDERR 
	  "e: $pool_entropy ($MIN_ENTROPY,$MAX_ENTROPY), g:$gathering";
	print STDERR " na:",$next_available - time()
	  if defined($next_available);
	print STDERR "\n";
    }

    # wait for input: blocks here until work can be done
    my($readable, $writable, $errorful) =
      IO::Select::select($read_select, $write_select, $error_select,
			 $timeout);
    if ($debug_select) {
	print STDERR " return: ";
	print STDERR "r(",$readable ? join(',',@$readable) : "nil","), ";
	print STDERR "w(",$writable ? join(',',@$writable) : "nil","), ";
	print STDERR "e(",$errorful ? join(',',@$errorful) : "nil","),";
	print STDERR "t=$timeout\n";
    }

    # if the quit time has arrived, quit
    if ($quit_time and time() > $quit_time) {
	exit(0);
    }

    # if we timed out, reduce the entropy count a little bit
    if (time() > $refresh_time) {
	print STDERR "timed out, decaying entropy\n" if $debug;
	$pool_entropy -= $DECAY if $pool_entropy > $DECAY;
	stir();
	$refresh_time = time() + $REFRESH_TIME
    }

    # then push out all the text we can
    foreach my $s (@$writable) {
	my $c = $s->[1];
	my $out = \$c->{'outgoing'};
	my $nwritten = syswrite($c->{'fd'}, $$out, length($$out));
	unless ($nwritten) {
	    print STDERR "error while writing, shutting down\n"
	      if $debug_select;
	    shutdown_thing($c);
	    next;
	}
	substr($$out,0,$nwritten) = "";
    }

    # now look for input from clients to get more work to do
    foreach my $s (@$readable) {
	if (grep {$s->[1] == $_} @lsockets) {
	    # a new connection: which lsocket?
	    my $l = $s->[1];
	    my $new = $s->[0]->accept;
	    if ($debug_client) {
		my $peer;
		if (ref($new) eq 'IO::Socket::INET') {
		    $peer = $new->peerhost() . ':' . $new->peerport();
		} elsif (ref($new) eq 'IO::Socket::UNIX') {
		    $peer = "some unix socket";#$new->peerpath();
		} else {
		    print STDERR "new client, but ref is ",ref($new),"\n";
		    $peer = "unknown";
		}
		print STDERR "new client from $peer on lsocket $l->[0]\n";
	    }
	    my $new_client = { 'fd' => $new, 'type' => 'client',
			       'canwrite' => $l->[1], 'active' => 1 };
	    push(@clients, $new_client);
	    $read_select->add([$new, $new_client]);
	    $error_select->add([$new, $new_client]);
	} else {
	    my $buf;
	    my $c = $s->[1];
	    unless(sysread($s->[0], $buf, 4096)) {
		# EOF
		shutdown_thing($c);
		next;
	    }
	    # gather the data
	    $c->{'incoming'} .= $buf;
	    if ($c->{'type'} eq 'client') {
		# examine a command from a client
		do_command($c);
	    } else {
		print STDERR "read ",length($buf)," bytes from gatherer ",
		  $c->{'source'},"\n" if $debug_gather;
	    }
	}
    }

    # now shut down the sockets for folks that have hung up, or gatherers
    # that have died
    foreach my $s (@$errorful) {
	if (grep {$s->[1] == $_} @lsockets) {	# is == the right test?
	    die "problem: lsocket had error\n";
	}
	# shut it down, kill it off, reap it
	print STDERR "shutting down errorful socket $s\n" if $debug_select;
	my $c = $s->[1];
	shutdown_thing($c);
    }

    # check to see if any gatherer ought to be expired
    my $now = time();
    my(@old) = grep { $_->{'expire'} < $now } @gatherers;
    foreach (@old) {
	# expire the sucker
	print STDERR "expiring source ",$_->{'source'},"\n" if $debug_gather;
	shutdown_thing($_);
    }
}

sub do_command {
    my($c) = @_;

    while ($c->{'incoming'}) {
	# check to see if there is a valid command in the input buffer
	my(@cmd) = unpack("C*", $c->{'incoming'});
	print STDERR ("do_command $c: 0x%02x\n",$cmd[0]) if $debug_client;
	print STDERR "total_bytes_sucked: $total_bytes_sucked\n"
	  if $debug_client;
	if ($cmd[0] == 0x00) {
	    # 1 byte
	    substr($c->{'incoming'}, 0, 1) = "";
	    $c->{'outgoing'} .= pack("N",$pool_entropy);
	} elsif ($cmd[0] == 0x01) {
	    last unless length($c->{'incoming'}) >= 2;
	    my $count = $cmd[1];
	    if ($cmd[1] * 8 > $pool_entropy) {
		$count = int($pool_entropy / 8);
	    }
	    print STDERR " wanted $cmd[1], given $count\n" if $debug_client;
	    $c->{'outgoing'} .= pack("C",$count) . get_entropy($count);
	    substr($c->{'incoming'}, 0, 2) = "";
	} elsif ($cmd[0] == 0x02) {
	    last unless length($c->{'incoming'}) >= 2;
	    $c->{'wanted'} = $cmd[1];
	    my $count = $c->{'wanted'};
	    if ($c->{'wanted'} * 8 > $pool_entropy) {
		$count = int($pool_entropy / 8);
	    }
	    $c->{'outgoing'} .= get_entropy($count);
	    substr($c->{'incoming'}, 0, 2) = "";
	    $c->{'wanted'} -= $count;
	    print STDERR "read blocked, they wait for $c->{'wanted'} bytes\n"
	      if $debug_client and $c->{'wanted'};
	    push(@want_entropy, $c) if $c->{'wanted'};
	} elsif ($cmd[0] == 0x03 and $c->{'canwrite'}) {
	    print STDERR "cmd: ",unpack("H*",$c->{'incoming'}),"\n"
	      if $debug_client;
	    last unless length($c->{'incoming'}) >= 4;
	    my($dummy,$bits,$bytes) = unpack("CnC", 
					     substr($c->{'incoming'},0,4));
	    last unless length($c->{'incoming'}) >= 4 + $bytes;
	    add_entropy(substr($c->{'incoming'},4,$bytes),$bits);
	    substr($c->{'incoming'}, 0, 4+$bytes) = "";
	} elsif ($cmd[0] == 0x04) {
	    my $pidstring = sprintf('%d',$$);
	    $c->{'outgoing'} .= pack("C",length($pidstring)) . $pidstring;
	    substr($c->{'incoming'}, 0, 1) = "";
	} else {
	    print STDERR "bogus client request $cmd[0]\n" if $debug;
	    $c->{'incoming'} = ""; # just in case
	    shutdown_thing($c);
	}
    }
}

__END__

notes:
 ways to get at the entropy:
  easiest is a unix or tcp socket, with a message protocol to say how much you
   want and to be told how much you are going to get
  next up is a named pipe
 ways to query/control:
  socket, messages
  socket, guile interpreter (silly..)
 try all entropy sources. if they cause errors, drop them from the list.
 message format:
 0x00 (get entropy level)
  0xMM (msb) 0xmm 0xll 0xLL (lsb)
 0x01 (read entropy nonblocking) 0xNN (bytes requested)
  0xMM (bytes granted) MM bytes
 0x02 (read entropy blocking) 0xNN (bytes desired)
  [block] NN bytes
 0x03 (write entropy) 0xMM 0xLL (bits of entropy) 0xNN (bytes of data) NN bytes
 0x04 (report PID)
  0xMM (length of PID string, not null-terminated) MM chars

todo:
 expiring a source should not cause it to be marked unusable, but it does 
  because $? after waitpid() is nonzero (SIGINT?)
 #each source should indicate a maximum frequency of use
advice from pgutmann library:
 some sources exit with non-zero exit codes and that is ok. Choose a minimum
 output size an use that as the criteria of whether the command succeeded or
 not.

 #source reuse timer
 #hush warning messages from gatherers (and errors)
 find a way to identify constant output from gatherers?
  have some per-source filters: #throw out everything but digits, compress
 find better gatherers
 verify security of use of SHA in stirring and reading pool
 scatter gatherers around a bit instead of letting them bunch up
 #if the socket is already in use and the daemon behind it seems to be working,
 # quit without error
 #allow a duration arg, after that many minutes just quit if there are no 
 # connected clients
 #add a 'get pid' command
 #add a --kill arg that gets a pid and kills that process

 #then for selftests, can run with --bottomless --quitafter 30 at start,
 # with --kill at end of tests. If desired, gpg can run --quitafter 30
 # automatically when it starts,

 #solaris-2.8, Irix 6.5.6: all gatherers fail?
 # select() marks pipes at EOF both readable and errorful, and we dropped the
 # errorful ones first. Switch to reap EOF before checking errorful ones,
 # don't mark gatherer unusable in that case.
