#!/usr/bin/perl
#
# Copyright (c) 2006-2013 Michael Schroeder, Novell Inc.
#
# 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 strict;
use warnings;
use Socket qw/IPPROTO_TCP PF_INET PF_UNIX SOCK_STREAM SOL_SOCKET SO_REUSEADDR SO_KEEPALIVE INADDR_ANY inet_aton inet_ntoa sockaddr_in sockaddr_un getnameinfo/;
use POSIX;
use Math::BigInt;
use MIME::Base64;
use Encode;
use bytes;
use File::Temp qw/tempdir/;
use File::Path qw/remove_tree/;
use Digest::SHA;

my $have_gcrypt;
eval {
  require Crypt::GCrypt::Sexp;
  require Crypt::GCrypt::MPI;
  require Crypt::GCrypt;
  die unless defined &Crypt::GCrypt::pk_sign;
  Crypt::GCrypt::gcrypt_version();	# initialize lib
  $have_gcrypt = 1;
};

my @allows;
my %map;
my $signhost = '127.0.0.1';
my $port = 5167;
my $proxyport = 5167;
my $signuser = '';
my $gpg = '/usr/bin/gpg';
my $openssl = '/usr/bin/openssl';
my $phrases = '';
my $tmpdir = '/run/signd';
my $patchclasstime;
my $conf = '/etc/sign.conf';
my $allow_unprivileged_ports = 0;
my $logfile;
my $use_agent;
my $agentsocket;
my @pinentrymode;
my $keycache = '';

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

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;
}

# 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 decodetaglenoff {
  my ($pkg) = @_;
  my $tag = unpack('C', $pkg);
  die("not a gpg packet\n") unless $tag & 128;
  my $len;
  my $off = 1;
  if ($tag & 64) {
    # new packet format
    $tag &= 63;
    $len = unpack('C', substr($pkg, 1));
    if ($len < 192) {
      $off = 2;
    } elsif ($len >= 192 && $len < 224) {
      $len = (($len - 192) << 8) + unpack('C', substr($pkg, 2)) + 192;
      $off = 3;
    } elsif ($len == 255) {
      $len = unpack('N', substr($pkg, 2));
      $off = 6;
    } else {
      die("can't deal with partial body lengths\n");
    }
  } 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;
    } else {
      die("can't deal with not specified packet length\n");
    }
    $tag = ($tag & 60) >> 2;
  }
  return ($tag, $len, $off);
}

sub encodetag {
  my ($tag, $pack) = @_;
  my $l = length($pack);
  if ($l < 192) {
    return pack("CC", $tag + 192, $l).$pack;
  } elsif ($l < 8384) {
    $l = $l - 192;
    $l += (192 << 8);
    return pack("Cn", $tag + 192, $l).$pack;
  } else {
    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 priv2pub {
  my ($privkey, $infos) = @_;
  my $pubkey = '';

  while ($privkey ne '') {
    my ($tag, $len, $off) = decodetaglenoff($privkey);
    #print "tag=$tag, len=$len off=$off\n";
    my $pack = substr($privkey, $off, $len);
    $privkey = substr($privkey, $len + $off);
    my $ptag;
    if ($tag == 5) {
      $ptag = 6;
    } elsif ($tag == 7) {
      $ptag = 14;
    } else {
      next;
    }
    my $pkver = unpack('C', $pack);
    #print "pubkey ver $pkver\n";
    my ($mpioff, $pkalgo);
    if ($pkver == 3) {
      my ($t, $v);
      (undef, $t, $v, $pkalgo) = unpack('CNnC', $pack);
      $mpioff = 8;
    } elsif ($pkver == 4) {
      my $t;
      (undef, $t, $pkalgo) = unpack('CNC', $pack);
      $mpioff = 6;
    } else {
      die("unknown public key version $pkver\n");
    }
    my $info = $infos ? {} : undef;
    push @$infos, $info if $info;
    $info->{'algo'} = $pkalgo if $info;
    my $mpinum;
    my $smpinum;
    if ($pkalgo == 1) {				# RSA
      $mpinum = 2;
      $smpinum = 4;
    } elsif ($pkalgo == 17) {			# DSA
      $mpinum = 4;
      $smpinum = 1;
    } elsif ($pkalgo == 16 || $pkalgo == 20) {	# Elgamal
      $mpinum = 3;
      $smpinum = 1;
    } elsif ($pkalgo == 22) {			# EdDSA
      $mpinum = 1;
      $smpinum = 1;
      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;
    } else {
      die("unknown public key algorithm $pkalgo\n");
    }
    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));
    }
    $pack = substr($pack, 0, $mpioff);
    $pubkey .= encodetag($ptag, $pack);
  }
  return $pubkey;
}

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

sub packlen {
  my ($len) = @_; 
  if ($len >= 128) {
    my $lenl = $len >> 8 ? $len >> 16 ? $len >> 24 ? 4 : 3 : 2 : 1;
    return pack("Ca*", $lenl | 0x80,  substr(pack("N", $len), -$lenl));
  } else {
    return pack("C", $len);
  }
}

sub packtag {
  return chr($_[0]).packlen(length($_[1])).$_[1];
}

sub packmpi {
  my ($mpi) = @_; 
  $mpi = chr(0).$mpi;
  $mpi = substr($mpi, 1) while length($mpi) > 1 && ord($mpi) == 0 && (ord(substr($mpi, 1, 1)) & 0x80) == 0;
  return chr(2).packlen(length($mpi)).$mpi;
}

sub priv2openssl_ed25519 {
  my ($q, $s) = @_;
  die("bad ed25519 Q\n") unless length($q) == 33 && unpack('C', $q) == 0x40;
  die("bad ed25519 S\n") unless length($s) <= 32;
  $s = "\0$s" while length($s) < 32;
  my $asn1 = '';
  $asn1 .= packtag(0x02, "\x00");			# INTEGER 0
  $asn1 .= packtag(0x30, "\x06\x03\x2b\x65\x70");	# SEQUENCE(OID 1.3.101.112)
  $asn1 .= packtag(0x04, packtag(0x04, $s));		# OCTET_STRING(OCTET_STRING(key))
  $asn1 = packtag(0x30, $asn1);
  my $base64 = encode_base64($asn1, '');
  my $pem = "-----BEGIN PRIVATE KEY-----\n";
  $pem .= "$_\n" for $base64 =~ /(.{1,64})/g;
  $pem .= "-----END PRIVATE KEY-----\n";
  return $pem;
}

sub priv2openssl_rsa {
  my (@s) = @_;
  # calculate missing stuff:
  #        modulus           INTEGER,  -- n
  #        publicExponent    INTEGER,  -- e
  #        privateExponent   INTEGER,  -- d    2
  #        prime1            INTEGER,  -- p    4
  #        prime2            INTEGER,  -- q    3
  #        exponent1         INTEGER,  -- d mod (p-1)
  #        exponent2         INTEGER,  -- d mod (q-1)
  #        coefficient       INTEGER,  -- (inverse of q) mod p
  my $d = Math::BigInt->new('0x' . unpack('H*', $s[2]));
  my $p = Math::BigInt->new('0x' . unpack('H*', $s[4]));
  my $q = Math::BigInt->new('0x' . unpack('H*', $s[3]));
  my $ex1 = $d->copy()->bmod($p->copy()->bdec());
  my $ex2 = $d->copy()->bmod($q->copy()->bdec());
  $ex1 = pack('H*', substr($ex1->as_hex(), 2));
  $ex2 = pack('H*', substr($ex2->as_hex(), 2));

  # asn1 encode
  my $asn1 = '';
  $asn1 .= packmpi(chr(0));
  $asn1 .= packmpi($s[0]);
  $asn1 .= packmpi($s[1]);
  $asn1 .= packmpi($s[2]);
  $asn1 .= packmpi($s[4]);
  $asn1 .= packmpi($s[3]);
  $asn1 .= packmpi($ex1);
  $asn1 .= packmpi($ex2);
  $asn1 .= packmpi($s[5]);
  $asn1 = packtag(0x30, $asn1);

  # pem encode
  my $base64 = encode_base64($asn1, '');
  my $pem = "-----BEGIN RSA PRIVATE KEY-----\n";
  $pem .= "$_\n" for $base64 =~ /(.{1,64})/g;
  $pem .= "-----END RSA PRIVATE KEY-----\n";
  return $pem;
}

sub priv2openssl {
  my ($gpgpackets, $search_for) = @_;
  die("empty privkey\n") unless $gpgpackets;
  $search_for ||= 5;
  while ($gpgpackets ne '') {
    my ($tag, $len, $off) = decodetaglenoff($gpgpackets);
    my $pack = substr($gpgpackets, $off, $len);
    $gpgpackets = substr($gpgpackets, $len + $off);
    next unless $tag == $search_for;
    my $pkver = unpack('C', $pack);
    my ($mpioff, $pkalgo);
    if ($pkver == 3) {
      my ($t, $v);
      (undef, $t, $v, $pkalgo) = unpack('CNnC', $pack);
      $mpioff = 8;
    } elsif ($pkver == 4) {
      my $t;
      (undef, $t, $pkalgo) = unpack('CNC', $pack);
      $mpioff = 6;
    } else {
      die("unknown public key version $pkver\n");
    }
    $pack = substr($pack, $mpioff);
    my ($mpinum, $smpinum, $curve);
    if ($pkalgo == 22) {
      my $curvelen = unpack('C', $pack);
      die("bad EdDSA curve len\n") if $curvelen == 0 || $curvelen == 255 || $curvelen + 1 > length($pack);
      $curve = substr($pack, 1, $curvelen);
      $pack = substr($pack, $curvelen + 1);
      $mpinum = 1;
      $smpinum = 1;
    } elsif ($pkalgo == 1) {
      $mpinum = 2;
      $smpinum = 4;
    } else {
      die("not an RSA or EdDSA private key\n");
    }
    my @s;
    for my $i (0..($mpinum + $smpinum - 1)) {
      if ($i == $mpinum) {
        my $encrypted = unpack('C', $pack);
        die("private key is encrypted\n") if $encrypted;
        $pack = substr($pack, 1);
      }
      my $ml = unpack('n', $pack);
      $ml = (($ml + 7) >> 3); 
      die("pack too small\n") unless length($pack) >= 2 + $ml;
      push @s, substr($pack, 2, $ml);
      $pack = substr($pack, 2 + $ml);
    }
    return priv2openssl_ed25519(@s) if $pkalgo == 22 && $curve eq "\x2b\x06\x01\x04\x01\xda\x47\x0f\x01";
    return priv2openssl_rsa(@s) if $pkalgo == 1;
    die("unsupported pubkey algorithm/curve\n");
  }
  die("no private key found\n");
}

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

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 wrap_into_gpgsig_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 sign_with_gcrypt {
  my ($info, $hash, $hashalgo) = @_;
  die("sign_with_gcrypt: missing fingerprint\n") unless $info->{'fingerprint'};
  my $issuer = substr($info->{'fingerprint'}, -16);
  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 = $1;
  $hashalgo = lc($hashalgo);
  my $pgphashalgo = get_pgphashalgo($hashalgo);
  die("sign_with_gcrypt: bad hashalgo $hashalgo\n") unless $pgphashalgo;
  die("sign_with_gcrypt: only RSA supported\n") unless $info->{'algo'} == 1;
  die("sign_with_gcrypt: missing MPIs\n") unless @{$info->{'mpis'} || []} == 2 && @{$info->{'smpis'} || []} == 4;
  my ($n, $e, $d, $p, $q, $u) = map {Crypt::GCrypt::MPI->new('format' => Crypt::GCrypt::MPI::FMT_USG(), 'value' => $_)} @{$info->{'mpis'}}, @{$info->{'smpis'}};
  my $data = Crypt::GCrypt::Sexp->build("(data (flags pkcs1) (hash $hashalgo %b))", pack('H*', $hash));
  my $skey = Crypt::GCrypt::Sexp->build("(private-key (rsa (n %M) (e %M) (d %M) (p %M) (q %M) (u %M)))", $n, $e, $d, $p, $q, $u);
  my $res = Crypt::GCrypt::pk_sign($data, $skey);
  my $sv = $res->nth_mpi(1, Crypt::GCrypt::MPI::FMT_USG(), 's');
  die("could not extract sign result\n") unless $sv;
  my $sigdata = $sv->print(Crypt::GCrypt::MPI::FMT_PGP());
  return wrap_into_gpgsig_v3($extra, $info->{'fingerprint'}, $info->{'algo'}, $pgphashalgo, $hash, $sigdata);
}

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 $@;
}

my $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};
  die("Crypt::GCrypt is not available\n") if ($ENV{SIGN_GCRYPT} || '') eq 'force' && !$have_gcrypt;
  undef $have_gcrypt if ($ENV{SIGN_GCRYPT} || '') eq 'disable';
  $use_agent = 1 if $ENV{SIGN_USE_AGENT};
}
(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;
  if ($s[0] eq 'server:') {
    $signhost = $s[1];
    next;
  }
  if ($s[0] eq 'port:') {
    $port = $proxyport = $s[1];
    next;
  }
  if ($s[0] eq 'proxyport:') {
    $proxyport = $s[1];
    next;
  }
  if ($s[0] eq 'allow:') {
    shift @s;
    push @allows, @s;
    next;
  }
  if ($s[0] eq 'map:') {
    $map{$s[1]} = defined($s[2]) ? $s[2] : '';
    next;
  }
  if ($s[0] eq 'user:') {
    $signuser = $s[1];
    next;
  }
  if ($s[0] eq 'gpg:') {
    $gpg = $s[1];
    next;
  }
  if ($s[0] eq 'openssl:') {
    $openssl = $s[1];
    next;
  }
  if ($s[0] eq 'phrases:') {
    $phrases = $s[1];
    next;
  }
  if ($s[0] eq 'tmpdir:') {
    $tmpdir = $s[1];
    next;
  }
  if ($s[0] eq 'keycache:') {
    $keycache = $s[1];
    next;
  }
  if ($s[0] eq 'patchclasstime:') {
    $patchclasstime = ($s[1] eq '1' || $s[1] =~ /^true$/i) ? 1 : 0;
    next;
  }
  if ($s[0] eq 'allow-unprivileged-ports:') {
    $allow_unprivileged_ports = ($s[1] eq '1' || $s[1] =~ /^true$/i) ? 1 : 0;
    next;
  }
  if ($s[0] eq 'use-agent:') {
    $use_agent = ($s[1] eq '1' || $s[1] =~ /^true$/i) ? 1 : 0;
    next;
  }
  if ($s[0] eq 'logfile:') {
    $logfile = $s[1];
    next;
  }
  if ($s[0] eq 'gnupghome:') {
    $ENV{GNUPGHOME} = $s[1];
    next;
  }
}

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

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

my $signaddr = inet_aton($signhost);
die("$signhost: unknown host\n") unless $signaddr;
@pinentrymode = ( '--pinentry-mode=loopback' ) if have_pinentry_mode();
$use_agent = 1 unless have_files_are_digests();
find_agentsocket() if $use_agent && !$agentsocket && $phrases;

my @argv;

if ($testmode) {
  die("test mode needs phrases\n") unless $phrases;
  # test mode
  $| = 1;
  if ($testmode == 2) {
    *CLNT = *STDIN;
    @argv = readreq();
  } else {
    @argv = @ARGV;
  }
  *CLNT = *STDOUT;
  goto testit;
}

if (($ARGV[0] || '') eq '-f') {
  my $pid = fork();
  die("fork") if  !defined($pid) || $pid < 0;
  #exit(0) if $pid > 0;
  if ($pid > 0) {
    open(PID, '>/run/signd.pid') || die("/run/signd.pid: $!\n");
    print PID "$pid\n";
    close PID;
    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");

socket(MS , PF_INET, SOCK_STREAM, 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");
};

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 = 0;
my ($hosterr, $hostname, $servicename) = getnameinfo($clntaddr);
my $hostnameinfo;
for my $allow (@allows) {
  $hostnameinfo ||= [ 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;

# read request from client, split into argv array
sub readreq {
  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 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);
  }
}

# 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, IPPROTO_TCP) || die("socket: $!\n");
  bindreservedport(*CS);
  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, sockaddr_in($port, $signaddr)) || die("connect: $!\n");
  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);
  }
}

sub cleanup_tmp_gpg {
  my ($unlinks) = @_;
  return unless defined $unlinks;
  if (ref($unlinks) eq 'ARRAY') {
    for (@{$unlinks || []}) {
      unlink($_);
    }
  } 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) {
    cleanup_tmp_gpg($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;
    cleanup_tmp_gpg($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-fingerprint', '--with-keygrip', '--with-colons', '--', "<$user>");
  my $fpr;
  my $grp;
  my $keyid;
  $keyid = lc(substr($user, -16)) if $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 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 prepare_tmp_gnupghome {
  my ($tmpdir) = @_;
  my $tdir = tempdir('XXXXXXXX', DIR => $tmpdir, CLEANUP => 1);
  chmod 0700, $tdir;
  mkdir("$tdir/gnupg", 0700) || die "Could not create $tdir/gnupg: $!\n";
  return ($tdir, "$tdir/gnupg");
}

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, '--file-is-digest', '--version');
  return !$status;
}

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;
  exit(0);
}

### commands

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

sub cmd_keygen {
  my ($cmd, $user, $hashalgo, @args) = @_;
  die("keygen: at least five arguments expected\n") if @args < 4;
  my $type = $args[0];
  my $expire = $args[1];
  die("bad expire format\n") unless $expire =~ /^\d{1,10}$/s;
  my $real = $args[2];
  my $email = $args[3];
  checkbadchar($real, 'real name');
  checkbadchar($email, 'email');
  my $length;
  if ($type eq 'ed25519' || $type eq 'eddsa@ed25519') {
    $type = 'eddsa';
    $length = 'ed25519';
  } else {
    die("bad type: $type\n") unless $type =~ /^(dsa|rsa)\@(1024|2048|4096)$/s;
    $length = $2;
    $type = $1;
  }

  my $org_gnupghome = $ENV{GNUPGHOME};
  my $tdir;
  ($tdir, $ENV{GNUPGHOME}) = prepare_tmp_gnupghome($tmpdir);

  # write params file
  my $batch;
  if ($type eq 'eddsa') {
    $batch = "Key-Type: $type\nKey-Curve: $length\n";
  } else {
    $batch = "Key-Type: $type\nKey-Length: $length\n";
  }
  $batch .= "Key-Usage: sign\nName-Real: $real\nName-Email: $email\nExpire-Date: ${expire}d\n%no-protection\n";
  local *F;
  open(F, ">$tdir/params") || die("$tdir/params: $!\n");
  (syswrite(F, $batch) || 0) == length($batch) || die("keygen parameter write error\n");
  close(F) || die("keygen parameter close error\n");

  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;
  if (@keyid != 1) {
    remove_tree($tdir) || die "Could not remove $tdir: $!\n";
    die("keyid not found\n");
  }
  $keyid = $keyid[0];

  # add user sig to pubkey
  $ENV{GNUPGHOME} = $org_gnupghome;
  my $pubring;
  if (-e "$tdir/gnupg/pubring.kbx") {
    $pubring = "$tdir/gnupg/pubring.kbx";
  } elsif ( -e "$tdir/gnupg/pubring.gpg") {
    $pubring = "$tdir/gnupg/pubring.gpg";
  } else {
    remove_tree($tdir);
    die "No valid pubring found in $tdir/gnupg\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');

  # export pubkey
  $ENV{GNUPGHOME} = "$tdir/gnupg";
  my $pubkey = rungpg_fatal('/dev/null', $tdir, $gpg, '--batch', '--no-secmem-warning', '--no-default-keyring', '--export', '-a');

  # encrypt privkey
  my $privkey_plain = 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_plain = striptofirst($privkey_plain);
  open(F, '>', "$tdir/privkey") || die("$tdir/privkey: $!\n");
  (syswrite(F, $privkey_plain) || 0) == length($privkey_plain) || die("privkey write error\n");
  close(F) || die("privkey close error\n");

  $ENV{GNUPGHOME} = $org_gnupghome;
  my $privkey = rungpg_fatal('/dev/null', $tdir, $gpg, '--batch', '--encrypt', '--no-verbose', '--no-secmem-warning', '--trust-model', 'always', '-o-', '-r', "<$user>", "$tdir/privkey");
  remove_tree($tdir);

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

sub cmd_certgen {
  my ($cmd, $user, $hashalgo, @args) = @_;
  die("keygen: at least five arguments expected\n") if @args < 4;
  die("bad private key\n") if $args[0] !~ /^(?:[0-9a-fA-F][0-9a-fA-F])+$/s;
  my $privkey = pack('H*', $args[0]);
  my $expire = $args[1];
  die("bad expire format\n") unless $expire =~ /^\d{1,10}$/s;
  my $real = $args[2];
  my $email = $args[3];
  checkbadchar($real, 'real name');
  checkbadchar($email, 'email');
  local *F;
  open(F, ">$tmpdir/privkey.$$") || die("$tmpdir/privkey.$$: $!\n");
  (syswrite(F, $privkey) || 0) == length($privkey) || die("encoded privkey write error\n");
  close(F) || die("encoded privkey close error\n");
  $privkey = rungpg_fatal("$phrases/$user", ["$tmpdir/privkey.$$"], $gpg, '--batch', '--decrypt', '--no-verbose', '-q', '--no-secmem-warning', @pinentrymode, '--passphrase-fd=0', "$tmpdir/privkey.$$");
  unlink("$tmpdir/privkey.$$");
  my $opensslprivkey = priv2openssl($privkey);
  my $reqconf = <<"EOL";
[ req ]
string_mask = utf8only
distinguished_name = distinguished_name
x509_extensions = x509_extensions
prompt = no
utf8 = yes

[ distinguished_name ]
CN = "$real"
emailAddress = "$email"

[ x509_extensions ]
basicConstraints = critical,CA:false
subjectKeyIdentifier=hash
authorityKeyIdentifier=keyid,issuer
keyUsage = critical,keyCertSign,digitalSignature
extendedKeyUsage = codeSigning
EOL
  open(F, ">$tmpdir/sslreq$$.conf") || die("$tmpdir/sslreq$$.conf: $!\n");
  (syswrite(F, $reqconf) || 0) == length($reqconf) || die("openssl conf write error\n");
  close(F) || die("openssl conf close error\n");
  open(F, ">$tmpdir/privkey.$$") || die("$tmpdir/privkey.$$: $!\n");
  (syswrite(F, $opensslprivkey) || 0) == length($opensslprivkey) || die("openssl privkey write error\n");
  close(F) || die("openssl privkey close error\n");
  my $cert = rungpg_fatal('/dev/null', ["$tmpdir/sslreq$$.conf", "$tmpdir/privkey.$$"], $openssl, 'req', '-new', '-x509', '-sha256', '-key', "$tmpdir/privkey.$$", '-days', $expire, '-config', "$tmpdir/sslreq$$.conf");
  unlink("$tmpdir/privkey.$$");
  unlink("$tmpdir/sslreq$$.conf");
  $oldproto = 1;		# FIXME: should not force the old proto here
  return (0, '', $cert);
}

sub cmd_pubkey {
  my ($cmd, $user, $hashalgo, @args) = @_;
  die("pubkey: one argument expected\n") if @args;
  my $pubkey = rungpg_fatal('/dev/null', undef, $gpg, '--export', '-a', "<$user>");
  return (0, '', $pubkey);
}

my $agent_sock;

sub find_agentsocket {
  undef $agentsocket;
  for (split("\n", `gpgconf --list-dirs`)) {
    $agentsocket = $1 if /^agent-socket:(.*)/;
  }
}

sub open_agent {
  find_agentsocket() unless $agentsocket;
  die("could not determine agent socket\n") unless $agentsocket;
  socket($agent_sock, PF_UNIX, SOCK_STREAM, 0) || die("socket: $!\n");
  if (!connect($agent_sock, sockaddr_un($agentsocket))) {
    rungpg_fatal("/dev/null", undef, 'gpg-connect-agent', '/bye');
    connect($agent_sock, sockaddr_un($agentsocket)) || die("connect: $!\n");
  }
  agent_rpc();	# read greeting
}

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

sub switch_agent {
  close_agent();
  undef $agentsocket;
}

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 $fd;
        open($fd, '<', $phrasefile) || die("$phrasefile: $!\n");
        my $passphrase = <$fd>;
        close $fd;
	die("unknown passphrase\n") unless defined $passphrase;
	chomp $passphrase;
	$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;
}

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), '');
    } 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 {
  my ($l, $lit) = @_;
  return @$l if @$l && $l->[0] eq $lit;
  for (@$l) {
    next unless ref($_) eq 'ARRAY';
    my @r = find_in_sexp($_, $lit);
    return @r if @r;
  }
  return ();
}

sub find_in_sexp_gpgmpi {
  my ($l, $lit) = @_;
  my (undef, $d) = find_in_sexp($l, $lit);
  die("could not find $lit\n") unless defined $d;
  $d = substr($d, 1) while substr($d, 0, 1) eq "\0";
  my $first = unpack('C', $d);
  my $bits = 0;
  while ($first && ($first & 0x80) == 0) {
    $bits++;
    $first *= 2;
  }
  return pack('n', 8 * length($d) - $bits).$d;
}

sub sign_with_agent {
  my ($phrasefile, $user, $hashalgo, $hash, $isprivsign) = @_;
  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 ($fingerprint, $keygrip) = $isprivsign ? find_key($user) : find_key_keycache($user);
  die("unknown pubkey for $user\n") unless $fingerprint;
  agent_rpc("SIGKEY $keygrip");
  agent_rpc("SETHASH $pgphashalgo $hash");
  agent_rpc("OPTION pinentry-mode=loopback") if defined($phrasefile) && $phrasefile ne '/dev/null' && -s $phrasefile;
  my $sig = agent_rpc("PKSIGN", $phrasefile);
  ($sig) = parse_sexp($sig);
  my (undef, $sigval) = find_in_sexp($sig, 'sig-val');
  die("missing sig-val\n") unless $sigval;
  my ($pgppubalgo, $sigdata);
  my $algo = $sigval->[0];
  if ($algo eq 'rsa') {
    $pgppubalgo = 1;
    $sigdata = find_in_sexp_gpgmpi($sigval, 's');
  } elsif ($algo eq 'dsa') {
    $pgppubalgo = 17;
    $sigdata = find_in_sexp_gpgmpi($sigval, 'r').find_in_sexp_gpgmpi($sigval, 's');
  } elsif ($algo eq 'eddsa') {
    $pgppubalgo = 22;
    $sigdata = find_in_sexp_gpgmpi($sigval, 'r').find_in_sexp_gpgmpi($sigval, 's');
  }
  die("unsupported pubkey algorithm $algo\n") unless defined $pgppubalgo;
  return wrap_into_gpgsig_v3($extra, $fingerprint, $pgppubalgo, $pgphashalgo, $hash, $sigdata);
}

sub do_sign {
  my ($phrasesfile, $user, $hashalgo, $hash, $isprivsign) = @_;
  if ($use_agent) {
    my $out;
    eval { $out = sign_with_agent($phrasesfile, $user, $hashalgo, $hash, $isprivsign) };
    return 1, '', $@ if $@;
    return (0, $out, '');
  } else {
    my @args;
    if ($isprivsign) {
      push @args, '--allow-non-selfsigned-uid';
    } else {
      push @args, '-u', "<$user>";
    }
    return rungpg($phrasesfile, undef, $gpg, "--batch", "--force-v3-sigs", "--file-is-digest", "--digest-algo=$hashalgo", "--no-verbose", "--no-armor", "--no-secmem-warning", "--ignore-time-conflict", @pinentrymode, "--passphrase-fd=0", @args, "-sbo", "-", $hash);
  }
}

sub do_decode {
  my ($phrasesfile, $user, $encodeddata) = @_;
  my $file = "$tmpdir/privkey.$$";
  local *F;
  open(F, '>', $file) || die("$file: $!\n");
  (syswrite(F, $encodeddata) || 0) == length($encodeddata) || die("encoded data write error\n");
  close(F) || die("encoded data close error\n");
  my $decoded = rungpg_fatal($phrasesfile, [ $file ], $gpg, '--batch', '--decrypt', '--no-verbose', '-q', '--no-secmem-warning', @pinentrymode, '--passphrase-fd=0', $file);
  unlink($file);
  return $decoded;
}

sub cmd_privsign {
  my ($cmd, $user, $hashalgo, @args) = @_;
  die("privsign: at least three 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*', $args[0]);
  shift @args;
  $privkey = do_decode("$phrases/$user", $user, $privkey);
  my @infos;
  my $pubkey = priv2pub($privkey, $have_gcrypt ? \@infos : undef);
  if ($have_gcrypt && @infos == 1 && $infos[0]->{'algo'} == 1 && $infos[0]->{'smpis'}) {
    my $info = $infos[0];
    my $status = 0;
    my $err = '';
    my @out;
    while (@args) {
      my $lout = '';
      my $classtime;
      if ($patchclasstime && ($args[0] =~ /\@([0-9a-fA-F]{10})$/s)) {
	$classtime = $1;
	$args[0] = substr($args[0], 0, -10)."0000000000";
      }
      eval { $lout = sign_with_gcrypt($info, $args[0], $hashalgo) };
      if ($@) {
        $err .= $@;
	$status = 1;
      }
      $lout = patchclasstime($lout, $classtime) if $classtime && !$status;
      shift @args;
      push @out, $lout;
      last if $status;
    }
    return ($status, $err, @out);
  }
  # create import data: pubkey pkg, user pkg, privkey pkg, user pkg
  $privkey = priv2pub($privkey).encodetag(13, 'privsign').striptofirst($privkey).encodetag(13, 'privsign');
  open(F, ">$tmpdir/privkey.$$") || die("$tmpdir/privkey.$$: $!\n");
  (syswrite(F, $privkey) || 0) == length($privkey) || die("decoded privkey write error\n");
  close(F) || die("decoded privkey close error\n");
  my $tdir;
  my $oldgpghome = $ENV{GNUPGHOME};
  ($tdir, $ENV{GNUPGHOME}) = prepare_tmp_gnupghome($tmpdir);
  switch_agent();
  rungpg_fatal("$phrases/$user", ["$tmpdir/privkey.$$"], $gpg, '--batch', '--no-verbose', '-q', '--no-secmem-warning', '--allow-non-selfsigned-uid', @pinentrymode, '--passphrase-fd=0', '--import', "$tmpdir/privkey.$$");
  unlink("$tmpdir/privkey.$$");
  my $status = 0;
  my $err = '';
  my @out;
  while (@args) {
    my ($lout, $lerr);
    my $classtime;
    if ($patchclasstime && ($args[0] =~ /\@([0-9a-fA-F]{10})$/s)) {
      $classtime = $1;
      $args[0] = substr($args[0], 0, -10)."0000000000";
    }
    ($status, $lout, $lerr) = do_sign('/dev/null', 'privsign', $hashalgo, $args[0], 1);
    $lout = patchclasstime($lout, $classtime) if $classtime && !$status;
    shift @args;
    push @out, $lout;
    $err .= $lerr;
    last if $status;
  }
  remove_tree($tdir);
  $ENV{GNUPGHOME} = $oldgpghome;
  switch_agent();
  return ($status, $err, @out);
}

sub cmd_sign {
  my ($cmd, $user, $hashalgo, @args) = @_;
  die("sign: two arguments expected (old protocol)\n") if $oldproto && @args != 1;
  die("sign: at least two arguments expected\n") if @args < 1;
  my $status = 0;
  my $err = '';
  my $out = '';
  my @out;
  while (@args) {
    my ($lout, $lerr);
    my $classtime;
    if ($patchclasstime && ($args[0] =~ /\@([0-9a-fA-F]{10})$/s)) {
      $classtime = $1;
      $args[0] = substr($args[0], 0, -10)."0000000000";
    }
    ($status, $lout, $lerr) = do_sign("$phrases/$user", $user, $hashalgo, $args[0]);
    $lout = patchclasstime($lout, $classtime) if $classtime && !$status;
    shift @args;
    push @out, $lout;
    $err .= $lerr;
    last if $status;
  }
  return ($status, $err, @out);
}

## read the request, call the handler, reply the result
@argv = readreq();
if (($argv[0] eq 'privsign' || $argv[0] eq 'certgen') && @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,
);

# extract command/user/hashalgo
my $hashalgo = 'SHA1';
my ($cmd, $user) = splice(@argv, 0, 2);
$user = '' unless defined $user;
if ($user =~ /^(.*?):(.*)$/) {
  $hashalgo = $1;
  $user = $2;
}
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);
die("illegal hashalgo $hashalgo\n") if $hashalgo ne '' && $hashalgo =~ /[\000-\037]/s;

# 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;
if (! -d $tmpdir) {
  mkdir($tmpdir, 0700) || die("$tmpdir: $!\n");
}
my ($status, $err, @out) = $handler->($cmd, $user, $hashalgo, @argv);
reply($status, $err, @out);
exit(0);

