#!/usr/bin/perl
#
# Copyright (c) 2022 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 Math::BigInt;
use MIME::Base64;
use Encode;
use bytes;
use File::Temp qw/tempdir/;
use File::Path qw/remove_tree/;
use Digest::SHA;

use strict;
use warnings;

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 @allow_subject;
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 @pinentrymode;
my $keycache = '';
my $use_gcrypt_sign;
my $use_gcrypt_privsign;
my $use_gcrypt_decrypt;
my $ssl_certfile;
my $ssl_keyfile;
my $ssl_verifyfile;
my $ssl_verifydir;

my $proxyport;
my $proxysockproto;
my $proxyssl_certfile;
my $proxyssl_keyfile;
my $proxyssl_verifyfile;
my $proxyssl_verifydir;

my $restricted_gnupghome = '';
my $restricted_phrases = '';
my $restricted_aliases = '';
my $privileged_gnupghome = '';
my $privileged_logfile;
my $system_gnupghome = '';
my $extranonce = '';
my $backup_user = '';
my @backup_locations;

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_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_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;
  ($tag, $pkg) = decodepkg(substr($encodeddata, $off + $len));
  die("unsupported protected data tag $tag\n") unless $tag == 18;
  die("unsupported integrity protected data packet version\n") if unpack('C', substr($pkg, 0, 1, '')) != 1;
  return ($einfo, $pkg, 1);
}

sub parse_sym_encryted_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 };
  ($tag, $pkg) = decodepkg(substr($encodeddata, $off + $len));
  die("unsupported protected data tag $tag\n") unless $tag == 18;
  die("unsupported integrity protected data packet version\n") if unpack('C', substr($pkg, 0, 1, '')) != 1;
  return ($einfo, $pkg, 1);
}

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


##
## libgcrypt support
##

sub sign_with_gcrypt {
  my ($info, $hash, $hashalgo, $replyv4) = @_;
  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;
  my $sigdata;
  if ($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;
    $sigdata = $sv->print(Crypt::GCrypt::MPI::FMT_PGP());
  } elsif ($info->{'algo'} == 17) {
    die("sign_with_gcrypt: missing MPIs\n") unless @{$info->{'mpis'} || []} == 4 && @{$info->{'smpis'} || []} == 1;
    my $qlen = length($info->{'mpis'}->[1]);
    my $hashraw = substr(pack('H*', $hash), 0, $qlen < 20 ? 20 : $qlen);
    my ($p, $q, $g, $y, $x) = map {Crypt::GCrypt::MPI->new('format' => Crypt::GCrypt::MPI::FMT_USG(), 'value' => $_)} @{$info->{'mpis'}}, @{$info->{'smpis'}};
    my $data = Crypt::GCrypt::Sexp->build("(data (flags raw) (value %b))", $hashraw);
    my $skey = Crypt::GCrypt::Sexp->build("(private-key (dsa (p %M) (q %M) (g %M) (y %M) (x %M)))", $p, $q, $g, $y, $x);
    my $res = Crypt::GCrypt::pk_sign($data, $skey);
    my $rv = $res->nth_mpi(1, Crypt::GCrypt::MPI::FMT_USG(), 'r');
    my $sv = $res->nth_mpi(1, Crypt::GCrypt::MPI::FMT_USG(), 's');
    $sigdata = $rv->print(Crypt::GCrypt::MPI::FMT_PGP()).$sv->print(Crypt::GCrypt::MPI::FMT_PGP());
  } elsif ($info->{'algo'} == 19) {
    die("sign_with_gcrypt: missing MPIs\n") unless @{$info->{'mpis'} || []} == 1 && @{$info->{'smpis'} || []} == 1;
    my $curve;
    $curve = 'NIST P-256' if $info->{'curve'} eq $pgp_curve_nistp256;
    $curve = 'NIST P-384' if $info->{'curve'} eq $pgp_curve_nistp384;
    die("sign_with_gcrypt: unsupported ECDSA curve\n") unless $curve;
    my $hashraw = pack('H*', $hash);
    $hashraw = substr($hashraw, 0, 32) if $curve eq 'NIST P-256';
    $hashraw = substr($hashraw, 0, 48) if $curve eq 'NIST P-384';
    my ($q, $d) = map {Crypt::GCrypt::MPI->new('format' => Crypt::GCrypt::MPI::FMT_USG(), 'value' => $_)} @{$info->{'mpis'}}, @{$info->{'smpis'}};
    my $data = Crypt::GCrypt::Sexp->build("(data (flags raw) (value %b))", $hashraw);
    my $skey = Crypt::GCrypt::Sexp->build("(private-key (ecc (curve \"$curve\") (q %M) (d %M)))", $q, $d);
    my $res = Crypt::GCrypt::pk_sign($data, $skey);
    my $rv = $res->nth_mpi(1, Crypt::GCrypt::MPI::FMT_USG(), 'r');
    my $sv = $res->nth_mpi(1, Crypt::GCrypt::MPI::FMT_USG(), 's');
    $sigdata = $rv->print(Crypt::GCrypt::MPI::FMT_PGP()).$sv->print(Crypt::GCrypt::MPI::FMT_PGP());
  } elsif ($info->{'algo'} == 22) {
    my $curve;
    $curve = 'Ed25519' if $info->{'curve'} eq $pgp_curve_ed25519;
    die("sign_with_gcrypt: unsupported EdDSA curve\n") unless $curve;
    die("sign_with_gcrypt: missing MPIs\n") unless @{$info->{'mpis'} || []} == 1 && @{$info->{'smpis'} || []} == 1;
    my ($d) = map {Crypt::GCrypt::MPI->new('format' => Crypt::GCrypt::MPI::FMT_USG(), 'value' => $_)} @{$info->{'smpis'}};
    my $data = Crypt::GCrypt::Sexp->build("(data (flags eddsa) (hash-algo sha512) (value %b))", pack('H*', $hash));
    my $skey = Crypt::GCrypt::Sexp->build("(private-key (ecc (curve \"$curve\") (d %M)))", $d);
    my $res = Crypt::GCrypt::pk_sign($data, $skey);
    my $rv = $res->nth_mpi(1, Crypt::GCrypt::MPI::FMT_USG(), 'r');
    my $sv = $res->nth_mpi(1, Crypt::GCrypt::MPI::FMT_USG(), 's');
    $sigdata = $rv->print(Crypt::GCrypt::MPI::FMT_PGP()).$sv->print(Crypt::GCrypt::MPI::FMT_PGP());
  } else {
    die("sign_with_gcrypt: unsupported pubkey algorithm $info->{'algo'}\n");
  }
  return wrap_into_pgpsig_v4($extra, $info->{'fingerprint'}, $info->{'algo'}, $pgphashalgo, $hash, $sigdata) if $replyv4;
  return wrap_into_pgpsig_v3($extra, $info->{'fingerprint'}, $info->{'algo'}, $pgphashalgo, $hash, $sigdata);
}

sub can_sign_with_gcrypt {
  my ($info) = @_;
  return 0 unless $have_gcrypt && $info && $info->{'algo'};
  return 0 unless $info->{'smpis'};
  return 1 if $info->{'algo'} == 1;
  return 1 if $info->{'algo'} == 17;
  return 1 if $info->{'algo'} == 22 && $info->{'curve'} eq $pgp_curve_ed25519;
  return 1 if $info->{'algo'} == 19 && $info->{'curve'} eq $pgp_curve_nistp256;
  return 1 if $info->{'algo'} == 19 && $info->{'curve'} eq $pgp_curve_nistp384;
  return 0;
}

sub decrypt_cipher_with_gcrypt {
  my ($cipheralgo, $key, $encrypted, $encrypted_mdc) = @_;
  my ($cipher, $blklen);
  if ($cipheralgo == 7) {	# AES128
    die("bad cipher key length\n") unless length($key) == 16;
    $blklen = 16;
    $cipher = Crypt::GCrypt->new('type' => 'cipher', 'algorithm' => 'aes128', 'mode' => 'cfb', 'padding' => 'none');
  } elsif ($cipheralgo == 9) {	# AES256
    die("bad cipher key length\n") unless length($key) == 32;
    $blklen = 16;
    $cipher = Crypt::GCrypt->new('type' => 'cipher', 'algorithm' => 'aes256', 'mode' => 'cfb', 'padding' => 'none');
  }
  die("decrypt_with_gcrypt: unsupported cipher algorithm $cipheralgo\n") unless $cipher && $blklen;
  $cipher->start('decrypting');
  $cipher->setkey($key);
  my $padlen = length($encrypted) % $blklen;
  my $pad = $padlen ? ("\0" x ($blklen - $padlen)) : '';
  my $plain = $cipher->decrypt("$encrypted$pad");
  $plain .= $cipher->finish();
  $plain = substr($plain, 0, length($encrypted)) if $padlen;
  die("bad DEK data\n") if length($plain) < $blklen + 2;
  my @chk = unpack('nn', substr($plain, $blklen - 2, 4));
  die("DEK mismatch\n") if $chk[0] != $chk[1];
  if ($encrypted_mdc) {
    die("MDC mismatch\n") if length($plain) < $blklen + 2 + 22 || unpack('n', substr($plain, -22, 2)) != 0xd314;
    die("MDC mismatch\n") if substr($plain, -20) ne Digest::SHA::sha1(substr($plain, 0, -20));
    substr($plain, -22, 22, '');
  }
  return substr($plain, $blklen + 2);
}

sub decrypt_with_gcrypt {
  my ($info, $einfo, $encrypted, $encrypted_mdc) = @_;
  die("decrypt_with_gcrypt: encryption algo mismatch\n") if $info->{'algo'} != $einfo->{'algo'};
  my $value;
  if ($info->{'algo'} == 1) {
    die("decrypt_with_gcrypt: missing MPIs\n") unless @{$info->{'mpis'} || []} == 2 && @{$info->{'smpis'} || []} == 4 && @{$einfo->{'mpis'} || []} == 1;
    my ($av) = map {Crypt::GCrypt::MPI->new('format' => Crypt::GCrypt::MPI::FMT_USG(), 'value' => $_)} @{$einfo->{'mpis'}};
    my ($n, $e, $d, $p, $q, $u) = map {Crypt::GCrypt::MPI->new('format' => Crypt::GCrypt::MPI::FMT_USG(), 'value' => $_)} @{$info->{'mpis'}}, @{$info->{'smpis'}};
    my $encval = Crypt::GCrypt::Sexp->build("(enc-val (flags) (rsa (a %M)))", $av);
    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_decrypt($encval, $skey);
    $value = $res->nth_data(1, 'value');
  } elsif ($info->{'algo'} == 16) {
    die("decrypt_with_gcrypt: missing MPIs\n") unless @{$info->{'mpis'} || []} == 3 && @{$info->{'smpis'} || []} == 1 && @{$einfo->{'mpis'} || []} == 2;
    my ($av, $bv) = map {Crypt::GCrypt::MPI->new('format' => Crypt::GCrypt::MPI::FMT_USG(), 'value' => $_)} @{$einfo->{'mpis'}};
    my ($p, $g, $y, $x) = map {Crypt::GCrypt::MPI->new('format' => Crypt::GCrypt::MPI::FMT_USG(), 'value' => $_)} @{$info->{'mpis'}}, @{$info->{'smpis'}};
    my $encval = Crypt::GCrypt::Sexp->build("(enc-val (flags) (elg (a %M) (b %M)))", $av, $bv);
    my $skey = Crypt::GCrypt::Sexp->build("(private-key (elg (p %M) (g %M) (y %M) (x %M)))", $p, $g, $y, $x);
    my $res = Crypt::GCrypt::pk_decrypt($encval, $skey);
    $value = $res->nth_data(1, 'value');
  } else {
    die("decrypt_with_gcrypt: unsupported encryption algorithm $info->{'algo'}\n");
  }
  $value = substr($value, 1) if unpack('C', $value) == 0;
  die("decryption error\n") unless unpack('C', $value) == 2;
  my $idx = index($value, "\0");
  die("decryption error\n") unless $idx >= 0;
  $value = substr($value, $idx + 1);
  my $cipheralgo = unpack('C', substr($value, 0, 1, ''));
  my $csum = unpack('n', substr($value, -2, 2, ''));
  my $csum2 = 0;
  $csum2 += $_ for unpack('C*', $value);
  die("decryption error\n") unless $csum == ($csum2 % 65536);
  return decrypt_cipher_with_gcrypt($cipheralgo, $value, $encrypted, $encrypted_mdc);
}

sub can_decrypt_with_gcrypt {
  my ($einfo) = @_;
  return 0 unless $have_gcrypt && $einfo && $einfo->{'algo'};
  return 1 if $einfo->{'algo'} == 1;
  return 1 if $einfo->{'algo'} == 16;
  return 0;
}

sub pgp_s2k_is {
  my ($hashalgo, $salt, $passphrase, $count, $outsize) = @_;
  die("unsupported s2k_is params\n") if $hashalgo != 10 || length($salt) != 8 || $count < 1024 || $outsize > 32 || $count > 131072;
  my $l = length($salt) + length($passphrase);
  $count = $l if $count < $l;
  my $blob = "$salt$passphrase" x (1 + int($count / $l));
  substr($blob, $count, length($blob), '');
  return substr(Digest::SHA::sha512($blob), 0, $outsize);
}

sub decrypt_sym_with_gcrypt {
  my ($info, $salt, $encrypted, $encrypted_mdc) = @_;
  my $keylen;
  $keylen = 32 if $info->{'cipheralgo'} == 9;
  die("decrypt_sym_with_gcrypt: unsupported cipher algorithm $info->{'cipheralgo'}\n") unless $keylen;
  my $s2kcnt = (16 + ($info->{'s2kcnt'} & 0x0f)) << (6 + (($info->{'s2kcnt'} >> 4) & 0x0f));
  my $secret = pgp_s2k_is($info->{'s2kalgo'}, $salt, $info->{'secret'}, $s2kcnt, $keylen);
  my $decrypted = decrypt_cipher_with_gcrypt($info->{'cipheralgo'}, $secret, $encrypted, $encrypted_mdc);
  return decode_decrypted_data($decrypted);
}

sub can_decrypt_sym_with_gcrypt {
  my ($info) = @_;
  return 0 unless $have_gcrypt && $info && defined($info->{'secret'});
  return 0 if ($info->{'s2kalgo'} || 0) != 10;
  return 0 if ($info->{'cipheralgo'} || 0) != 9;
  return 0 if ($info->{'s2kcnt'} || 0) > 0x70;
  return 1;
}


##
## gnupg agent functions
##

my $agent_sock;

sub find_agentsocket_with_gpgconf {
  $agentsocket = [];
  for (split("\n", `gpgconf --list-dirs`)) {
    $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), '');
    } 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 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, '--file-is-digest', '--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');
  die("sexp is not an unprotected private key\n") unless defined $pk;
  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;
  for (@{$info->{'mpis'}}, @{$info->{'smpis'}}) {
    $_ = $pk->nth_data(1, $_);
    die("missing mpi in privkey\n") unless $_;
  }
  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->{'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, $encrypted, $encrypted_mdc) = parse_encryted_data($encodeddata);
  return undef unless $einfo && $encrypted && can_decrypt_with_gcrypt($einfo);
  my ($fingerprint, $keygrip) = find_key_keycache($einfo->{'keyid'}, 'e');
  my $info = gpg_keygrip_to_info($gnupghome, $keygrip, $fingerprint);
  return undef unless $info;
  my $decrypted = decrypt_with_gcrypt($info, $einfo, $encrypted, $encrypted_mdc);
  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 $info = read_encparams_sym($phrasefile, $keyid, $use_gcrypt_decrypt && $have_gcrypt ? 1 : 0);
  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 = substr($edata, 10);
  if ($use_gcrypt_decrypt && $have_gcrypt && can_decrypt_sym_with_gcrypt($info)) {
    return decrypt_sym_with_gcrypt($info, $s2ksalt, $edata, 1);
  }
  # 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);
  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, $encrypted, $encrypted_mdc) = parse_sym_encryted_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'};
  die("unexpected gpg encrypted data\n") if !$encrypted_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 && $have_gcrypt) {
    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 $sig = agent_rpc("PKSIGN", $phrasefile);
  my ($pgppubalgo, @mpis) = parse_sexp_signature($sig);
  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, "--file-is-digest", "--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) = @_;

  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 && $have_gcrypt && $use_gcrypt_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;
  }
  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) {
      $lout = eval { sign_with_gcrypt($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");
  if ($sockproto && $sockproto eq 'ssl') {
    my %sslconf;
    $sslconf{'SSL_verify_mode'} = &IO::Socket::SSL::SSL_VERIFY_PEER;
    $sslconf{'SSL_key_file'} = $ssl_keyfile if $ssl_keyfile;
    $sslconf{'SSL_cert_file'} = $ssl_certfile if $ssl_certfile;
    $sslconf{'SSL_ca_file'} = $ssl_verifyfile if $ssl_verifyfile;
    $sslconf{'SSL_ca_path'} = $ssl_verifydir if $ssl_verifydir;
    my $ssl = IO::Socket::SSL->start_SSL(\*CS, %sslconf);
    die("ssl handshake failed: $IO::Socket::SSL::SSL_ERROR\n") unless $ssl;
    *CS = $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);
}


##
## main server code follows
##

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 = $s[1];
    next;
  }
  if ($s[0] eq 'proto:') {
    $sockproto = $s[1];
    next;
  }
  if ($s[0] eq 'ssl_keyfile:') {
    $ssl_keyfile = $s[1];
    next;
  }
  if ($s[0] eq 'ssl_certfile:') {
    $ssl_certfile = $s[1];
    next;
  }
  if ($s[0] eq 'ssl_verifyfile:') {
    $ssl_verifyfile = $s[1];
    next;
  }
  if ($s[0] eq 'ssl_verifydir:') {
    $ssl_verifydir = $s[1];
    next;
  }
  if ($s[0] eq 'proxyport:') {
    $proxyport = $s[1];
    next;
  }
  if ($s[0] eq 'proxyproto:') {
    $proxysockproto = $s[1] || '';
    next;
  }
  if ($s[0] eq 'proxyssl_keyfile:') {
    $proxyssl_keyfile = $s[1] || '';
    next;
  }
  if ($s[0] eq 'proxyssl_certfile:') {
    $proxyssl_certfile = $s[1] || '';
    next;
  }
  if ($s[0] eq 'proxyssl_verifyfile:') {
    $proxyssl_verifyfile = $s[1] || '';
    next;
  }
  if ($s[0] eq 'proxyssl_verifydir:') {
    $proxyssl_verifydir = $s[1] || '';
    next;
  }
  if ($s[0] eq 'allow:') {
    shift @s;
    push @allows, @s;
    next;
  }
  if ($s[0] eq 'allow_subject:') {
    @s = split(' ', $_, 2);
    shift @s;
    push @allow_subject, @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:') {
    next;
  }
  if ($s[0] eq 'phrases:') {
    $phrases = $s[1];
    next;
  }
  if ($s[0] eq 'aliases:') {
    $aliases = $s[1];
    next;
  }
  if ($s[0] eq 'encryptionkeys:') {
    $encryptionkeys = $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-unprivileged-ports:') {
    $use_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 'use-gcrypt:') {
    $s[1] = 1 if $s[1] =~ /^true$/i;
    @s = split(',', $s[1]);
    $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;
    next;
  }
  if ($s[0] eq 'logfile:') {
    $logfile = $s[1];
    next;
  }
  if ($s[0] eq 'pidfile:') {
    $pidfile = $s[1];
    next;
  }
  if ($s[0] eq 'gnupghome:') {
    $ENV{GNUPGHOME} = $s[1];
    next;
  }
  if ($s[0] eq 'agentsocket:') {
    shift @s;
    $agentsocket = \@s;
    next;
  }
  if ($s[0] eq 'restricted_gnupghome:') {
    $restricted_gnupghome = $s[1];
    next;
  }
  if ($s[0] eq 'restricted_phrases:') {
    $restricted_phrases = $s[1];
    next;
  }
  if ($s[0] eq 'restricted_aliases:') {
    $restricted_aliases = $s[1];
    next;
  }
  if ($s[0] eq 'privileged_gnupghome:') {
    $privileged_gnupghome = $s[1];
    next;
  }
  if ($s[0] eq 'system_gnupghome:') {
    $system_gnupghome = $s[1];
    next;
  }
  if ($s[0] eq 'privileged_logfile:') {
    $privileged_logfile = $s[1];
    next;
  }
  if ($s[0] eq 'extranonce:') {
    $extranonce = $s[1];
    next;
  }
  if ($s[0] eq 'backup:') {
    shift @s;
    push @backup_locations, @s;
    next;
  }
  if ($s[0] eq 'backup_user:') {
    $backup_user = $s[1];
    next;
  }
}

$proxyport = $port unless defined $proxyport;
$proxysockproto = $sockproto unless defined $proxysockproto;
$proxyssl_certfile = $ssl_certfile unless defined $proxyssl_certfile;
$proxyssl_keyfile = $ssl_keyfile unless defined $proxyssl_keyfile;
$proxyssl_verifyfile = $ssl_verifyfile unless defined $proxyssl_verifyfile;
$proxyssl_verifydir = $ssl_verifydir unless defined $proxyssl_verifydir;

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();

# we need zlib to decompress gpg's compressed data packet
require Compress::Raw::Zlib if $use_gcrypt_decrypt && $have_gcrypt;

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 && $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);
}

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';
if (($proxysockproto || '') eq 'ssl') {
  die("no ssl_keyfile specified\n") unless $proxyssl_keyfile;
  die("keyfile '$proxyssl_keyfile' does not exist\n") unless -f $proxyssl_keyfile;
  die("no ssl_certfile specified\n") unless $proxyssl_certfile;
  die("certfile '$proxyssl_certfile' does not exist\n") unless -f $proxyssl_certfile;
}
require IO::Socket::SSL if ($sockproto || '') eq 'ssl' || ($proxysockproto || '') eq 'ssl';

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");

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') {
  #$IO::Socket::SSL::DEBUG = 4;
  my %sslconf = ( SSL_cert_file => $proxyssl_certfile, SSL_key_file => $proxyssl_keyfile );
  $sslconf{'SSL_verify_mode'} = &IO::Socket::SSL::SSL_VERIFY_FAIL_IF_NO_PEER_CERT | &IO::Socket::SSL::SSL_VERIFY_PEER;
  $sslconf{'SSL_ca_file'} = $proxyssl_verifyfile if $proxyssl_verifyfile;
  $sslconf{'SSL_ca_path'} = $proxyssl_verifydir if $proxyssl_verifydir;
  my $ssl = IO::Socket::SSL->start_SSL(\*CLNT, SSL_server => 1, %sslconf);
  die("ssl handshake failed: $IO::Socket::SSL::SSL_ERROR\n") unless $ssl;
  *CLNT = $ssl;
  if (@allow_subject) {
    my $cert = $ssl->peer_certificate();
    die("could not get peer certificate\n") unless $cert;
    my $subject = Net::SSLeay::X509_get_subject_name($cert);
    die("could not get subject from peer certificate\n") unless $subject;
    $subject = Net::SSLeay::X509_NAME_print_ex($subject, &Net::SSLeay::XN_FLAG_RFC2253);
    die("could not convert certificate subject to text\n") unless $subject;
    $allowed = undef;
    for my $as (@allow_subject) {
      if ($as =~ /^\/(.*)\/$/) {
	my $as_re = $1;
        next unless $subject =~ /$as_re/;
      } else {
        next unless $subject eq $as;
      }
      $allowed = 1;
      last;
    }
    die("certificate denied: $subject\n") unless $allowed;
  }
}


### commands

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

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

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];
  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;
  ($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;
  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 && $have_gcrypt ? {} : undef;
  my $pubkey = priv2pub($privkey, $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 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");
}

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

my %privileged_cmds = (
  'sign'	=> [ \&cmd_privileged_sign,       1, [ 'restricted' ] ],
  'pubkey'	=> [ \&cmd_privileged_pubkey,     1, [ 'restricted' ] ],
  'keylist'	=> [ \&cmd_privileged_keylist,    0, [ 'standard', 'restricted', 'privileged' ] ],
  'keyphrases'	=> [ \&cmd_privileged_keyphrases, 0, [ 'standard', 'restricted' ] ],
  'keygen'	=> [ \&cmd_privileged_keygen,     0, [ 'standard', 'restricted' ] ],
  'keydel'	=> [ \&cmd_privileged_keydel,     1, [ 'standard', 'restricted', 'privileged' ] ],
  'keyextend'	=> [ \&cmd_privileged_keyextend,  1, [ 'standard', 'restricted' ] ],
  'keycvt'	=> [ \&cmd_privileged_keycvt,     1, [ 'standard', 'restricted' ] ],
  'aliaslist'	=> [ \&cmd_privileged_aliaslist,  0, [ 'standard', 'restricted' ] ],
  'aliasgen'	=> [ \&cmd_privileged_aliasgen,   1, [ 'standard', 'restricted' ] ],
  'aliasdel'	=> [ \&cmd_privileged_aliasdel,   1, [ 'standard', 'restricted' ] ],
  'enckeylist'	=> [ \&cmd_privileged_enckeylist, 0, [ 'standard' ] ],
  'enckeygen'	=> [ \&cmd_privileged_enckeygen,  0, [ 'standard' ] ],
  'enckeydel'	=> [ \&cmd_privileged_enckeydel,  1, [ 'standard' ] ],
  'backup'	=> [ \&cmd_privileged_backup,     0, [ 'system' ] ],
  'log'		=> [ \&cmd_privileged_log,        0, [ 'system' ] ],
);

sub privileged_switch_gnupghome {
  my ($keyring, $allow_privileged, $allow_system) = @_;
  my $oldgnupghome = $ENV{'GNUPGHOME'};
  die("bad keyring in privileged_switch_gnupghome\n") if $keyring eq 'privileged' && !$allow_privileged;
  die("bad keyring in privileged_switch_gnupghome\n") if $keyring eq 'system' && !$allow_system;
  my $gnupghome;
  $gnupghome = $oldgnupghome if $keyring eq 'standard';
  $gnupghome = $restricted_gnupghome if $keyring eq 'restricted';
  $gnupghome = $system_gnupghome if $keyring eq 'system';
  $gnupghome = $privileged_gnupghome if $keyring eq 'privileged';
  die("keyring $keyring is not configured\n") unless $gnupghome;
  switch_gnupghome($gnupghome);
  return $oldgnupghome;
}

sub privileged_get_aliasdir {
  my ($keyring, $mustexist) = @_;
  my $aliasdir;
  $aliasdir = $restricted_aliases if $keyring eq 'restricted';
  $aliasdir = $aliases if $keyring eq 'standard';
  if ($mustexist) {
    die("aliases are not configured for keyring $keyring\n") unless $aliasdir;
    die("aliases directory $aliasdir does not exist\n") unless -d $aliasdir;
  }
  return $aliasdir;
}

sub privileged_get_phrasedir {
  my ($keyring, $mustexist) = @_;
  my $phrasedir;
  $phrasedir = $restricted_phrases if $keyring eq 'restricted';
  $phrasedir = $phrases if $keyring eq 'standard';
  if ($mustexist) {
    die("phrases are not configured for keyring $keyring\n") unless $phrasedir;
    die("phrases directory $phrasedir does not exist\n") unless -d $phrasedir;
  }
  return $phrasedir;
}

sub privileged_map_user {
  my ($keyring, $user) = @_;
  my $phrasedir = privileged_get_phrasedir($keyring);
  my $aliasdir = privileged_get_aliasdir($keyring);
  $user = read_alias($aliasdir, $user) if $aliasdir && -e "$aliasdir/$user";
  die("unknown key: $user\n") unless $phrasedir && -e "$phrasedir/$user";
  return ($user, $phrasedir, $aliasdir);
}

sub cmd_privileged_sign {
  my ($cmd, $user, $hashalgo, $keyring, @args) = @_;
  die("usage: sign <arg>\n") unless @args == 1;
  my $phrasedir;
  ($user, $phrasedir) = privileged_map_user($keyring, $user);
  my $oldgnupghome = privileged_switch_gnupghome($keyring);
  undef $keycache;	# hack
  my ($status, $out, $err) = do_sign_multiple("$phrasedir/$user", $user, undef, $hashalgo, $args[0]);
  switch_gnupghome($oldgnupghome);
  return ($status, $err, $out);
}

sub cmd_privileged_pubkey {
  my ($cmd, $user, $hashalgo, $keyring, @args) = @_;
  die("excess arguments\n") unless @args == 0;
  ($user) = privileged_map_user($keyring, $user);
  my $oldgnupghome = privileged_switch_gnupghome($keyring);
  my $pubkey = rungpg_fatal('/dev/null', undef, $gpg, '--export', '-a', $user);
  switch_gnupghome($oldgnupghome);
  return (0, '', $pubkey);
}

sub cmd_privileged_keylist {
  my ($cmd, $user, $hashalgo, $keyring, @args) = @_;
  die("excess arguments\n") unless @args == 0;
  my $oldgnupghome = privileged_switch_gnupghome($keyring, 1);
  my $result= rungpg_fatal('/dev/null', undef, $gpg, '--list-keys');
  switch_gnupghome($oldgnupghome);
  return (0, '', $result);
}

sub cmd_privileged_keyphrases {
  my ($cmd, $user, $hashalgo, $keyring, @args) = @_;
  die("excess arguments\n") unless @args == 0;
  my $phrasedir = privileged_get_phrasedir($keyring);
  my $result = '';
  $result .= "$_\n" for ls($phrasedir);
  return (0, '', $result);
}

sub cmd_privileged_keydel {
  my ($cmd, $user, $hashalgo, $keyring, @args) = @_;
  die("excess arguments\n") unless @args == 0;
  my $phrasedir;
  ($user, $phrasedir) = privileged_map_user($keyring, $user);
  my $oldgnupghome = privileged_switch_gnupghome($keyring, 1);
  my ($efpr) = find_key($user, 'e');
  die("key '$user' has an encrytion subkey\n") if $efpr;
  my ($fpr) = find_key($user);
  die("could not determine fingerprint of key '$user'\n") unless $fpr;
  rungpg_fatal('/dev/null', undef, $gpg, '--batch', '--yes', '--delete-secret-and-public-key', $fpr);
  unlink("$phrasedir/$user");
  switch_gnupghome($oldgnupghome);
  return (0, '', '');
}

sub cmd_privileged_keygen {
  my ($cmd, $user, $hashalgo, $keyring, @args) = @_;
  die("usage: keygen <type> <days> <name> <email> [alias]\n") unless @args == 4 || @args == 5;
  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 $alias = $args[4];
  my $aliasdir = privileged_get_aliasdir($keyring, $alias ? 1 : 0);
  my $phrasedir = privileged_get_phrasedir($keyring, 1);
  my ($tdir) = prepare_tmp_gnupghome();
  my $length;
  ($type, $length) = split_length_from_type($type);
  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);
  my $oldgnupghome = privileged_switch_gnupghome($keyring);
  my $out = rungpg_fatal('/dev/null', $tdir, $gpg, '--batch', '--status-fd=1', '--no-secmem-warning', '--gen-key', "$tdir/params");
  remove_tree($tdir);
  die("could not determine key id of generated key\n") if $out !~ /KEY_CREATED P ([0-9A-F]{40,})/s;
  my $keyid = substr($1, -16);
  spew("$phrasedir/$keyid", '');
  write_alias($aliasdir, $keyid, $alias) if $alias;
  my $pubkey = rungpg_fatal('/dev/null', undef, $gpg, '--export', '-a', $keyid);
  switch_gnupghome($oldgnupghome);
  return (0, '', $pubkey);
}

sub cmd_privileged_keyextend {
  my ($cmd, $user, $hashalgo, $keyring, @args) = @_;
  die("usage: keyextend <days>\n") unless @args == 1;
  my $expire = $args[0];
  die("bad expire format\n") unless $expire =~ /^\d{1,10}$/s;
  my $phrasedir;
  ($user, $phrasedir) = privileged_map_user($keyring, $user);
  # gpg does not support to specify the expire as argument on the cmd line
  my ($tdir) = prepare_tmp_gnupghome();
  spew("$tdir/params", "expire\n${expire}d\nsave\n");
  my $oldgnupghome = privileged_switch_gnupghome($keyring);
  rungpg_fatal("$phrasedir/$user", $tdir, $gpg, '--batch', '--no-secmem-warning', '--passphrase-fd=0', '--command-file', "$tdir/params", '--edit-key', $user);
  remove_tree($tdir);
  my $pubkey = rungpg_fatal('/dev/null', undef, $gpg, '--export', '-a', $user);
  switch_gnupghome($oldgnupghome);
  return (0, '', $pubkey);
}

sub cmd_privileged_keycvt {
  my ($cmd, $user, $hashalgo, $keyring, @args) = @_;
  die("excess arguments\n") unless @args == 0;
  my $aliasdir = privileged_get_aliasdir($keyring);
  $aliasdir = privileged_get_aliasdir($keyring, 1) if $aliasdir;
  my $phrasedir = privileged_get_phrasedir($keyring, 1);
  die("unknown key: $user\n") unless $phrasedir && -e "$phrasedir/$user";
  my $oldgnupghome = privileged_switch_gnupghome($keyring);
  my ($fpr) = find_key($user);
  die("could not determine fingerprint of key '$user'\n") unless $fpr;
  my $keyid = substr($fpr, -16);
  die("phrases entry for $keyid already exists\n") if -e "$phrasedir/$keyid";
  rename("$phrasedir/$user", "$phrasedir/$keyid") || die("rename $phrasedir/$user $phrasedir/$keyid: $!\n");
  switch_gnupghome($oldgnupghome);
  write_alias($aliasdir, $keyid, $user) if $aliasdir && ! -e "$aliasdir/$user";
  return (0, '', '');
}

sub cmd_privileged_enckeygen {
  my ($cmd, $user, $hashalgo, $keyring, @args) = @_;
  if (@args && $args[0] eq 'sym') {
    my $keyid = do_keygen_sym();
    return(0, '', "$keyid\n");
  }
  die("please specify a user\n") if $user eq '-';
  die("usage: enckeygen <type> <days>\n") unless @args == 2;
  my $type = $args[0];
  my $expire = $args[1];
  die("bad expire format\n") unless $expire =~ /^\d{1,10}$/s;
  if ($type =~ /^(rsa|elg)\@(2048|4096)$/) {
    $type =~ s/\@//;
  } elsif ($type ne 'cv25519') {
    die("bad type: $type\n");
  }
  my $phrasedir;
  ($user, $phrasedir) = privileged_map_user($keyring, $user);
  my $oldgnupghome = privileged_switch_gnupghome($keyring);
  my ($fpr) = find_key($user);
  die("could not determine fingerprint of key '$user'\n") unless $fpr;
  my ($efpr) = find_key($user, 'e');
  die("key '$user' already has an encryption key\n") if $efpr;
  rungpg_fatal("$phrasedir/$user", undef, $gpg, '--batch', '--no-secmem-warning', '--passphrase-fd=0', '--quick-add-key', $fpr, $type, 'encr', "${expire}d");
  my $pubkey = rungpg_fatal('/dev/null', undef, $gpg, '--export', '-a', $user);
  switch_gnupghome($oldgnupghome);
  return (0, '', $pubkey);
}

sub cmd_privileged_enckeydel {
  my ($cmd, $user, $hashalgo, $keyring, @args) = @_;
  die("excess arguments\n") unless @args == 0;
  if ($encryptionkeys && -e "$encryptionkeys/$user") {
    unlink("$encryptionkeys/$user");
    return (0, '', '');
  }
  my $phrasedir;
  ($user, $phrasedir) = privileged_map_user($keyring, $user);
  my $oldgnupghome = privileged_switch_gnupghome($keyring);
  my ($fpr) = find_key($user);
  die("could not determine fingerprint of key '$user'\n") unless $fpr;
  my ($efpr) = find_key($user, 'e');
  die("key '$user' does not have an encryption key\n") unless $efpr;
  die("the enctyption key for '$user' is the primary key\n") if $fpr eq $efpr;
  rungpg_fatal('/dev/null', undef, $gpg, '--batch', '--yes', '--delete-secret-and-public-key', "$efpr!");
  switch_gnupghome($oldgnupghome);
  return (0, '', '');
}

sub cmd_privileged_enckeylist {
  my ($cmd, $user, $hashalgo, $keyring, @args) = @_;
  my $result = '';
  for my $keyid (ls($encryptionkeys)) {
    my $info = eval { read_encparams_sym("$encryptionkeys/$keyid", $keyid) };
    my $istr = '';
    $istr .= "$_=$info->{$_}," for grep {$info && defined($info->{$_})} qw{version created s2kalgo s2kcnt cipheralgo};
    $result .= "$keyid  ".substr($istr || 'broken,', 0, -1)."\n";
  }
  return (0, '', $result);
}

sub cmd_privileged_aliaslist {
  my ($cmd, $user, $hashalgo, $keyring, @args) = @_;
  die("excess arguments\n") unless @args == 0;
  my $aliasdir = privileged_get_aliasdir($keyring);
  my $phrasedir = privileged_get_phrasedir($keyring);
  my $result = '';
  for my $alias (ls($aliasdir)) {
    my $isenc = $alias =~ /^:enc/ ? 1 : 0;
    my $user = read_alias($aliasdir, $alias, $isenc);
    my $dead = ' (dead)';
    $dead = '' if $isenc && $encryptionkeys && -e "$encryptionkeys/$user";
    $dead = '' if $phrasedir && -e "$phrasedir/$user";
    $result .= "$alias -> $user$dead\n";
  }
  return (0, '', $result);
}

sub cmd_privileged_aliasgen {
  my ($cmd, $user, $hashalgo, $keyring, @args) = @_;
  die("usage: aliasgen <alias>\n") unless @args == 1;
  my $alias = $args[0];
  my $aliasdir = privileged_get_aliasdir($keyring, 1);
  write_alias($aliasdir, $user, $alias);
  return (0, '', '');
}

sub cmd_privileged_aliasdel {
  my ($cmd, $user, $hashalgo, $keyring, @args) = @_;
  die("excess arguments\n") unless @args == 0;
  my $aliasdir = privileged_get_aliasdir($keyring);
  die("unknown alias: $user\n") unless $aliasdir && -e "$aliasdir/$user";
  unlink("$aliasdir/$user");
  return (0, '', '');
}

sub cmd_privileged_backup {
  my ($cmd, $user, $hashalgo, $keyring, @args) = @_;
  die("no backup key configured\n") unless $backup_user;
  die("no backup locations configured\n") unless @backup_locations;
  my @bl = @backup_locations;
  for (@bl) {
    s/^\/+//;
    die("cannot backup complete filesystem\n") unless $_;
  }
  # create backup tar
  my $tdir = create_tmpdir();
  my $tarfile = "$tdir/backup.tar";
  my $encfile = "$tdir/backup.enc";
  unlink($tarfile);
  unlink($encfile);
  rungpg_fatal('/dev/null', $tdir, 'tar', '-C', '/', '-cf', $tarfile, @bl);

  # encrypt file
  my $oldgnupghome = privileged_switch_gnupghome('system', 0, 1);
  rungpg_fatal('/dev/null', $tdir, $gpg, '--batch', '--encrypt', '--no-verbose', '--no-secmem-warning', '--trust-model', 'always', '--no-auto-key-locate', '-o', $encfile, '-r', $backup_user, $tarfile);
  switch_gnupghome($oldgnupghome);
  unlink($tarfile);

  my $fd;
  open($fd, '<', $encfile) || die("$encfile: $!\n");
  remove_tree($tdir);
  privileged_replyfile($fd, $encfile);
  close($fd);
  return (0, '', '');
}

sub cmd_privileged_log {
  my ($cmd, $user, $hashalgo, $keyring, @args) = @_;
  my $fd;
  open($fd, '<', $privileged_logfile) || die("$privileged_logfile: $!\n");
  privileged_replyfile($fd, $privileged_logfile);
  close($fd);
  return (0, '', '');
}

sub privileged_replyfile {
  my ($fd, $filename) = @_;
  my $size = -s $fd;
  # send back reply (cannot use reply() as it closes the socket)
  my $ret = pack('nn', 1, length($size)).$size;
  $ret = pack("nnn", 0, length($ret), 0).$ret;
  swrite(*CLNT, $ret);
  # send back file
  while ($size > 0) {
    my $buf = '';
    my $r = sysread($fd, $buf, $size > 8192 ? 8192 : $size);
    die("$filename: $!\n") unless defined $r;
    die("$filename: unexpected EOF\n") unless $r;
    swrite(*CLNT, $buf);
    $size -= length($buf);
  }
  close CLNT;
}

sub privileged_generate_nonce {
  my ($now, $logfdlen) = @_;
  $now = int($now / 600);
  return Digest::SHA::sha256_hex("$extranonce/$now/$logfdlen");
}

sub privileged_verify_signature {
  my ($signature, $now, $logfdlen, $algouser, $keyring, @args) = @_;
  my $oldgnupghome = privileged_switch_gnupghome('privileged', 1);
  my $tdir = create_tmpdir();
  my ($status, $out, $err);
  spew("$tdir/sig", pack('H*', $signature));
  for my $tdelta (0, 600) {
    spew("$tdir/data", "privileged\0$algouser\0$keyring\0".privileged_generate_nonce($now - $tdelta, $logfdlen)."\0".join("\0", @args));
    ($status, $out, $err) = rungpg('/dev/null', undef, $gpg, '--no-secmem-warning', '--batch', '--status-fd=1', '--verify', "$tdir/sig", "$tdir/data");
    last unless $status;
  }
  switch_gnupghome($oldgnupghome);
  remove_tree($tdir);
  die("bad signature\n") if $status;
  die("bad status output\n") unless $out =~ /^\[GNUPG:\] GOODSIG ([0-9A-F]+) (.*)$/m;
  my ($keyid, $user) = ($1, $2);
  die("cannot extract email from user $user\n") unless $user =~ /(\<\S+\>)/;
  return "$keyid$1";
}

sub privileged_log {
  my ($logfd, $logline) = @_;
  $logline =~ s/[\r\n].*//s;
  $logline =~ s/[\000-\037\177]//g;
  $logline = "$logline\n";
  die("privlog write: $!\n") unless syswrite($logfd, $logline) == length($logline);
}

sub cmd_privileged {
  my ($cmd, $user, $hashalgo, @args) = @_;
  die("privileged mode is not configured\n") unless $privileged_logfile && $privileged_gnupghome;
  if (@args == 1 && $args[0] eq 'nonce') {
    my $logfdlen = (-s $privileged_logfile) || 0;
    my $nonce = privileged_generate_nonce(time(), $logfdlen);
    return (0, '', $nonce);
  }
  -d $tmpdir || mkdir($tmpdir, 0700) || die("$tmpdir: $!\n");
  die("privileged: please specify a user\n") unless $user;
  die("privileged: bad number of arguments\n") unless @args >= 3;
  die("privileged: oldproto is not supported\n") if $oldproto;
  my ($keyring, $signature, $pcmd) = splice(@args, 0, 3);
  die("privileged: bad keyring '$keyring'\n") if $keyring ne 'standard' && $keyring ne 'restricted' && $keyring ne 'privileged' && $keyring ne 'system';
  die("privileged: no system keyring configured\n") if $keyring eq 'system' && !$system_gnupghome;
  die("privileged: no restricted keyring configured\n") if $keyring eq 'restricted' && !$restricted_gnupghome;
  die("bad signature\n") unless $signature =~ /^\A[0-9a-fA-F]+\z/s;
  my $handler = $privileged_cmds{$pcmd};
  die("unknown command: $pcmd\n") unless $handler;
  die("please specify a user\n") if $user eq '-' && $handler->[1];
  die("$pcmd: keyring must be ".join('|', @{$handler->[2]})."\n") unless grep {$keyring eq $_} @{$handler->[2]};

  my $logfd;
  open($logfd, '>>', $privileged_logfile) || die("$privileged_logfile: $!\n");
  flock($logfd, LOCK_EX) || die("flock $privileged_logfile: $!\n");
  my $now = time();
  my $logfdlen = -s $logfd;
  my $privileged_user = eval { privileged_verify_signature($signature, $now, $logfdlen, "$hashalgo:$user", $keyring, $pcmd, @args) };
  if ($@) {
    privileged_log($logfd, "auth $now $@");
    sleep(5);
    close($logfd);
    die($@);
  }
  privileged_log($logfd, "req $now $privileged_user $user $hashalgo $keyring $pcmd @args");
  my ($status, $err, @out);
  eval { ($status, $err, @out) = $handler->[0]->($pcmd, $user, $hashalgo, $keyring, @args) };
  ($status, $err) = (1, $@) if $@;
  $now = time();
  if ($status) {
    privileged_log($logfd, "fail $now $status ".(split(/[\r\n]/, $err || 'unknown error'))[-1]);
  } else {
    privileged_log($logfd, "ok $now");
  }
  close($logfd);
  exit(0) if !$status && ($pcmd eq 'backup' || $pcmd eq 'log');		# already replied
  return ($status, $err, @out);
}

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


## 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 > 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;
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') {
  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);

