##
## support for directly signing with a tpm chip with shadowed keys
##

# currently needed to parse the private key
use Crypt::GCrypt::Sexp;

my $tpm_ctxcache = '';
my $tpm_device = '/dev/tpmrm0';
my $tpm_lock;

my $tpm_rm;
my $tpm_lock_fd;

sub tpm_initialize {
  my $tpmfd;
  die("$tpm_device: $!\n") unless open($tpmfd, '+<', $tpm_device);
  close $tpmfd;
  $tpm_rm = 1 if $tpm_device =~ /tpmrm/;
  tpm_flush_keyctx() if $tpm_ctxcache;
  die("need a tpm lock file\n") if !$tpm_rm && !$tpm_lock;
}

sub can_sign_with_tpm {
  my ($info) = @_;
  return 0 unless $info && $info->{'algo'};
  return 0 unless $info->{'shadowed-tpm2-v1'} && $info->{'shadowed-tpm2-v1'}->[0] ne 'pkcs11';
  return 1 if $info->{'algo'} == 1;
  return 1 if $info->{'algo'} == 19;
  return 0;
}

sub tpm_open {
  my $tpmfd;
  if (!$tpm_rm) {
    open($tpm_lock_fd, '>>', $tpm_lock) || die("$tpm_lock: $!\n");
    flock($tpm_lock_fd, LOCK_EX) || die("tpm lock flock: $!\n");
    fcntl($tpm_lock_fd, F_SETFD, FD_CLOEXEC);
  }
  open($tpmfd, '+<', $tpm_device) || die("$tpm_device: $!\n");
  fcntl($tpmfd, F_SETFD, FD_CLOEXEC);
  return $tpmfd;
}

sub tpm_close {
  my ($tpmfd) = @_;
  close($tpmfd);
  close($tpm_lock_fd) unless $tpm_rm;
}

my $tpm_auth_null_pw = pack('NnCn', 0x40000009, 0, 0, 0);
my $tpm_ticket_null_hashcheck = pack('nNn', 0x8024, 0x40000007, 0);

my $tpm_alg_sha1   = 0x04;
my $tpm_alg_aes    = 0x06;
my $tpm_alg_sha256 = 0x0b;
my $tpm_alg_sha512 = 0x0d;
my $tpm_alg_null   = 0x10;
my $tpm_alg_rsassa = 0x14;
my $tpm_alg_ecdsa  = 0x18;
my $tpm_alg_ecc    = 0x23;
my $tpm_alg_cfb    = 0x43;

my $tpm_ecc_nist_p256 = 0x03;

sub tpm_pw_auth {
  my ($pw) = @_;
  return pack('NnCn', 0x40000009, 0, 0, length($pw)).$pw;
}

sub tpm_send {
  my ($fd, $cmd, $handle, $param, $auth) = @_;
  my $tag = $auth ? 0x8002  : 0x8001;
  die("tpm_send: need a handle for auth\n") if $auth && !$handle;
  my $c = $param;
  $c = pack('N', length($auth)).$auth.$c if $auth;
  $c = pack('N', $handle).$c if $handle;
  $c = pack('nNN', $tag, length($c) + 10, $cmd).$c;
  my $r = syswrite($fd, $c);
  die("tpm write: $!\n") unless $r && $r == length($c);
}

sub tpm_recv {
  my ($fd, $auth, $nhandle) = @_;
  my $c = '';
  my $r = sysread($fd, $c, 65536);
  die("tpm read: $!\n") unless $r && $r >= 10;
  my ($tag, $len, $res) = unpack('nNN', substr($c, 0, 10, ''));
  die("tpm read length mismatch\n") unless $r == $len;
  die("tpm read tag mismatch\n") unless $tag == ($auth && !$res ? 0x8002  : 0x8001);
  die(sprintf("tpm error: 0x%04x\n", $res)) if $res;
  die("unsupported nhandler size\n") unless defined($nhandle) && ($nhandle == 0 || $nhandle == 1);
  my $rhandle = $nhandle ? unpack('N', substr($c, 0, 4, '')) : undef;
  if ($tag == 0x8002) {
    die("tpm read length error\n") unless $r >= 4;
    my $pl = unpack('N', $c);
    die("tpm read length error\n") unless length($c) >= 4 + $pl;
    return $rhandle, substr($c, 4, $pl), substr($c, 4 + $pl);
  }
  return $rhandle, $c;
}

sub tpm_cmd {
  my ($fd, $cmd, $handle, $param, $auth, $nhandle) = @_;
  tpm_send($fd, $cmd, $handle, $param, $auth);
  return tpm_recv($fd, $auth, $nhandle);
}

sub tpm_getcap {
  my ($fd, $cap, $prop, $maxcnt) = @_;
  my $param = pack('NNN', $cap, $prop, $maxcnt);
  my $d = (tpm_cmd($fd, 0x017a, undef, pack('NNN', $cap, $prop, $maxcnt), undef, 0))[1];
  my ($more, $rcap, $rcnt) = unpack('CNN', $d);
  die("bad answer\n") unless $rcap == $cap;
  $d = substr($d, 9);
  return unpack('N*', $d) if $cap == 1;
  die("tpm_getcap: unsupported query\n");
}

sub tpm_flush_context {
  my ($fd, $handle) = @_;
  tpm_cmd($fd, 0x165, $handle, '', undef, 0);
}

sub tpm_context_save {
  my ($fd, $handle) = @_;
  return (tpm_cmd($fd, 0x162, $handle, '', undef, 0))[1];
}

sub tpm_context_load {
  my ($fd, $c) = @_;
  return (tpm_cmd($fd, 0x161, undef, $c, undef, 1))[0];
}

sub tpm_create_primary {
  my ($fd, $handle, $auth) = @_;
  my $sensitive = pack('nn', 0, 0);
  my $public = pack('nnNnnnnnnnN', $tpm_alg_ecc, $tpm_alg_sha256, 0x30472, 0, $tpm_alg_aes, 128, $tpm_alg_cfb, $tpm_alg_null, $tpm_ecc_nist_p256, $tpm_alg_null, 0);
  my $outside_info = '';
  my $param = pack('n', length($sensitive)).$sensitive.pack('n', length($public)).$public.pack('n', length($outside_info)).$outside_info.pack('N', 0);
  return (tpm_cmd($fd, 0x131, $handle, $param, $auth, 1))[0];
}

sub tpm_load {
  my ($fd, $handle, $private, $public, $auth) = @_;
  return (tpm_cmd($fd, 0x157, $handle, "$private$public", $auth, 1))[0];
}

sub tpm_sign {
  my ($fd, $handle, $sig_scheme, $sig_scheme_details, $digest, $auth) = @_;
  my $scheme = pack('nn', $sig_scheme, $sig_scheme_details);
  my $validation = $tpm_ticket_null_hashcheck;
  my $param = pack('n', length($digest)).$digest.$scheme.$validation;
  my ($rhandle, $rparam, $rauth) = tpm_cmd($fd, 0x15d, $handle, $param, $auth, 0);
  my ($rsig_scheme, $rdigest_alg, $siglen) = unpack('nnn', $rparam);
  die("reply signature scheme does not match request\n") if $rsig_scheme != $sig_scheme;
  if ($rsig_scheme == $tpm_alg_rsassa) {
    return substr($rparam, 6, $siglen);
  } elsif ($rsig_scheme == $tpm_alg_ecdsa) {
    my $siglen2 = unpack('n', substr($rparam, 6 + $siglen, 2));
    return substr($rparam, 6, $siglen), substr($rparam, 6 + $siglen + 2, $siglen2);
  }
  die("unsupported signature scheme\n");
}

sub tpm_flush_all_transient {
  my ($tpmfd) = @_;
  tpm_flush_context($tpmfd, $_) for tpm_getcap($tpmfd, 0x00000001, 0x80000000, 1024);
}

sub tpm_load_keyctx {
  my ($tpmfd, $keygrip) = @_;
  return undef unless $keygrip && $tpm_ctxcache && -s "$tpm_ctxcache/$keygrip";
  my $ctx = slurp("$tpm_ctxcache/$keygrip");
  return tpm_context_load($tpmfd, $ctx);
}

sub tpm_save_keyctx {
  my ($tpmfd, $handle, $keygrip) = @_;
  return unless $keygrip && $tpm_ctxcache && -d $tpm_ctxcache;
  my $ctx = tpm_context_save($tpmfd, $handle);
  spew("$tpm_ctxcache/.$$.$keygrip", $ctx);
  rename("$tpm_ctxcache/.$$.$keygrip", "$tpm_ctxcache/$keygrip");
}

sub tpm_flush_keyctx {
  return unless $tpm_ctxcache && -d $tpm_ctxcache;
  unlink("$tpm_ctxcache/$_") for ls($tpm_ctxcache);
}

sub tpm_disable_ctxcache {
  undef $tpm_ctxcache;
}

sub tpm_key2handle {
  my ($tpmfd, $tpmdata, $keygrip) = @_;
  die unless @{$tpmdata || []} == 3;
  my $handle;
  $handle = eval { tpm_load_keyctx($tpmfd, $keygrip) } if $keygrip;
  return $handle if $handle;
  my $h = tpm_create_primary($tpmfd, 0 + $tpmdata->[0], $tpm_auth_null_pw);
  $handle = eval { tpm_load($tpmfd, $h, $tpmdata->[2], $tpmdata->[1], $tpm_auth_null_pw) };
  my $err = $@;
  tpm_flush_context($tpmfd, $h);
  die $err if $err;
  eval { tpm_save_keyctx($tpmfd, $handle, $keygrip) } if $keygrip;
  return $handle;
}

sub tpm_keep_open_finalize {
  my ($tpm_keep_open) = @_;
  my $tpmfd = delete $tpm_keep_open->{'fd'};
  my $handle = delete $tpm_keep_open->{'handle'};
  tpm_flush_context($tpmfd, $handle) if $tpmfd && $handle && !$tpm_rm;
  tpm_close($tpmfd) if $tpmfd;
}

sub sign_with_tpm {
  my ($phrasefile, $info, $hash, $hashalgo, $replyv4) = @_;
  die("sign_with_tpm: missing fingerprint\n") unless $info->{'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 = $1;
  $hashalgo = lc($hashalgo);
  my $pgphashalgo = get_pgphashalgo($hashalgo);
  die("sign_with_tpm: bad hashalgo $hashalgo\n") unless $pgphashalgo;
  my $digest = pack('H*', $hash);
  my $digest_alg;
  $digest_alg = $tpm_alg_sha1 if $hashalgo eq 'sha1';
  $digest_alg = $tpm_alg_sha256 if $hashalgo eq 'sha256';
  $digest_alg = $tpm_alg_sha512 if $hashalgo eq 'sha512';
  die("sign_with_tpm: unsupported hash algo '$hashalgo'\n") unless $digest_alg;
  my $scheme;
  $scheme = $tpm_alg_rsassa if $info->{'algo'} == 1;
  $scheme = $tpm_alg_ecdsa if $info->{'algo'} == 19;
  die("sign_with_tpm: unsupported pubkey algo '$info->{'algo'}'\n") unless $scheme;
  my $passphrase = '';
  $passphrase = slurp_first_line($phrasefile) if defined $phrasefile;
  my $tpm_keep_open = $info->{'tpm_keep_open'};
  if ($info->{'will_sign_multiple'} && !$tpm_keep_open) {
    $info->{'tpm_keep_open'} = $tpm_keep_open = {};
    $info->{'tpm_finalizer'} = Signd::Finalize::new(sub {tpm_keep_open_finalize($tpm_keep_open)});
  }
  my ($tpmfd, $handle);
  if ($tpm_keep_open && $tpm_keep_open->{'fd'}) {
    $tpmfd = delete $tpm_keep_open->{'fd'};
    $handle = delete $tpm_keep_open->{'handle'};
  } else {
    $tpmfd = tpm_open();
    tpm_flush_all_transient($tpmfd) unless $tpm_rm;
    $handle = tpm_key2handle($tpmfd, $info->{'shadowed-tpm2-v1'}, $info->{'keygrip'});
  }
  my @sig;
  eval { @sig = tpm_sign($tpmfd, $handle, $scheme, $digest_alg, pack('H*', $hash), tpm_pw_auth($passphrase)) };
  if ($@) {
    tpm_flush_context($tpmfd, $handle) unless $tpm_rm;
    tpm_close($tpmfd);
    die($@);
  }
  if ($tpm_keep_open) {
    $tpm_keep_open->{'fd'} = $tpmfd;
    $tpm_keep_open->{'handle'} = $handle;
  } else {
    tpm_flush_context($tpmfd, $handle) unless $tpm_rm;
    tpm_close($tpmfd);
  }
  my $sigdata = join('', map {encodempi($_)} @sig);
  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 tpm_config {
  my ($cmd, @s) = @_;
  if ($cmd eq 'tpm_ctxcache:') {
    $tpm_ctxcache = $s[0];
  } elsif ($cmd eq 'tpm_device:') {
    $tpm_device = $s[0];
  } elsif ($cmd eq 'tpm_lock:') {
    $tpm_lock = $s[0];
  } else {
    return 0;
  }
  return 1;
}

sub tpm_init {
  eval { tpm_initialize($ENV{GNUPGHOME}) };
  warn($@) if $@;
  return $@ ? 0 : 1;
}

sub Signd::Finalize::new {
  bless($_[0], 'Signd::Finalize')
}

sub Signd::Finalize::DESTROY {
  $_[0]->()
}

return { 'init' => \&tpm_init, 'config' => \&tpm_config };
# vim: syntax=perl
