#!/usr/bin/perl
#
# Copyright (c) 2022-2026 SUSE LLC
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License version 2 as
# published by the Free Software Foundation.
#
# 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 (see the file COPYING); if not, write to the
# Free Software Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
#
################################################################

use Socket;
use POSIX;
use Fcntl qw(:DEFAULT :flock);
use Encode;
use bytes;
use File::Temp qw/tempdir/;
use File::Path qw/remove_tree/;
use Digest::SHA;

use strict;
use warnings;

my @allows;
my %map;
my $signhost = '127.0.0.1';
my $port = 5167;
my $sockproto = '';
my $signuser = '';
my $gpg = '/usr/bin/gpg';
my $phrases = '';
my $aliases = '';
my $encryptionkeys = '';
my $tmpdir = '/run/signd';
my $patchclasstime;
my $conf = '/etc/sign.conf';
my $allow_unprivileged_ports = 0;
my $use_unprivileged_ports = 0;
my $logfile;
my $pidfile = '/run/signd.pid';
my $use_agent;
my $agentsocket = [];
my $keycache = '';
my $use_gcrypt_sign;
my $use_gcrypt_privsign;
my $use_gcrypt_decrypt;
my $use_tpm_sign;
my $use_pkcs11_sign;
my $proxyport;
my $proxysockproto;
my $modulepath = '/usr/lib/signd';
my %modules;

my $testmode;
my @pinentrymode;
my $signaddr;

# request data
my $oldproto = 0;
my $peer = 'unknown';



##
## helper functions
##

sub ls {
  my ($dir) = @_;
  my $d;
  return () unless defined($dir) && opendir($d, $dir);
  my @d = grep {!/^\./} readdir($d);
  closedir($d);
  return sort(@d);
}

sub spew {
  my ($fn, $data) = @_;
  local *F;
  open(F, '>', $fn) || die("$fn: $!\n");
  (syswrite(F, $data) || 0) == length($data) || die("write error: $!\n");
  close(F) || die("close: $!\n");
}

sub slurp {
  my ($fn) = @_;
  my $fd;
  open($fd, '<', $fn) || die("$fn: $!\n");
  local $/;
  my $data = <$fd>;
  die("$fn: $!\n") unless defined $data;
  close $fd;
  return $data;
}

sub slurp_first_line {
  my ($fn) = @_;
  my $fd;
  open($fd, '<', $fn) || die("$fn: $!\n");
  my $data = <$fd>;
  die("$fn: $!\n") unless defined $data;
  close $fd;
  chomp $data;
  return $data;
}

sub printlog {
  my ($msg) = @_;
  my @lt = localtime(time);
  my $year = $lt[5] + 1900;
  my $month = $lt[4] + 1;
  printf "%04d-%02d-%02d %02d:%02d:%02d: %s\n", $year, $month, @lt[3,2,1,0], $msg;
}

sub create_tmpdir {
  my $tdir = tempdir('XXXXXXXX', DIR => $tmpdir, CLEANUP => 1);
  chmod 0700, $tdir;
  return $tdir;
}

# convert CIDR prefix to netmask array
sub calc_netmask {
  my $prefix = @_;
  my $mask  = (2 ** $prefix - 1) << (32 - $prefix);
  my @netmask = unpack( "C4", pack( "N", $mask ) );
  return @netmask;
}

# Check if an ip falls within a CIDR-style subnet
sub ip_in_network {
  my ($ip, $network) = @_;
  return 0 unless $network =~ /^([0-9\.]+)\/([0-9]+)$/;
  my @ip_a = split '\.', $ip;
  my @network_a = split '\.', "$1.0.0.0.0";
  my @netmask_a = unpack('C4', pack('N', 0xffffffff >> $2));
  for (my $i = 0; $i < 4; $i++) {
    return 0 if ($ip_a[$i] | $netmask_a[$i]) != ($network_a[$i] | $netmask_a[$i]);
  }
  return 1;
}

sub swrite {
  my ($sock, $data) = @_;
  local *S = $sock;
  while (length($data)) {
    my $l = syswrite(S, $data, length($data));
    die("write: $!\n") unless $l;
    $data = substr($data, $l);
  }
}

sub checkbadchar {
  my ($str, $what) = @_;
  die("bad character in $what\n") if $str =~ /[\000-\037]/;
  eval {
    Encode::_utf8_on($str);
    encode('UTF-8', $str, Encode::FB_CROAK);
  };
  die("$what is not utf-8\n") if $@;
}


##
## PGP functions (RFC 4880)
##

my $pgp_curve_nistp256 = "\x2a\x86\x48\xce\x3d\x03\x01\x07";
my $pgp_curve_nistp384 = "\x2b\x81\x04\x00\x22";
my $pgp_curve_ed25519  = "\x2b\x06\x01\x04\x01\xda\x47\x0f\x01";
my $pgp_curve_cv25519  = "\x2b\x06\x01\x04\x01\x97\x55\x01\x05\x01";

sub get_pgphashalgo {
  my ($hashalgo) = @_;
  $hashalgo = lc($hashalgo);
  return 2 if $hashalgo eq 'sha1';
  return 8 if $hashalgo eq 'sha256';
  return 10 if $hashalgo eq 'sha512';
  return undef;
}

sub decodetaglenoff {
  my ($pkg) = @_;
  my $tag = unpack('C', $pkg);
  die("not a pgp packet\n") unless $tag & 128;
  my ($len, $off);
  if ($tag & 64) {
    # new packet format
    $tag &= 63;
    $len = unpack('@1C', $pkg);
    if ($len < 192) {
      $off = 2;
    } elsif ($len >= 192 && $len < 224) {
      $len = unpack('@1n', $pkg) - 48960;
      $off = 3;
    } elsif ($len == 255) {
      $len = unpack('@2N', $pkg);
      $off = 6;
    }
  } else {
    # old packet format
    if (($tag & 3) == 0) {
      $len = unpack('C', substr($pkg, 1));
      $off = 2;
    } elsif (($tag & 3) == 1) {
      $len = unpack('n', substr($pkg, 1));
      $off = 3;
    } elsif (($tag & 3) == 2) {
      $len = unpack('N', substr($pkg, 1));
      $off = 5;
    }
    $tag = ($tag & 60) >> 2;
  }
  die("unsupported pgp packet length\n") unless defined $off;
  return ($tag, $len, $off);
}

sub decodepkg {
  my ($pkg) = @_;
  my $partial = '';
  if ((unpack('C', $pkg) & 0xc3) == 0x83) {
    return ((unpack('C', $pkg) & 60) >> 2, substr($pkg, 1), '');
  }
  while ((unpack('C', $pkg) & 0xc0) == 0xc0) {
    my $len = unpack('@1C', $pkg);
    last if $len < 224 || $len == 255;
    $len = 1 << ($len & 0x1f);
    die("truncated pgp packet\n") if length($pkg) < $len + 2;
    $partial .= substr($pkg, 2, $len);
    substr($pkg, 1, $len + 1, '');
  }
  my ($tag, $len, $off) = decodetaglenoff($pkg);
  return ($tag, $partial.substr($pkg, $off, $len), substr($pkg, $off + $len));
}

sub striptofirst {
  my ($pkg) = @_;
  my ($tag, $len, $off) = decodetaglenoff($pkg);
  return substr($pkg, 0, $off + $len);
}

sub encodetag {
  my ($tag, $pack) = @_;
  my $l = length($pack);
  return pack("CC", $tag + 192, $l).$pack if $l < 192;
  return pack("Cn", $tag + 192, $l + 48960).$pack if $l < 8384;
  return pack("CCN", $tag + 192, 255, $l).$pack;
}

sub encodetag_oldformat {
  my ($tag, $pack) = @_;
  my $l = length($pack);
  return pack("CC", $tag * 4 + 128, $l).$pack if $l < 256;
  return pack("Cn", $tag * 4 + 129, $l).$pack if $l < 65536;
  return pack("CN", $tag * 4 + 130, $l).$pack;
}

sub encodesubpackets {
  my $su = '';
  for (@_) {
    die("unsupported subpackage length\n") if length($_) >= 16320;
    $su .= pack('C', length($_)).$_ if length($_) < 192;
    $su .= pack('n', length($_) + 48960).$_ if length($_) >= 192;
  }
  return $su;
}

sub encodempi {
  my ($mpi) = @_;
  $mpi = substr($mpi, 1) while substr($mpi, 0, 1) eq "\0";
  my $first = unpack('C', $mpi);
  my $bits = 0;
  while ($first && ($first & 0x80) == 0) {
    $bits++;
    $first *= 2;
  }
  return pack('n', 8 * length($mpi) - $bits).$mpi;
}

sub priv2pub {
  my ($privkey, $info) = @_;
  my $pubkey = '';

  my ($tag, $len, $off) = decodetaglenoff($privkey);
  die("not a secret key packet\n") unless $tag == 5;
  my $pack = substr($privkey, $off, $len);
  my $pkver = unpack('C', $pack);
  my ($mpioff, $pkalgo);
  if ($pkver == 3) {
    (undef, undef, undef, $pkalgo) = unpack('CNnC', $pack);
    $mpioff = 8;
  } elsif ($pkver == 4) {
    (undef, undef, $pkalgo) = unpack('CNC', $pack);
    $mpioff = 6;
  }
  die("unknown public key version $pkver\n") unless $mpioff;
  $info->{'version'} = $pkver if $info;
  $info->{'algo'} = $pkalgo if $info;
  if ($pkalgo == 19 || $pkalgo == 22) {	# ECDSA + EdDSA have a curve
    my $oidlen = unpack('C', substr($pack, $mpioff));
    die("bad curve len") if $oidlen == 0 || $oidlen == 255;
    $info->{'curve'} = substr($pack, $mpioff + 1, $oidlen) if $info;
    $mpioff += $oidlen + 1;
  }
  my ($mpinum, $smpinum);
  ($mpinum, $smpinum) = (2, 4) if $pkalgo == 1;	# RSA
  ($mpinum, $smpinum) = (4, 1) if $pkalgo == 17;	# DSA
  ($mpinum, $smpinum) = (3, 1) if $pkalgo == 16 || $pkalgo == 20;	# Elgamal
  ($mpinum, $smpinum) = (1, 1) if $pkalgo == 19 || $pkalgo == 22;	# ECDSA + EdDSA
  die("unsupported public key algorithm $pkalgo\n") unless defined $mpinum;
  while ($mpinum > 0) {
    my $ml = unpack('n', substr($pack, $mpioff, 2));
    $ml = (($ml + 7) >> 3) + 2;
    push @{$info->{'mpis'}}, substr($pack, $mpioff + 2, $ml - 2) if $info;
    $mpioff += $ml;
    $mpinum--;
  }
  if ($info) {
    my $s2k = unpack('C', substr($pack, $mpioff, 1));
    if ($s2k == 0) {
      my $smpioff = $mpioff + 1;
      while ($smpinum > 0) {
	my $ml = unpack('n', substr($pack, $smpioff, 2));
	$ml = (($ml + 7) >> 3) + 2;
	push @{$info->{'smpis'}}, substr($pack, $smpioff + 2, $ml - 2);
	$smpioff += $ml;
	$smpinum--;
      }
    }
    $info->{'fingerprint'} = Digest::SHA::sha1_hex(pack('Cn', 0x99, $mpioff).substr($pack, 0, $mpioff)) if $pkver == 4;
  }
  return encodetag(6, substr($pack, 0, $mpioff));
}

sub patchclasstime {
  my ($sig, $t) = @_;
  die("classtime is not 10 hex nibbles\n") unless $t =~ /^[0-9a-fA-F]{10}$/s;
  my ($tag, $len, $off) = decodetaglenoff($sig);
  die("not a v3 signature\n") unless $tag == 2 && ord(substr($sig, $off, 1)) == 3;
  substr($sig, $off + 2, 5, pack('H*', $t));
  return $sig;
}

sub wrap_into_pgpsig_v3 {
  my ($extra, $fingerprint, $pgppubalgo, $pgphashalgo, $hash, $sigdata) = @_;
  my $v3sig = pack('CCH10H16CCH4', 3, 5, $extra, substr($fingerprint, -16), $pgppubalgo, $pgphashalgo, substr($hash, 0, 4)).$sigdata;
  return encodetag_oldformat(2, $v3sig);
}

sub wrap_into_pgpsig_v4 {
  my ($extra, $fingerprint, $pgppubalgo, $pgphashalgo, $hash, $sigdata) = @_;
  die("wrap_into_pgpsig_v4: bad fingerprint length\n") unless length($fingerprint) == 40;
  my $pubkeyversion = 4;
  my $hashedsub = encodesubpackets(pack('CCH*', 33, $pubkeyversion, $fingerprint), pack('CH*', 2, substr($extra, 2, 8)));
  my $unhashedsub = encodesubpackets(pack('CH*', 16, substr($fingerprint, -16)));
  my $v4sig = pack('CH2CC', 4, substr($extra, 0, 2), $pgppubalgo, $pgphashalgo);
  $v4sig .= pack('n', length($hashedsub)).$hashedsub;
  $v4sig .= pack('n', length($unhashedsub)).$unhashedsub;
  $v4sig .= pack('H4', substr($hash, 0, 4)).$sigdata;
  return encodetag_oldformat(2, $v4sig);
}

sub parse_protected_data_packet {
  my ($encodeddata) = @_;
  my ($tag, $pkg) = decodepkg($encodeddata);
  if ($tag == 18) {
    die("unsupported integrity protected data packet version\n") if unpack('C', substr($pkg, 0, 1, '')) != 1;
    return { 'method' => 'cfb', 'encrypted' => $pkg, 'mdc' => 1 };
  } elsif ($tag == 20) {
    my ($aead_version, $aead_cipher, $aead_algo, $aead_chunksize) = unpack('CCCC', substr($pkg, 0, 4, ''));
    die("unsupported aead protected data packet version\n") if $aead_version != 1;
    return { 'method' => 'aead', 'aead_cipher' => $aead_cipher, 'aead_algo' => $aead_algo, 'aead_chunksize' => $aead_chunksize, 'encrypted' => $pkg };
  }
  die("unsupported protected data packet $tag\n");
}

sub parse_encryted_data {
  my ($encodeddata) = @_;

  my ($tag, $len, $off) = decodetaglenoff($encodeddata);
  die("encrypted data does not start with a session packet\n") if $tag != 1;
  my $pkg = substr($encodeddata, $off, $len);
  my ($version, $keyid, $algo) = unpack('CH16C', $pkg);
  die("unsupported session packet version\n") unless $version == 3;
  my @mpis;
  my $mpinum;
  $mpinum = 1 if $algo == 1;
  $mpinum = 2 if $algo == 16;
  $mpinum = 1 if $algo == 18;
  die("unsupported encryption algorithm $algo\n") unless $mpinum;
  my $einfo = { 'algo' => $algo, 'keyid' => $keyid };
  my $mpioff = 10;
  while ($mpinum > 0) {
    my $ml = unpack('n', substr($pkg, $mpioff, 2));
    $ml = (($ml + 7) >> 3) + 2;
    push @{$einfo->{'mpis'}}, substr($pkg, $mpioff + 2, $ml - 2);
    $mpioff += $ml;
    $mpinum--;
  }
  if ($algo == 18) {
    my $ml = unpack('C', substr($pkg, $mpioff, 1));
    die("bad ecdh encoded key size\n") if $ml < 2 || $ml == 255;
    push @{$einfo->{'mpis'}}, substr($pkg, $mpioff, $ml + 1);
    $mpioff += $ml + 1;
  }
  die("truncated mpis\n") if length($pkg) < $mpioff;
  my $edata = parse_protected_data_packet(substr($encodeddata, $off + $len));
  return ($einfo, $edata);
}

sub parse_sym_encrypted_data {
  my ($encodeddata) = @_;

  my ($tag, $len, $off) = decodetaglenoff($encodeddata);
  die("encrypted data does not start with a symmetric session packet\n") if $tag != 3;
  my $pkg = substr($encodeddata, $off, $len);
  my ($version, $cipheralgo, $s2kmode) = unpack('CCC', $pkg);
  die("unsupported session packet version\n") unless $version == 4;
  die("unsupported s2k mode\n") unless $s2kmode== 3;
  die("symmetric session packet with session key\n") if $len > 2 + 11;
  my ($s2kalgo, $s2ksalt, $s2kcnt) = unpack('@3Ca8C', $pkg);
  my $einfo = { 'cipheralgo' => $cipheralgo, 's2kalgo' => $s2kalgo, 's2kcnt' => $s2kcnt, 's2ksalt' => $s2ksalt };
  my $edata = parse_protected_data_packet(substr($encodeddata, $off + $len));
  return ($einfo, $edata);
}

sub decode_decrypted_data {
  my ($decrypted) = @_;
  my ($tag, $pkg);
  ($tag, $pkg, $decrypted) = decodepkg($decrypted);
  if ($tag == 8) {
    my $compalgo = unpack('C', $pkg);
    die("unsupported compression algo $compalgo\n") unless $compalgo == 1 || $compalgo == 2;
    my ($compressed, $decompressed) = (substr($pkg, 1), '');
    my ($zlib, $status) = Compress::Raw::Zlib::Inflate->new(-WindowBits => $compalgo == 2 ? Compress::Raw::Zlib::MAX_WBITS() : -15, -Bufsize => 65536, -LimitOutput => 1);
    die("could not create zlib decompressor\n") unless $status == Compress::Raw::Zlib::Z_OK();
    die("decompression error\n") unless $zlib->inflate($compressed, $decompressed, 1) == Compress::Raw::Zlib::Z_STREAM_END();
    ($tag, $pkg, $decrypted) = decodepkg($decompressed.$decrypted);
  }
  die("not a single data packet\n") if $decrypted ne '';
  die("not a literal data packet\n") if $tag != 11;
  my ($fmt, $fnl) = unpack('CC', $pkg);
  die("not binary data\n") unless $fmt == 0x62;
  die("literal data packet is too small\n") unless length($pkg) >= 2 + $fnl + 4;
  return substr($pkg, 2 + $fnl + 4);
}

##
## gnupg agent functions
##

my $agent_sock;

sub find_agentsocket_with_gpgconf {
  $agentsocket = [];
  for (split("\n", `gpgconf --list-dirs </dev/null`)) {
    $agentsocket = [ $1 ] if /^agent-socket:(.*)/;
  }
  die("could not determine agent socket\n") unless @$agentsocket;
}

sub connect_to_agent {
  for my $s (@$agentsocket) {
    return 1 if -e $s && connect($agent_sock, sockaddr_un($s));
  }
  return 0;
}

sub start_agent {
  rungpg_fatal("/dev/null", undef, 'gpg-connect-agent', '/bye');
}

sub open_agent {
  undef $agent_sock;
  socket($agent_sock, PF_UNIX, SOCK_STREAM, 0) || die("socket: $!\n");
  if (!connect_to_agent()) {
    find_agentsocket_with_gpgconf();
    if (!connect_to_agent()) {
      start_agent();
      connect_to_agent() || die("connect to agent @$agentsocket: $!\n");
    }
  }
  agent_rpc();	# read greeting
}

sub close_agent {
  close($agent_sock) if defined $agent_sock;
  undef $agent_sock;
}

sub agent_rpc {
  my ($cmd, $phrasefile) = @_;
  open_agent() unless defined $agent_sock;
  my $data = '';
  my $error;
  eval {
    swrite($agent_sock, "$cmd\n") if defined $cmd;
    my $res = '';
    while (1) {
      while ($res !~ /(.*?)\n/) {
	my $r = sysread($agent_sock, $res, 4096, length($res));
	die("read: $!\n") unless defined $r;
	die("unexpected EOF\n") unless $r;
      }
      die unless $res =~ /(.*?)\n/;
      my $line = $1;
      $res = substr($res, length($line) + 1);
      next if $line =~ /^#/;
      next if $line =~ /^S/;
      last if $line =~ /^OK/;
      if ($line =~ /^ERR ?(.*)/) {
	$error = $1;
	last;
      }
      if ($line =~ /^D /) {
	$line =~ s/%([a-fA-F0-9]{2})/chr(hex($1))/sge;
	$data .= substr($line, 2);
	next;
      }
      if ($line eq 'INQUIRE PASSPHRASE') {
	die("unknown passphrase\n") unless defined $phrasefile;
	my $passphrase = slurp_first_line($phrasefile);
	$passphrase =~ s/([^a-zA-Z0-9])/sprintf("%%%02X",ord($1))/sge;
	my $msg = "D $passphrase\nEND\n";
	syswrite($agent_sock, $msg) == length($msg) || die("syswrite: $!\n");
	next;
      }
      die("unsupported answer from gpg-agent\n");
    }
  };
  if ($@) {
    close_agent();
    die($@);
  }
  die("gpg-agent: $error\n") if defined $error;
  return $data;
}


##
## sexp support (used in agent)
##

sub parse_sexp {
  my ($l) = @_;
  my @l;
  die("sexp does not start with '('\n") unless substr($l, 0, 1, '') eq '(';
  while (substr($l, 0, 1) ne ')') {
    if (substr($l, 0, 1) eq '(') {
      push @l, parse_sexp($l);
      $l = pop(@l);
    } elsif ($l =~ /^(\d+):/) {
      my $cnt = $1;
      substr($l, 0, length($cnt) + 1, '');
      push @l, substr($l, 0, $cnt, '');
    } elsif ($l =~ /^([0-9a-zA-Z\-\.\/_:*+=]+)/) {
      push @l, substr($l, 0, length($1), '');
      $l =~ s/^ //;
    } else {
      die("unterminated sexp\n") if $l eq '';
      die("unsupported sexp: ".substr($l, 0, 1)."\n");
    }
  }
  return \@l, substr($l, 1);
}

sub find_in_sexp_rec {
  my ($l, $lit) = @_;
  return @$l if @$l && $l->[0] eq $lit;
  for (@$l) {
    next unless ref($_) eq 'ARRAY';
    my @r = find_in_sexp_rec($_, $lit);
    return @r if @r;
  }
  return ();
}

sub find_in_sexp {
  my ($l, $lit) = @_;
  my (undef, $d) = find_in_sexp_rec($l, $lit);
  die("could not find $lit\n") unless defined $d;
  return $d;
}

sub parse_sexp_signature {
  my ($sig) = @_;
  ($sig) = parse_sexp($sig);
  my $sigval = find_in_sexp($sig, 'sig-val');
  my $algo = $sigval->[0];
  if ($algo eq 'rsa') {
    return (1, find_in_sexp($sigval, 's'));
  } elsif ($algo eq 'dsa') {
    return (17, find_in_sexp($sigval, 'r'), find_in_sexp($sigval, 's'));
  } elsif ($algo eq 'ecdsa') {
    return (19, find_in_sexp($sigval, 'r'), find_in_sexp($sigval, 's'));
  } elsif ($algo eq 'eddsa') {
    return (22, find_in_sexp($sigval, 'r'), find_in_sexp($sigval, 's'));
  }
  die("parse_sexp_signature: unsupported algo $algo\n");
}


##
## gnupg functions
##

sub switch_gnupghome {
  my ($gnupghome) = @_;
  close_agent();
  $agentsocket = [];
  $ENV{'GNUPGHOME'} = $gnupghome;
}

sub prepare_tmp_gnupghome {
  my $tdir = create_tmpdir();
  mkdir("$tdir/gnupg", 0700) || die("mkdir $tdir/gnupg: $!\n");
  return ($tdir, "$tdir/gnupg", $ENV{'GNUPGHOME'});
}

sub rungpg_cleanup {
  my ($unlinks) = @_;
  return unless defined $unlinks;
  if (ref($unlinks) eq 'ARRAY') {
    unlink($_) for @{$unlinks || []};
  } elsif (-d $unlinks) {
    remove_tree($unlinks);
  }
}

sub rungpg {
  my ($stdin, $unlinks, $prg, @args) = @_;

  local *RH;
  local *WH;
  local *KID;

  pipe RH, WH;
  my $pid = open(KID, "-|");
  if (!defined $pid) {
    rungpg_cleanup($unlinks) if $unlinks;
    die("could not fork: $!\n");
    exit(0);
  }
  if (!$pid) {
    delete $SIG{'__DIE__'};
    close RH;
    if (!open(STDERR, ">&STDOUT")) {
      print STDOUT "can't dup stdout: $!\n";
      exit(1);
    }
    open(STDOUT, ">&WH") || die("can't dup writepipe: $!\n");
    open(STDIN, "<$stdin") || die("$stdin: $!\n");
    close WH;
    exec $prg, @args;
    die("$prg: $!\n");
  }
  close WH;
  my $out = '';
  my $err = '';
  1 while sysread(KID, $err, 4096, length($err)) > 0;
  1 while sysread(RH, $out, 4096, length($out)) > 0;
  close(RH);
  my $status = 0;
  $status = $? || 255 unless close KID;
  $status >>= 8 if $status >= 256;
  return ($status, $out, $err);
}

sub rungpg_fatal {
  my ($stdin, $unlinks, $prg, @args) = @_;
  my ($status, $out, $err) = rungpg($stdin, $unlinks, $prg, @args);
  if ($status) {
    $err = "Error $status" if $err eq '';
    $err =~ s/\n$//s;
    rungpg_cleanup($unlinks) if $unlinks;
    die("$err\n");
  }
  return $out;
}

sub find_key {
  my ($user, $purpose) = @_;
  $purpose ||= 's';
  $purpose = qr/$purpose/;
  my $lines = rungpg_fatal('/dev/null', undef, $gpg, '--locate-key', '--with-fingerprint', '--with-keygrip', '--with-colons', '--', $user);
  my $fpr;
  my $grp;
  my $keyid;
  $keyid = lc(substr($user, -16)) if $purpose eq 's' && $user =~ /^[0-9a-fA-f]{8,}$/;
  my $key;
  for my $line (split("\n", $lines)) {
    next unless $line =~ /^(?:pub|sub|fpr|grp)/;
    my @s = split(':', $line);
    if ($s[0] eq 'pub' || $s[0] eq 'sub') {
      last if $s[0] eq 'pub' && $fpr && $grp;	# first matching pubkey wins
      undef $key;
      next unless $s[11] =~ /$purpose/;
      next if $keyid && $s[4] !~ /\Q$keyid\E$/i;
      $key = $line;
      undef $fpr;
      undef $grp;
    } elsif ($s[0] eq 'fpr') {
      $fpr = $s[9] if $key;
    } elsif ($s[0] eq 'grp') {
      $grp = $s[9] if $key;
    }
  }
  return (undef, undef) unless $grp && $fpr;
  return (uc($fpr), uc($grp));
}

sub read_keycache {
  my ($user) = @_;
  my ($fd, $fpr, $grp, $rid);
  if (open($fd, '<', "$keycache/$user")) {
    while(<$fd>) {
      chomp; 
      $fpr = $1 if /^fpr:(\S+)/;
      $grp = $1 if /^grp:(\S+)/;
      $rid = $1 if /^rid:(\S+)/;
    }
    close($fd);
  }
  return ($fpr, $grp, $rid) if $fpr && $grp && $rid;
  return (undef, undef, undef);
}

sub write_keycache {
  my ($user, $fpr, $grp, $rid) = @_;
  mkdir($keycache, 0700) unless -d $keycache;
  my $fd;
  if (open($fd, '>', "$keycache/.$user.$$")) {
    if (print $fd "fpr:$fpr\ngrp:$grp\nrid:$rid\n") {
      close($fd) && rename("$keycache/.$user.$$", "$keycache/$user");
    } else {
      close($fd);
    }
    unlink("$keycache/.$user.$$");
  }
}

sub disable_keycache {
  undef $keycache;
}

sub find_key_keycache {
  my ($user, $purpose) = @_;
  $purpose ||= 's';
  return find_key($user, $purpose) if !$keycache;
  my $gnupghome = $ENV{GNUPGHOME};
  if (!$gnupghome) {
    my $home = $ENV{HOME} || (getpwuid($<))[7];
    $gnupghome = "$home/.gnupg" if $home;
  }
  return find_key($user, $purpose) unless $gnupghome;
  my @s = stat("$gnupghome/pubring.kbx");
  @s = stat("$gnupghome/pubring.gpg") unless @s;
  return find_key($user, $purpose) unless @s;
  my $srid = "$s[9]/$s[7]/$s[1]";
  my ($fpr, $grp, $rid) = read_keycache("$purpose-$user");
  return ($fpr, $grp) if $fpr && $grp && $rid && $rid eq $srid;
  ($fpr, $grp) =  find_key($user, $purpose);
  write_keycache("$purpose-$user", $fpr, $grp, $srid) if $fpr && $grp;
  return ($fpr, $grp);
}

sub have_pinentry_mode {
  my ($status) = rungpg('/dev/null', undef, $gpg, '--pinentry-mode=loopback', '--version');
  return !$status;
}

sub have_files_are_digests {
  my ($status) = rungpg('/dev/null', undef, $gpg, '--files-are-digests', '--version');
  return !$status;
}

sub parse_gpg_kv {
  my %kv;
  my $lastkey;
  for my $l (split(/[\r\n]+/, $_[0])) {
    if (defined($lastkey) && ($l eq '' || $l =~ /^[ \t]/)) {
      # continuation
      $l =~ s/^[ \t]//;
      $l =~ s/[ \t]+$//;
      $l =~ s/^[ \t]+// if $kv{$lastkey} =~ /\n\z/s;
      $l = "\n" if $l eq '';
      $kv{$lastkey} .= $l;
      next;
    }
    undef $lastkey;
    $l =~ s/^[ \t]*//;
    if ($l =~ /^([^ \t]+):[ \t]?(.*)/) {
      $lastkey = $1;
      $kv{$lastkey} = $2;
    } elsif ($l ne '' && $l !~ /^#/) {
      die("bad line: $l\n");
    }
  }
  return %kv;
}

sub gpg_privkey_to_info {
  my ($key) = @_;
  my $sexp = Crypt::GCrypt::Sexp->new($key);
  die("could not parse private key sexp\n") unless defined $sexp;
  my $pk = $sexp->nth(1, 'private-key');
  my $is_shadowed;
  if (!defined($pk)) {
    $pk = $sexp->nth(1, 'shadowed-private-key');
    die("sexp is not an unprotected private key\n") unless defined $pk;
    $is_shadowed = 1;
  }
  my $type = $pk->nth_data(0) || '?';
  my $info;
  if ($type eq 'rsa') {
    $info = {'algo' => 1, 'mpis' => ['n', 'e'], 'smpis' => ['d', 'p', 'q', 'u']};
  } elsif ($type eq 'elg') {
    $info = {'algo' => 16, 'mpis' => ['p', 'g', 'y'], 'smpis' => ['x']};
  } elsif ($type eq 'dsa') {
    $info = {'algo' => 17, 'mpis' => ['p', 'q', 'g', 'y'], 'smpis' => ['x']};
  } elsif ($type eq 'ecc') {
    $info = {'algo' => 19, 'mpis' => ['q'], 'smpis' => ['d']};
    my $curve = $pk->nth_data(1, 'curve') || '?';
    $info->{'curve'} = $pgp_curve_ed25519 if $curve eq 'Ed25519';
    $info->{'curve'} = $pgp_curve_cv25519 if $curve eq 'Curve25519';
    $info->{'curve'} = $pgp_curve_nistp256 if $curve eq 'NIST P-256';
    $info->{'curve'} = $pgp_curve_nistp384 if $curve eq 'NIST P-384';
    die("unsupported ecc curve $curve\n") unless $info->{'curve'};
    $info->{'algo'} = 18 if $curve eq 'Curve25519';
    $info->{'algo'} = 22 if $curve eq 'Ed25519';
  }
  die("unsupported private key type $type\n") unless $info;
  delete $info->{'smpis'} if $is_shadowed;
  for (@{$info->{'mpis'}}, @{$info->{'smpis'} || []}) {
    $_ = $pk->nth_data(1, $_);
    die("missing mpi in privkey\n") unless $_;
  }
  if ($is_shadowed) {
    my $stype = $pk->nth_data(1, 'shadowed');
    die("missing shadowed data in shadowed-private-key\n") unless $stype;
    die("unsupported shadowed data type in shadowed-private-key\n") unless $stype eq 'tpm2-v1';
    my $spk = $pk->nth(2, 'shadowed');
    die("missing tpm2-v1 data in shadowed-private-key\n") unless $spk;
    $info->{'shadowed-tpm2-v1'} = [ map { $spk->nth_data($_) } (0, 1, 2) ] ;
  }
  return $info;
}

sub gpg_keygrip_to_info {
  my ($gnupghome, $keygrip, $fingerprint) = @_;
  return undef unless $gnupghome && $keygrip;
  my $keyfile = "$gnupghome/private-keys-v1.d/$keygrip.key";
  return undef unless -s $keyfile;
  my $kfd;
  return undef unless open($kfd, '<', $keyfile);
  my $key = '';
  1 while length($key) < 65536 && sysread($kfd, $key, 4096, length($key)) > 0;
  close($kfd);
  return undef if length($key) >= 65536;
  my $info;
  eval {
    if (substr($key, 0, 1) ne '(') {
      my %kv = parse_gpg_kv($key);
      $key = $kv{'Key'};
      die("no 'Key' element in privkey?\n") unless $key;
    }
    $info = gpg_privkey_to_info($key);
  };
  $info->{'keygrip'} = $keygrip if $info;
  $info->{'fingerprint'} = $fingerprint if $info && $fingerprint;
  return $info;
}


##
## project key encryption/decryption
##

sub do_decode_gpg {
  my ($phrasefile, $encodeddata) = @_;
  my $file = "$tmpdir/privkey.$$";
  spew($file, $encodeddata);
  my $decoded = rungpg_fatal($phrasefile, [ $file ], $gpg, '--batch', '--decrypt', '--max-output', '65536', '--no-verbose', '-q', '--no-secmem-warning', @pinentrymode, '--passphrase-fd=0', $file);
  unlink($file);
  return $decoded;
}

sub do_encode_gpg {
  my ($user, $data, $tdir) = @_;
  my $file = $tdir ? "$tdir/privkey" : "$tmpdir/privkey.$$";
  spew($file, $data);
  my $encodeddata = rungpg_fatal('/dev/null', $tdir || [ $file ], $gpg, '--batch', '--encrypt', '--no-verbose', '--no-secmem-warning', '--trust-model', 'always', '-o-', '-r', $user, $file);
  unlink($file);
  return $encodeddata;
}

sub do_decode_gcrypt {
  my ($encodeddata) = @_;
  my $gnupghome = $ENV{'GNUPGHOME'};
  return undef unless $gnupghome;
  my ($einfo, $edata) = parse_encryted_data($encodeddata);
  return undef unless $einfo && $edata && $use_gcrypt_decrypt && can_decrypt_with_gcrypt($einfo, $edata);
  my ($fingerprint, $keygrip) = find_key_keycache($einfo->{'keyid'}, 'e');
  my $info = gpg_keygrip_to_info($gnupghome, $keygrip, $fingerprint);
  return undef unless $info && $info->{'smpis'};
  my $decrypted = decrypt_with_gcrypt($info, $einfo, $edata);
  return decode_decrypted_data($decrypted);
}

sub read_encparams_sym {
  my ($phrasefile, $keyid, $withsecret) = @_;
  die("malformed encryption key $keyid\n") unless $keyid =~ /^[0-9A-F]{16}$/s;
  die("unknown encryption key $keyid\n") unless $phrasefile && -s $phrasefile;
  my $params = slurp_first_line($phrasefile);
  my $secret = $withsecret ? $params : undef;
  die("bad encryption key $keyid\n") unless $params =~ /^(?:[0-9a-f][0-9a-f])+$/s;
  $params = pack('H*', $params);
  # 1:01|4:created|1:s2kalgo|1:s2kcnt|1:cipheralgo|8:keyid|56:random
  die("bad encryption key $keyid\n") unless length($params) == 72;
  my ($version, $created, $s2kalgo, $s2kcnt, $cipheralgo, $xkeyid) = unpack('CNCCCH16', $params);
  die("bad encryption key $keyid\n") unless $version == 1 && $s2kcnt != 0 && $xkeyid eq lc($keyid);
  my $info = { 'version' => $version, 'created' => $created, 's2kalgo' => $s2kalgo, 's2kcnt' => $s2kcnt, 'cipheralgo' => $cipheralgo };
  $info->{'secret'} = $secret if $secret;
  return $info;
}

sub do_decode_sym {
  my ($encodeddata) = @_;
  # 1:01|8:keyid|1:xdatalen|?:xdata|8:salt|2:edatalength|?:edata
  die("bad encoded data\n") if length($encodeddata) < 10;
  my ($version, $keyid, $xdl) = unpack('CH16C', $encodeddata);
  die("bad encoded data\n") if $version != 1 || length($encodeddata) < 10 + $xdl + 2 + 8;
  $keyid = uc($keyid);
  my $phrasefile =  $encryptionkeys ? "$encryptionkeys/$keyid" : undef;
  my $withsecret = $use_gcrypt_decrypt ? 1 : 0;
  my $info = read_encparams_sym($phrasefile, $keyid, $withsecret);
  my $file = "$tmpdir/privkey.$$";
  my $edata = substr($encodeddata, 10 + $xdl);
  die("truncated encoded data\n") if unpack('@8n', $edata) != length($edata) - 10;
  my $s2ksalt = substr($edata, 0, 8);
  $edata = { 'method' => 'cfb', 'encrypted' => substr($edata, 10), 'mdc' => 1 };
  if ($use_gcrypt_decrypt && can_decrypt_sym_with_gcrypt($info, $edata)) {
    return decrypt_sym_with_gcrypt($info, $s2ksalt, $edata);
  }
  # create gpg symmetric session and integrity proteced encrypted data packets
  $encodeddata = encodetag(3, pack('CCCCa8C', 4, $info->{'cipheralgo'}, 3, $info->{'s2kalgo'}, $s2ksalt, $info->{'s2kcnt'}));
  $encodeddata .= encodetag(18, pack('C', 1).$edata->{'encrypted'});
  spew($file, $encodeddata);
  my $decoded = rungpg_fatal($phrasefile, [ $file ], $gpg, '--batch', '--decrypt', '--max-output', '65536', '--no-verbose', '-q', '--no-secmem-warning', '--passphrase-fd=0', $file);
  unlink($file);
  return $decoded;
}

sub do_encode_sym {
  my ($keyid, $data, $tdir, $xdata) = @_;
  $xdata = '' unless defined $xdata;
  die("bad xdata length\n") if length($xdata) > 255;
  my $phrasefile =  $encryptionkeys ? "$encryptionkeys/$keyid" : undef;
  my $info = read_encparams_sym($phrasefile, $keyid);
  die("unsupported s2kalgo\n") unless $info->{'s2kalgo'} == 10;
  die("unsupported cipheralgo \n") unless $info->{'cipheralgo'} == 9;
  my $s2kcntarg = (16 + ($info->{'s2kcnt'} & 0x0f)) << (6 + (($info->{'s2kcnt'} >> 4) & 0x0f));
  my $file = $tdir ? "$tdir/privkey" : "$tmpdir/privkey.$$";
  spew($file, $data);
  my $encodeddata = rungpg_fatal($phrasefile , $tdir || [ $file ], $gpg, '--batch', '--symmetric', '--no-verbose', '--no-secmem-warning', '--passphrase-fd=0', '--s2k-mode=3', '--s2k-cipher-algo=aes256', '--s2k-digest-algo=sha512', "--s2k-count=$s2kcntarg", '--compress-algo=zlib', '-o-', $file);
  unlink($file);
  # parse and verify gpg encoded data packets and transcode to our own format
  my ($einfo, $edata) = parse_sym_encrypted_data($encodeddata);
  die("gpg encrypted data does not match encryption parameters\n") if $info->{'cipheralgo'} != $einfo->{'cipheralgo'} || $info->{'s2kalgo'} != $einfo->{'s2kalgo'} || $info->{'s2kcnt'} != $einfo->{'s2kcnt'};
  my $encrypted = $edata->{'encrypted'};
  die("unexpected gpg encrypted data\n") if $edata->{'method'} ne 'cfb' || !$edata->{'mdc'} || length($einfo->{'s2ksalt'}) != 8 || length($encrypted) > 65535;
  return pack('CH16C', 1, $keyid, length($xdata)).$xdata.$einfo->{'s2ksalt'}.pack('n', length($encrypted)).$encrypted;
}

sub do_keygen_sym {
  die("encryptionkeys directory not configured\n") unless $encryptionkeys;
  my $random = rungpg_fatal('/dev/null', undef, $gpg, '--gen-random', '2', '64');
  die("random generation failed\n") unless length($random) == 64;
  my $keyid = uc(unpack('H16', $random));
  die("keyid $keyid already exists, please try again\n") if -e "$encryptionkeys/$keyid";
  my $created = time();
  my $param = pack('CNCCC', 1, $created, 10, 1, 9).$random;
  # the gpg passphrase limit is 255 bytes, so our 144 bytes are good
  spew("$encryptionkeys/.$keyid$$", unpack('H*', $param)."\n");
  if (!link("$encryptionkeys/.$keyid$$", "$encryptionkeys/$keyid")) {
    my $error = "link $encryptionkeys/.$keyid$$ $encryptionkeys/$keyid: $!\n";
    unlink("$encryptionkeys/.$keyid$$");
    die($error);
  }
  unlink("$encryptionkeys/.$keyid$$");
  return $keyid;
}

sub do_decode {
  my ($phrasefile, $user, $encodeddata) = @_;

  return do_decode_sym($encodeddata) if unpack('C', $encodeddata) < 128;
  if ($use_gcrypt_decrypt) {
    my $have_phrase = defined($phrasefile) && $phrasefile ne '/dev/null' && -s $phrasefile;
    if (!$have_phrase) {
      my $decoded = eval { do_decode_gcrypt($encodeddata) };
      warn($@) if $@;
      return $decoded if defined $decoded;
    }
  }
  return do_decode_gpg($phrasefile, $encodeddata);
}

sub do_encode {
  my ($user, $data, $tdir, $xdata) = @_;
  return do_encode_sym($user, $data, $tdir, $xdata) if $encryptionkeys && $user =~ /^[0-9A-F]{16}$/ && -s "$encryptionkeys/$user";
  return do_encode_gpg($user, $data, $tdir);
}


##
## signature generation
##

sub sign_with_agent {
  my ($phrasefile, $user, $fingerprint, $keygrip, $hashalgo, $hash, $isprivsign, $replyv4) = @_;
  if (!$fingerprint) {
    ($fingerprint, $keygrip) = $isprivsign ? find_key($user) : find_key_keycache($user);
    die("unknown pubkey for $user\n") unless $fingerprint;
  }
  die("bad hash $hash\n") unless $hash =~ /^((?:[0-9a-fA-F][0-9a-fA-F])+)\@(0[01][0-9a-fA-F]{8})$/;
  my $extra = $2;
  $hash = uc($1);
  my $pgphashalgo = get_pgphashalgo($hashalgo);
  die("sign_with_agent: bad hashalgo $hashalgo\n") unless $pgphashalgo;
  my $have_phrase = defined($phrasefile) && $phrasefile ne '/dev/null' && -s $phrasefile;
  agent_rpc("SIGKEY $keygrip");
  agent_rpc("SETHASH $pgphashalgo $hash");
  agent_rpc("OPTION pinentry-mode=loopback") if $have_phrase;
  my $sigsexp = agent_rpc("PKSIGN", $phrasefile);
  my ($pgppubalgo, @mpis) = parse_sexp_signature($sigsexp);
  my $sigdata = join('', map {encodempi($_)} @mpis);
  return wrap_into_pgpsig_v4($extra, $fingerprint, $pgppubalgo, $pgphashalgo, $hash, $sigdata) if $replyv4;
  return wrap_into_pgpsig_v3($extra, $fingerprint, $pgppubalgo, $pgphashalgo, $hash, $sigdata);
}

sub sign_with_files_are_digests {
  my ($phrasefile, $user, $hashalgo, $hash, $isprivsign, $replyv4) = @_;
  my @args;
  if ($isprivsign) {
    push @args, '--allow-non-selfsigned-uid';
  } else {
    push @args, '-u', $user;
  }
  my $classtime;
  if ($patchclasstime && !$replyv4 && ($hash =~ /\@([0-9a-fA-F]{10})$/s)) {
    $classtime = $1;
    substr($hash, -10, 10, '0000000000');
  }
  my @force_v3_sigs;
  push @force_v3_sigs, "--force-v3-sigs" unless $replyv4;
  my ($status, $out, $err) = rungpg($phrasefile, undef, $gpg, "--batch", @force_v3_sigs, "--files-are-digests", "--digest-algo=$hashalgo", "--no-verbose", "--no-armor", "--no-secmem-warning", "--ignore-time-conflict", @pinentrymode, "--passphrase-fd=0", @args, "-sbo", "-", $hash);
  $out = patchclasstime($out, $classtime) if $classtime && !$status;
  return ($status, $out, $err);
}

sub do_sign_multiple {
  my ($phrasefile, $user, $info, $hashalgo, $hashes, $isprivsign) = @_;

  $info = {'opensslkey' => 1, 'user' => $1 } if !$info && $user =~ /^openssl:(.+)/;

  my ($fingerprint, $keygrip);
  if (!$info && $use_agent) {
    ($fingerprint, $keygrip) = $isprivsign ? find_key($user) : find_key_keycache($user);
    die("unknown pubkey for $user\n") unless $fingerprint;
  }
  if (!$info && ($use_gcrypt_sign || $use_tpm_sign || $use_pkcs11_sign) && $fingerprint && $keygrip) {
    my $have_phrase = defined($phrasefile) && $phrasefile ne '/dev/null' && -s $phrasefile;
    $info = gpg_keygrip_to_info($ENV{'GNUPGHOME'}, $keygrip, $fingerprint) unless $have_phrase && !($use_tpm_sign || $use_pkcs11_sign);
    undef $info if $info && $info->{'smpis'} && !$use_gcrypt_sign;
    undef $info if $info && $info->{'shadowed-tpm2-v1'} && $info->{'shadowed-tpm2-v1'}->[0] ne 'pkcs11' && !$use_tpm_sign;
    undef $info if $info && $info->{'shadowed-tpm2-v1'} && $info->{'shadowed-tpm2-v1'}->[0] eq 'pkcs11' && !$use_pkcs11_sign;
  }
  $info->{'will_sign_multiple'} = 1 if $info && @$hashes > 1;
  my ($status, $err, @out) = (0, '');
  for my $hash (@$hashes) {
    my $replyv4 = 0;
    $replyv4 = 1 if $hash =~ /^(?:04040404)+\@/;	# special v4 algo probe
    my ($lout, $lerr) = ('', '');
    if ($info && $info->{'opensslkey'}) {
      die("openssl module not loaded\n") unless $modules{'openssl'};
      $lout = eval { sign_with_openssl($phrasefile, $info, $hash, $hashalgo, $replyv4) };
      ($status, $lout, $lerr) = (1, '', $@) if $@;
    } elsif ($info && $use_gcrypt_sign && can_sign_with_gcrypt($info)) {
      $lout = eval { sign_with_gcrypt($info, $hash, $hashalgo, $replyv4) };
      ($status, $lout, $lerr) = (1, '', $@) if $@;
    } elsif ($info && $use_tpm_sign && can_sign_with_tpm($info)) {
      $lout = eval { sign_with_tpm($phrasefile, $info, $hash, $hashalgo, $replyv4) };
      ($status, $lout, $lerr) = (1, '', $@) if $@;
    } elsif ($info && $use_pkcs11_sign && can_sign_with_pkcs11($info)) {
      $lout = eval { sign_with_pkcs11($phrasefile, $info, $hash, $hashalgo, $replyv4) };
      ($status, $lout, $lerr) = (1, '', $@) if $@;
    } elsif ($use_agent) {
      $lout = eval { sign_with_agent($phrasefile, $user, $fingerprint, $keygrip, $hashalgo, $hash, $isprivsign, $replyv4) };
      ($status, $lout, $lerr) = (1, '', $@) if $@;
    } else {
      ($status, $lout, $lerr) = sign_with_files_are_digests($phrasefile, $user, $hashalgo, $hash, $isprivsign, $replyv4);
    }
    push @out, $lout;
    $err .= $lerr;
    last if $status;
  }
  return ($status, $err, @out);
}


##
## request handling
##

sub readreq {
  my @argv;
  my $pack = '';
  sysread(CLNT, $pack, 1024);
  die("zero size packet\n") if length($pack) == 0;
  die("packet too small\n") if length($pack) < 4;
  my ($userlen, $arg) = unpack("nn", $pack);
  while (length($pack) < 4 + $userlen + $arg) {
    sysread(CLNT, $pack, 1024, length($pack)) || die("packet read error\n");
  }
  die("packet size mismatch\n") if length($pack) !=  4 + $userlen + $arg;

  if ($arg == 0 && $userlen != 0) {
    # new format
    die("packet too small\n") unless $userlen >= 2;
    my $narg = unpack("n", substr($pack, 4));
    die("packet too small\n") unless $userlen >= 2 + $narg * 2;
    my @argl = unpack('n' x $narg, substr($pack, 6));
    @argv = unpack('a'.join('a', @argl), substr($pack, 6 + $narg * 2));
  } elsif ($arg == 0 && $userlen == 0) {
    # old protocol ping request
    $oldproto = 1;
    @argv = ('ping', '');
  } else {
    # old protocol sign/pubkey request
    $oldproto = 1;
    @argv = ('sign', substr($pack, 4, $userlen), substr($pack, 4 + $userlen, $arg));
    # the old protocol has the hashalgo attached to the arg instead of the user
    if ($argv[-1] =~ /^(.*?):(.*$)/) {
      $argv[1] = "$1:$argv[1]";
      $argv[-1] = $2;
    }
    if ($argv[-1] eq 'PUBKEY') {
      pop @argv;
      $argv[0] = 'pubkey';
    }
  }
  return @argv;
}

sub reply {
  my ($status, $err, @out) = @_;
  my $out;
  if (!@out || $status) {
    $out = '';		# always use "old protocol" here
  } elsif ($oldproto) {
    die("only one reply supported in old protocol") if @out != 1;
    $out = $out[0];
  } else {
    $out = pack('n' x (1 + scalar(@out)), scalar(@out), map {length($_)} @out).join('', @out);
  }
  my $ret = pack("nnn", $status, length($out), length($err)).$out.$err;
  swrite(*CLNT, $ret);
  close CLNT;
}

sub bindreservedport {
  my ($sock) = @_;
  local *S = $sock;
  my %blacklist;
  local *BL;
  if (open(BL, '<', '/etc/bindresvport.blacklist')) {
    while(<BL>) {
      chomp;
      next unless /^\s*(\d+)/;
      $blacklist{0 + $1} = 1;
    }
    close BL;
  }
  while (1) {
    my $po;
    for ($po = 600; $po < 1024; $po++) {
      next if $blacklist{$po};
      return if bind(S, sockaddr_in($po, INADDR_ANY));
    }
    sleep(3);
  }
}

# read request from client, split into argv array
# proxy a request to another sign server
sub doproxy {
  my ($cmd, $user, $hashalgo, @args) = @_;
  unshift @args, $cmd, $user;
  $args[1] = "$hashalgo:$user" if $hashalgo ne 'SHA1';

  #forward to next server
  socket(CS , PF_INET, SOCK_STREAM, Socket::IPPROTO_TCP) || die("socket: $!\n");
  bindreservedport(*CS) unless $use_unprivileged_ports;
  my $pack;
  if ($args[0] eq 'sign' && $oldproto) {
    my $arg = $args[2];
    $arg = "$hashalgo:$arg" if $hashalgo ne 'SHA1';
    $pack = pack("nn", length($user), length($arg)).$user.$arg;
  } elsif ($args[0] eq 'pubkey' && $oldproto) {
    my $arg = 'PUBKEY';
    $arg = "$hashalgo:$arg" if $hashalgo ne 'SHA1';
    $pack = pack("nn", length($user), length($arg)).$user.$arg;
  } else {
    $pack = pack('n' x (1 + @args), scalar(@args), map {length($_)} @args).join('', @args);
    $pack = pack('nn', length($pack), 0).$pack;
  }
  setsockopt(CS, SOL_SOCKET, SO_KEEPALIVE, pack("l",1));
  connect(CS, $signaddr) || die("connect: $!\n");
  *CS = ssl_client(\*CS) if $sockproto && $sockproto eq 'ssl';
  swrite(*CS, $pack);
  while (1) {
    my $buf = '';
    my $r = sysread(CS, $buf, 8192);
    if (!defined($r)) {
      die("sysread: $!\n") if $! != POSIX::EINTR;
      next;
    }
    last unless $r;
    swrite(*CLNT, $buf);
  }
  close(CS);
}

sub load_module {
  my ($module) = @_;
  die("Illegal module name $module\n") unless $module =~ /^[a-zA-Z][a-zA-Z0-9_-]*$/;
  return if exists $modules{$module};
  $modules{$module} = do "$modulepath/signd_$module";
  die("$modulepath/signd_$module: ".($@ || $!)."\n") unless $modules{$module};
}

sub initialize_modules {
  my $config = { 'sockproto' => $sockproto, 'proxysockproto' => $proxysockproto,
                 'tmpdir' => $tmpdir, 'testmode' => $testmode,
                 'gpg' => $gpg, 'pinentrymode' => \@pinentrymode,
                 'aliases' => $aliases, 'phrases' => $phrases, 'encryptionkeys' => $encryptionkeys };
  my %ret;
  for my $module (grep {$modules{$_}} sort keys %modules) {
    $ret{$module} = $modules{$module}->{'init'}->($config);
  }
  # turn off options if we do not have support
  die("gcrypt module initialization failed\n") if $testmode && ($ENV{'SIGN_GCRYPT'} || '') eq 'force' && !$ret{'gcrypt'};
  $use_gcrypt_sign = $use_gcrypt_privsign = $use_gcrypt_decrypt = 0 unless $ret{'gcrypt'};
  $use_tpm_sign = 0 unless $ret{'tpm'};
  $use_pkcs11_sign = 0 unless $ret{'pkcs11'};
}

##
## main server code follows
##

$testmode = (($ARGV[0] || '') eq '-t') ? 1 : 0;
$testmode = 2 if ($ARGV[0] || '') eq '--test-sign';
if ($testmode) {
  shift @ARGV;
  $conf = $ENV{'SIGN_CONF'} if $ENV{'SIGN_CONF'};
  $modulepath = $ENV{'SIGN_MODULEPATH'} if $ENV{'SIGN_MODULEPATH'};
  $use_agent = 1 if $ENV{SIGN_USE_AGENT};
  if (($ENV{'SIGN_GCRYPT'} || '') eq 'disable') {
    $modules{'gcrypt'} = 0;
  } elsif (($ENV{'SIGN_GCRYPT'} || '') eq 'force') {
    load_module('gcrypt');
    $use_gcrypt_sign = $use_gcrypt_privsign = $use_gcrypt_decrypt = 1;
  }
}

(undef, $conf) = splice(@ARGV, 0, 2) if ($ARGV[0] || '') eq '--config';

local *F;
open(F, '<', $conf) || die("$conf: $!\n");
while(<F>) {
  chomp;
  next if /^#/;
  my @s = split(' ', $_);
  next unless @s;
  @s = split(' ', $_, 2) if $s[0] eq 'allow_subject:';	# hack
  my $cmd = shift @s;
  if ($cmd eq 'modulepath:') {
    $modulepath = $s[0];
  } elsif ($cmd eq 'module:') {
    load_module($_) for @s;
  } elsif ($cmd eq 'server:') {
    $signhost = $s[0];
  } elsif ($cmd eq 'port:') {
    $port = $s[0];
  } elsif ($cmd eq 'proto:') {
    $sockproto = $s[0];
  } elsif ($cmd eq 'proxyport:') {
    $proxyport = $s[0];
  } elsif ($cmd eq 'proxyproto:') {
    $proxysockproto = $s[0] || '';
  } elsif ($cmd eq 'allow:') {
    push @allows, @s;
  } elsif ($cmd eq 'map:') {
    $map{$s[0]} = defined($s[1]) ? $s[1] : '';
  } elsif ($cmd eq 'user:') {
    $signuser = $s[0];
  } elsif ($cmd eq 'gpg:') {
    $gpg = $s[0];
  } elsif ($cmd eq 'phrases:') {
    $phrases = $s[0];
  } elsif ($cmd eq 'aliases:') {
    $aliases = $s[0];
  } elsif ($cmd eq 'encryptionkeys:') {
    $encryptionkeys = $s[0];
  } elsif ($cmd eq 'tmpdir:') {
    $tmpdir = $s[0];
  } elsif ($cmd eq 'keycache:') {
    $keycache = $s[0];
  } elsif ($cmd eq 'patchclasstime:') {
    $patchclasstime = ($s[0] eq '1' || $s[0] =~ /^true$/i) ? 1 : 0;
  } elsif ($cmd eq 'allow-unprivileged-ports:') {
    $allow_unprivileged_ports = ($s[0] eq '1' || $s[0] =~ /^true$/i) ? 1 : 0;
  } elsif ($cmd eq 'use-unprivileged-ports:') {
    $use_unprivileged_ports = ($s[0] eq '1' || $s[0] =~ /^true$/i) ? 1 : 0;
  } elsif ($cmd eq 'use-agent:') {
    $use_agent = ($s[0] eq '1' || $s[0] =~ /^true$/i) ? 1 : 0;
  } elsif ($cmd eq 'use-gcrypt:') {
    $s[0] = 1 if $s[0] =~ /^true$/i;
    @s = split(',', $s[0]);
    $use_gcrypt_sign = 1 if grep {$_ eq '1' || $_ eq 'sign'} @s;
    $use_gcrypt_privsign = 1 if grep {$_ eq '1' || $_ eq 'privsign'} @s;
    $use_gcrypt_decrypt = 1 if grep {$_ eq '1' || $_ eq 'decrypt'} @s;
  } elsif ($cmd eq 'use-tpm:') {
    $use_tpm_sign =  ($s[0] eq '1' || $s[0] eq 'sign' || $s[0] =~ /^true$/i) ? 1 : 0;
  } elsif ($cmd eq 'use-pkcs11:') {
    $use_pkcs11_sign =  ($s[0] eq '1' || $s[0] eq 'sign' || $s[0] =~ /^true$/i) ? 1 : 0;
  } elsif ($cmd eq 'logfile:') {
    $logfile = $s[0];
  } elsif ($cmd eq 'pidfile:') {
    $pidfile = $s[0];
  } elsif ($cmd eq 'gnupghome:') {
    $ENV{GNUPGHOME} = $s[0];
  } elsif ($cmd eq 'agentsocket:') {
    $agentsocket = \@s;
  } elsif ($cmd eq 'hash:' || $cmd eq 'allowuser:') {
    # only used in sign client
  } else {
    my $known;
    for my $module (grep {$modules{$_}} sort keys %modules) {
      if ($modules{$module}->{'config'} && $modules{$module}->{'config'}->($cmd, @s)) {
	$known = 1;
	last;
      }
    }
    warn("Unknown keyword '$cmd'\n") unless $known;
  }
}
close F;

$proxyport = $port unless defined $proxyport;
$proxysockproto = $sockproto unless defined $proxysockproto;
die("unknown sockproto $sockproto\n") if $sockproto && $sockproto ne 'unprotected' && $sockproto ne 'ssl';
die("unknown proxysockproto $proxysockproto\n") if $proxysockproto && $proxysockproto ne 'unprotected' && $proxysockproto ne 'ssl';

# compat: try to load modules
load_module('gcrypt') if ($use_gcrypt_sign || $use_gcrypt_privsign || $use_gcrypt_decrypt) && !exists($modules{'gcrypt'});
die("Please enable the 'ssl' module in sign.conf\n") if (($sockproto || '') eq 'ssl' || ($proxysockproto || '') eq 'ssl') && !exists($modules{'ssl'});
die("Please enable the 'tpm' module in sign.conf\n") if $use_tpm_sign && !exists($modules{'tpm'});
die("Please enable the 'pkcs11' module in sign.conf\n") if $use_pkcs11_sign && !exists($modules{'pkcs11'});

my $myname = $phrases ? 'signd' : 'signproxy';

die("will not proxy to myself\n") if $signhost eq '127.0.0.1' && $port eq $proxyport && !$phrases;

$signaddr = inet_aton($signhost);
die("$signhost: unknown host\n") unless $signaddr;
$signaddr = sockaddr_in($port, $signaddr);

@pinentrymode = ( '--pinentry-mode=loopback' ) if have_pinentry_mode();
$use_agent = 1 unless have_files_are_digests();

my @argv;

if ($testmode) {
  # test mode
  die("test mode needs phrases\n") unless $phrases;
  my @phrases_s = stat($phrases);
  die("phrases directory does not exist\n") unless @phrases_s;
  die("phrases directory owner does not match euid\n") unless $phrases_s[4] == $>;
  $| = 1;
  initialize_modules();
  if ($testmode == 2) {
    *CLNT = *STDIN;
    @argv = readreq();
  } else {
    @argv = @ARGV;
  }
  *CLNT = *STDOUT;
  goto testit;
}

if (@ARGV && $ARGV[0] eq '--gen-enckey') {
  my $alias = @ARGV == 2 ? $ARGV[1] : undef;
  die("encryption alias must start with ':enc'\n") if $alias && $alias !~ /^:enc/;
  my $keyid = do_keygen_sym();
  if ($alias) {
    die("aliases are not configured\n") unless $aliases;
    die("aliases directory $aliases does not exist\n") unless -d $aliases;
    write_alias($aliases, $keyid, $alias);
  }
  print "generated encryption key $keyid\n";
  exit(0);
}

if (($ARGV[0] || '') eq '-f') {
  my $pid = fork();
  die("fork") if  !defined($pid) || $pid < 0;
  if ($pid > 0) {
    spew($pidfile, "$pid\n") if $pidfile;
    exit(0);
  }
}
POSIX::setsid();
$SIG{'PIPE'} = 'IGNORE'; 
$| = 1;
if ($logfile) {
  open(STDOUT, '>>', $logfile) || die("Could not open $logfile: $!\n");
  open(STDERR, ">&STDOUT");
}
printlog("$myname started");

# initialize our modules
initialize_modules();

socket(MS , PF_INET, SOCK_STREAM, Socket::IPPROTO_TCP) || die "socket: $!\n";
setsockopt(MS, SOL_SOCKET, SO_REUSEADDR, pack("l",1));
setsockopt(MS, SOL_SOCKET, SO_KEEPALIVE, pack("l",1));
bind(MS, sockaddr_in($proxyport, INADDR_ANY)) || die "bind: $!\n";
listen(MS , 512) || die "listen: $!\n";

my %chld;
my $clntaddr;

while (1) {
  $clntaddr = accept(CLNT, MS);
  next unless $clntaddr;
  my $pid = fork();
  last if $pid == 0;
  die if $pid == -1;
  close CLNT;
  $chld{$pid} = 1;
  while (($pid = waitpid(-1, keys(%chld) > 10 ? 0 : POSIX::WNOHANG())) > 0) {
    delete $chld{$pid};
  }
}

$SIG{'__DIE__'} = sub {
  die(@_) if $^S;
  my $err = $_[0];
  chomp $err;
  printlog("$peer: $err");
  reply(1, "$err\n");
  exit(0);
};

my ($sport, $saddr) = sockaddr_in($clntaddr);
$peer = inet_ntoa($saddr);
die("not coming from a reserved port\n") if !$allow_unprivileged_ports && ($sport < 0 || $sport > 1024);
my $allowed;
my $hostnameinfo;
for my $allow (@allows) {
  $hostnameinfo ||= [ Socket::getnameinfo($clntaddr) ] if $allow !~ /^[0-9\.]+(:?\/[0-9]+)?$/;
  if (ip_in_network($peer, $allow) || $peer eq $allow || ($hostnameinfo && $hostnameinfo->[1] && $hostnameinfo->[1] eq $allow)) {
    $allowed = 1;
    last;
  }
}
die("illegal host $peer\n") unless $allowed;

if ($proxysockproto eq 'ssl') {
  *CLNT = ssl_server(\*CLNT);
  ssl_checkclient(\*CLNT);
}

### commands

sub cmd_ping {
  my ($cmd, $user, $hashalgo, @args) = @_;
  return (0, '');
}

sub split_length_from_type {
  my ($type) = @_;
  return ('eddsa', 'ed25519') if $type eq 'ed25519' || $type eq 'eddsa@ed25519';
  return ('ecdsa', 'nistp256') if $type eq 'nistp256' || $type eq 'ecdsa@nistp256';
  return ('ecdsa', 'nistp384') if $type eq 'nistp384' || $type eq 'ecdsa@nistp384';
  die("bad type: $type\n") unless $type =~ /^(dsa|rsa)\@(1024|2048|4096)$/s;
  return ($1, $2);
}

sub cmd_keygen {
  my ($cmd, $user, $hashalgo, @args) = @_;
  die("keygen: four arguments expected\n") if @args != 4;
  my $type = $args[0];
  my $expire = $args[1];
  my $real = $args[2];
  my $email = $args[3];
  die("bad expire format\n") unless $expire =~ /^\d{1,10}$/s;
  checkbadchar($real, 'real name');
  checkbadchar($email, 'email');
  my $length;
  ($type, $length) = split_length_from_type($type);

  my ($tdir, $gnupghome, $oldgnupghome) = prepare_tmp_gnupghome();

  # write params file
  my $batch = "Key-Type: $type\n";
  $batch .= ($type eq 'ecdsa' || $type eq 'eddsa' ? "Key-Curve: " : "Key-Length: "). "$length\n";
  $batch .= "Key-Usage: sign\nName-Real: $real\nName-Email: $email\nExpire-Date: ${expire}d\n%no-protection\n";
  spew("$tdir/params", $batch);

  switch_gnupghome($gnupghome);

  # create the key
  rungpg_fatal('/dev/null', $tdir, $gpg, '--batch', '--no-secmem-warning', '--gen-key', "$tdir/params");

  # get the keyid so we can add a signature
  my $keyid = rungpg_fatal('/dev/null', $tdir, $gpg, '--list-keys', '--no-secmem-warning', '--no-default-keyring', '--fixed-list-mode', '--with-colons');
  my @keyid = split("\n", $keyid);
  @keyid = grep {s/^pub:[^:]*:[^:]*:[^:]*:([^:]*):.*$/$1/} @keyid;
  die("keyid not found\n") unless @keyid == 1;
  $keyid = $keyid[0];

  switch_gnupghome($oldgnupghome);

  # add user sig to pubkey
  my $pubring;
  if (-e "$gnupghome/pubring.kbx") {
    $pubring = "$gnupghome/pubring.kbx";
  } elsif ( -e "$gnupghome/pubring.gpg") {
    $pubring = "$gnupghome/pubring.gpg";
  } else {
    die "no pubring found in $gnupghome\n";
  }
  rungpg_fatal("$phrases/$user", $tdir, $gpg, '--batch', '--no-secmem-warning',
        @pinentrymode,
        "--passphrase-fd=0", "--yes",
        "-u", $user,
        '--default-cert-level', '3',
        "--keyring", $pubring,
        '--edit-key', $keyid,
        'sign',
        'save');

  switch_gnupghome($gnupghome);

  # export pubkey and privkey
  my $pubkey = rungpg_fatal('/dev/null', $tdir, $gpg, '--batch', '--no-secmem-warning', '--no-default-keyring', '--export', '-a');
  my $privkey = rungpg_fatal('/dev/null', $tdir, $gpg, '--batch', '--export-secret-keys', '--no-verbose', '--no-secmem-warning', '--trust-model', 'always');
  # newer gpg versions also export the userid and signature, so strip to the bare key
  $privkey = striptofirst($privkey);

  switch_gnupghome($oldgnupghome);

  # get info from privkey
  my $info = {};
  priv2pub($privkey, $info);
  my $xdata = '';
  $xdata = pack('CCH*', $info->{'algo'}, $info->{'version'}, $info->{'fingerprint'}) if $info->{'algo'} && $info->{'version'} && $info->{'fingerprint'};

  my $encuser = $user;
  if ($aliases && -e "$aliases/:enc:$user") {
    $encuser = read_alias($aliases, ":enc:$user", 1);
  } elsif ($aliases && -e "$aliases/:enc") {
    $encuser = read_alias($aliases, ":enc", 1);
  }
  # encrypt the privkey
  $privkey = do_encode($encuser, $privkey, $tdir, $xdata);

  # cleanup and send back
  remove_tree($tdir);
  $privkey = unpack('H*', $privkey);
  return (0, '', $pubkey, $privkey);
}

sub cmd_certgen {
  die("certgen: no longer supported, please update your sign client\n");
}

sub cmd_pubkey {
  my ($cmd, $user, $hashalgo, @args) = @_;
  die("pubkey: no argument expected\n") if @args;
  if ($user =~ /^openssl:(.+)/) {
    die("openssl module not loaded\n") unless $modules{'openssl'};
    return (0, '', openssl_pubkey($1));
  }
  my $pubkey = rungpg_fatal('/dev/null', undef, $gpg, '--export', '-a', $user);
  return (0, '', $pubkey);
}

sub cmd_privsign {
  my ($cmd, $user, $hashalgo, @args) = @_;
  die("privsign: at least two arguments expected\n") if @args < 2;
  die("bad private key\n") if $args[0] !~ /^(?:[0-9a-fA-F][0-9a-fA-F])+$/s;
  my $privkey = pack('H*', shift @args);
  $privkey = do_decode("$phrases/$user", $user, $privkey);
  $privkey = striptofirst($privkey);		# just use the first packet
  my $info = $use_gcrypt_privsign ? {} : undef;
  my $pubkey = priv2pub($privkey, $info);	# also fills $info
  if ($use_gcrypt_privsign && can_sign_with_gcrypt($info)) {
    return do_sign_multiple('/dev/null', undef, $info, $hashalgo, \@args, 1);
  }
  my ($tdir, $gnupghome, $oldgnupghome) = prepare_tmp_gnupghome();
  # create import data: pubkey pkg, user pkg, privkey pkg, user pkg
  spew("$tdir/privkey", $pubkey.encodetag(13, 'privsign').$privkey.encodetag(13, 'privsign'));
  switch_gnupghome($gnupghome);
  rungpg_fatal("$phrases/$user", $tdir, $gpg, '--batch', '--no-verbose', '-q', '--no-secmem-warning', '--allow-non-selfsigned-uid', @pinentrymode, '--passphrase-fd=0', '--import', "$tdir/privkey");
  unlink("$tdir/privkey");
  my ($status, $err, @out) = do_sign_multiple('/dev/null', 'privsign', undef, $hashalgo, \@args, 1);
  switch_gnupghome($oldgnupghome);
  remove_tree($tdir);
  return ($status, $err, @out);
}

sub cmd_sign {
  my ($cmd, $user, $hashalgo, @args) = @_;
  die("sign: at least one arguments required\n") if @args < 1;
  return do_sign_multiple("$phrases/$user", $user, undef, $hashalgo, \@args);
}

sub cmd_privtotp {
  my ($cmd, $user, $hashalgo, @args) = @_;
  die("privtotp: two arguments expected\n") if @args != 2;
  die("bad private key\n") if $args[0] !~ /^(?:[0-9a-fA-F][0-9a-fA-F])+$/s;
  die("bad time argument\n") unless $args[1] =~ /^(?:[0-9a-fA-F][0-9a-fA-F]){4}$/s;
  my $totp = pack('H*', $args[0]);
  my $t = unpack('N', pack('H*', $args[1]));
  $totp = do_decode("$phrases/$user", $user, $totp);
  die("bad totp uri\n") unless $totp =~ /^otpauth:\/\/totp\/.*?\?(.*)$/;
  my %cgi;
  for (split('&', $1)) {
    s/%([a-fA-F0-9]{2})/chr(hex($1))/sge;
    $cgi{$1} = $2 if /^([^=]+)=(.*)$/;
  }
  defined($cgi{$_}) || die("missing totp parameter '$_'\n") for qw{algorithm secret digits period};
  die("bad totp digits\n") unless $cgi{'digits'} =~ /^\d+$/ && $cgi{'digits'} > 0 && $cgi{'digits'} <= 10;
  die("bad totp period\n") unless $cgi{'period'} =~ /^\d+$/ && $cgi{'period'} > 0;
  my $now = time();
  if ($t) {
    my $skew = defined($cgi{'skew'}) ? 0 + $cgi{'skew'} : 3600;
    die("time out of range\n") if $t - $now < -$skew || $t - $now > $skew;
  } else {
    $t = $now;
  }
  # do base32 decoding of secret
  my $secret = uc($cgi{'secret'});
  $secret =~ s/[^A-Z2-7].*\Z//s;
  $secret =~ tr/A-Z2-7/\000-\037/;
  $secret = join('', map {unpack('B5', pack('C', $_ << 3))} unpack('C*', $secret));
  $secret = pack('B*', substr($secret, 0, int(length($secret) / 8) * 8));
  my $b = pack('NN', 0, int($t / $cgi{'period'}));
  my $totpalgo = lc($cgi{'algorithm'});
  my $hmac;
  $hmac = Digest::SHA::hmac_sha1($b, $secret) if $totpalgo eq 'sha1';
  $hmac = Digest::SHA::hmac_sha256($b, $secret) if $totpalgo eq 'sha256';
  $hmac = Digest::SHA::hmac_sha512($b, $secret) if $totpalgo eq 'sha512';
  die("unsupported hmac algorithm\n") unless defined $hmac;
  die("bad hmac length\n") unless length($hmac) >= 20;
  my $offset = unpack('C', substr($hmac, -1, 1)) & 15;
  my $val = unpack("\@${offset}N", $hmac) & 0x7fffffff;
  $val %= 10 ** $cgi{'digits'};
  $val = "0$val" while length($val) < $cgi{'digits'};
  return (0, '', $val);
}

################

sub read_alias {
  my ($aliasdir, $alias, $colonok) = @_;
  die("illegal user $alias\n") if $alias eq '' || $alias =~ /[\000-\037\/]/s || $alias =~ /^\./s;
  die("illegal user $alias\n") if !$colonok && $alias =~ /^:/;
  my $user = slurp_first_line("$aliasdir/$alias");
  die("illegal user $user for alias $alias\n") if $user eq '' || $user =~ /[\000-\037\/]/s || $user =~ /^\./s;
  return $user;
}

sub write_alias {
  my ($aliasdir, $user, $alias) = @_;
  die("illegal user $user\n") if $user eq '' || $user =~ /[\000-\037\/]/s || $user =~ /^\./s;
  die("illegal alias $alias\n") if $alias eq '' || $alias =~ /[\000-\037\/]/s || $alias =~ /^\./s;
  spew("$aliasdir/.$alias.$$", "$user\n");
  rename("$aliasdir/.$alias.$$", "$aliasdir/$alias") || die("rename $aliasdir/.$alias.$$ $aliasdir/$alias: $!\n");
}

################


## read the request, call the handler, reply the result
@argv = readreq();

# verify args contain no control chars and are valid utf8
eval {
  for (@argv) {
    die if /[\000-\037\177]/;
    decode('UTF-8', $_, Encode::FB_CROAK | Encode::LEAVE_SRC) if /[\200-\377]/;
  }
};
die("malformed argument\n") if $@;

if (($argv[0] eq 'privsign' || $argv[0] eq 'certgen' || $argv[0] eq 'privtotp') && @argv > 2) {
  my $pk = $argv[2];
  $argv[2] =~ s/^(..)(.*)(..)$/$1...$3/s;
  printlog("$peer: @argv");
  $argv[2] = $pk;
} else {
  printlog("$peer: @argv");
}

testit:

my %cmds = (
  'ping'	=> \&cmd_ping,
  'keygen'	=> \&cmd_keygen,
  'certgen'	=> \&cmd_certgen,
  'pubkey'	=> \&cmd_pubkey,
  'privsign'	=> \&cmd_privsign,
  'sign'	=> \&cmd_sign,
  'privtotp'	=> \&cmd_privtotp,
);

# extract command/user/hashalgo
my $hashalgo;
my ($cmd, $user) = splice(@argv, 0, 2);
$user = '' unless defined $user;
if ($user =~ /^(.*?):(.*)$/) {
  $hashalgo = $1;
  $user = $2;
}
$hashalgo ||= 'SHA1';	# historic default, maybe die() instead?
die("illegal user $user\n") if $user ne '' && ($user =~ /[\000-\037\/]/s || $user =~ /^\./s);
die("illegal hashalgo $hashalgo\n") if $hashalgo ne '' && $hashalgo =~ /[\000-\037]/s;
if ($cmd eq 'privileged') {
  die("privileged module is not loaded\n") unless defined &cmd_privileged;
  die("privileged: oldproto is not supported\n") if $oldproto;
  reply(cmd_privileged($cmd, $user, $hashalgo, @argv));
  exit(0);
}
if (exists $map{"$hashalgo:$user"}) {
  $user = $map{"$hashalgo:$user"};
} elsif ($user ne '' && exists($map{$user})) {
  $user = $map{$user};
}
$user = $signuser if $user eq '' && $signuser ne '';
die("illegal user $user\n") if $user ne '' && ($user =~ /[\000-\037\/]/s || $user =~ /^\./s);
$user = read_alias($aliases, $user) if $user ne '' && $aliases && -e "$aliases/$user";

# proxy unknown users
if (!$phrases || ($cmd ne 'ping' && $user eq '') || ($user ne '' && ! -e "$phrases/$user")) {
  die("unknown key: $user\n") if $signhost eq '127.0.0.1' && $port eq $proxyport;
  doproxy($cmd, $user, $hashalgo, @argv);
  exit(0);
}

# run the command and reply
my $handler = $cmds{$cmd};
die("unknown command: $cmd\n") unless $handler;
-d $tmpdir || mkdir($tmpdir, 0700) || die("$tmpdir: $!\n");
my ($status, $err, @out) = $handler->($cmd, $user, $hashalgo, @argv);
reply($status, $err, @out);
exit(0);

