#!/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 SOCK_STREAM SOL_SOCKET SO_REUSEADDR SO_KEEPALIVE INADDR_ANY inet_aton inet_ntoa sockaddr_in getnameinfo/;
use POSIX;
use Math::BigInt;
use MIME::Base64;
use Encode;
use bytes;
use File::Temp qw/tempdir/;
use File::Path qw/remove_tree/;

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 @pinentrymode;

# 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 != 255) {
      $len = (($len - 192) << 8) + unpack('C', substr($pkg, 2)) + 192;
      $off = 3;
    } else {
      $len = unpack('N', substr($pkg, 2));
      $off = 5;
    }
  } 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) == 1) {
      $len = unpack('N', substr($pkg, 1));
      $off = 6;
    } 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 priv2pub {
  my ($privkey) = @_;
  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 $mpinum;
    if ($pkalgo == 1) {
      # RSA
      $mpinum = 2;
    } elsif ($pkalgo == 17) {
      $mpinum = 4;
    } elsif ($pkalgo == 16) {
      $mpinum = 3;
    } elsif ($pkalgo == 20) {
      $mpinum = 3;
    } else {
      die("unknown public key algorithm $pkalgo\n");
    }
    while ($mpinum > 0) {
      #print "MPI\n";
      my $ml = unpack('n', substr($pack, $mpioff));
      $ml = (($ml + 7) >> 3) + 2;
      $mpioff += $ml;
      $mpinum--;
    }
    $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 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 {
  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");
    }
    die("not an RSA private key\n") unless $pkalgo == 1;
    $pack = substr($pack, $mpioff);
    my @s;
    for my $i (0, 1, 2, 3, 4, 5) {
      if ($i == 2) {
        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);
    }
    close(F);
    # 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 = chr(0x30).packlen(length($asn1)).$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;
  }
  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 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 $@;
}

local *F;
my $testmode = (($ARGV[0] || '') eq '-t') ? 1 : 0;
$testmode = 2 if ($ARGV[0] || '') eq '--test-sign';
$conf = $ENV{SIGN_CONF} if $testmode && $ENV{SIGN_CONF};
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 'patchclasstime:') {
    $patchclasstime = $s[1];
    next;
  }
  if ($s[0] eq 'allow-unprivileged-ports:') {
    $allow_unprivileged_ports = ($s[1] =~ /^true$/i) ? 1 : 0;
  }
  if ($s[0] eq 'logfile:') {
    $logfile = $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();

my @argv;

if ($testmode) {
  die("test mode need phrases\n") unless $phrases;
  # test mode
  $| = 1;
  if ($testmode == 2) {
    *CLNT = *STDIN;
    @argv = readreq();
  } else {
    @argv = @ARGV;
    shift @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));
  } else {
    $oldproto = 1;
    if ($userlen == 0 && $arg == 0) {
      @argv = ('ping', '');
    } else {
      @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;
}

# 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");
  my %blacklist;
  # bindresvport
  if (open(BL, "</etc/bindresvport.blacklist")) {
    while(<BL>) {
      chomp;
      next unless /^\s*(\d+)/;
      $blacklist{0 + $1} = 1;
    }
    close BL;
  }
  my $po;
  while (1) {
    for ($po = 600; $po < 1024; $po++) {
      next if $blacklist{$po};
      last if bind(CS, sockaddr_in($po, INADDR_ANY));
    }
    last if $po < 1024;
    sleep(3);
  }
  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) = @_;
  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);
    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);
    die("$err\n");
  }
  return $out;
}

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 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');
  die("bad type: $type\n") unless $type =~ /^(dsa|rsa)\@(1024|2048|4096)$/s;
  my $length = $2;
  $type = $1;

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

  # write params file
  my $batch = "Key-Type: $type\nKey-Length: $length\nKey-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);
}

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;
  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.$$");
  # 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);
  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 = '';
  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) = rungpg('/dev/null', undef, $gpg, "--batch", "--force-v3-sigs", "--files-are-digests", "--allow-non-selfsigned-uid", "--digest-algo=$hashalgo", "--no-verbose", "--no-armor", "--no-secmem-warning", "--ignore-time-conflict", @pinentrymode, "--passphrase-fd=0", "-sbo", "-", $args[0]);
    $lout = patchclasstime($lout, $classtime) if $classtime && !$status;
    shift @args;
    push @out, $lout;
    $err .= $lerr;
    last if $status;
  }
  remove_tree($tdir);
  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) = rungpg("$phrases/$user", undef, $gpg, "--batch", "--force-v3-sigs", "--files-are-digests", "--digest-algo=$hashalgo", "--no-verbose", "--no-armor", "--no-secmem-warning", "--ignore-time-conflict", @pinentrymode, "--passphrase-fd=0", "-u", $user, "-sbo", "-", $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,
);

my $hashalgo = 'SHA1';
my $cmd = shift(@argv);
my $user = shift(@argv) || '';
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 '';

if (!$phrases || ($cmd ne 'ping' && $user eq '') || ($cmd ne 'ping' && ! -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);
}

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

