#!/usr/bin/perl
#
# Copyright (c) 2026 SUSE LLC
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License version 2 as
# published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program (see the file COPYING); if not, write to the
# Free Software Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
#
################################################################

use strict;

use Math::BigInt;
use Digest::SHA;
use Crypt::PKCS11;
use Crypt::PKCS11::Attributes;

BEGIN {
  # workaround for eddsa missing in Crypt::PKCS11
  *Crypt::PKCS11::CKK_EC_EDWARDS = sub {0x00000040} unless defined &Crypt::PKCS11::CKK_EC_EDWARDS;
  *Crypt::PKCS11::CKM_EDDSA = sub {0x00001057} unless defined &Crypt::PKCS11::CKM_EDDSA;
}

my $homedir;
my $pkcs11;

my $config = {};

sub read_config {
  my $fd;
  open($fd, '<', "$homedir/gpg-pkcs11-tpm.conf") || die("$homedir/gpg-pkcs11-tpm.conf: $!\n");
  while (<$fd>) {
    chomp;
    s/^\s+//;
    s/\s+$//;
    next if $_ eq '' || $_ =~ /^#/;
    $config->{$1} = 1 if /^(\S+)$/;
    $config->{$1} = $2 if /^(\S+)\s+(.*?)$/;
  }
  close($fd);
}

##########  PKCS11 helpers

sub pkcs11_init {
  die("No provider-library configured\n") unless $config->{'provider-library'};
  $pkcs11 = Crypt::PKCS11->new;
  $pkcs11->load($config->{'provider-library'});
  $pkcs11->Initialize;
}

sub pkcs11_free {
  $pkcs11->Finalize;
  $pkcs11->unload;
  undef $pkcs11;
}

sub pkcs11_generate_token_url {
  my ($slot_id) = @_;
  my $token_info = $pkcs11->GetTokenInfo($slot_id) or die("pkcs11_generate_token_url: could not get token info for slot $slot_id\n");
  return undef unless %$token_info;
  my $uri = '';
  for my $what (['model' => 'model'], ['manufacturerID' => 'manufacturer'], ['serialNumber' => 'serial'], ['label' => 'token']) {
    my $d = $token_info->{$what->[0]};
    $d = '' unless defined $d;
    $d =~ s/\s+$//;
    $d =~ s/([\000-\040<>;\"#\?&\+=%[\177-\377])/sprintf("%%%02X",ord($1))/sge;
    $uri .= ";$what->[1]=$d";
  }
  $uri =~ s/^./pkcs11:/;
  return $uri;
}

sub pkcs11_open_session {
  my ($rw) = @_;

  my $slot_id = $config->{'slot-id'};
  if (!defined $slot_id) {
    my $slot_list = $pkcs11->GetSlotList(1) or die "GetSlotList: " . $pkcs11->errstr;
    for my $sid (@$slot_list) {
      next if $config->{'token'} && (pkcs11_generate_token_url($sid) || '') ne $config->{'token'};
      $slot_id = $sid;
      last;
    }
    die("no slot found\n") unless defined $slot_id;
  }
  my $session = $pkcs11->OpenSession($slot_id, Crypt::PKCS11::CKF_SERIAL_SESSION | ($rw ? Crypt::PKCS11::CKF_RW_SESSION : 0)) or die "OpenSession: " . $pkcs11->errstr;
  if (defined $config->{'login'}) {
    $session->Login(Crypt::PKCS11::CKU_USER, $config->{'login'}) or die "login error: " . $session->errstr;
  }
  return $session;
}

sub pkcs11_get_session_slot {
  my ($session) = @_;
  my $session_info = $session->GetSessionInfo() or die die("pkcs11_get_session_slot: could not get session info\n");
  return $session_info->{'slotID'};
}

sub pkcs11_mechanism {
  my ($mechanism) = @_;
  my $mech_obj = Crypt::PKCS11::CK_MECHANISM->new;
  $mech_obj->set_mechanism($mechanism) if defined $mechanism;
  return $mech_obj;
}

sub pkcs11_generate_wrapping_key {
  my ($session) = @_;
  my $wrapping_key_template = Crypt::PKCS11::Attributes->new->push(
    Crypt::PKCS11::Attribute::Class->new->set(Crypt::PKCS11::CKO_SECRET_KEY),
    Crypt::PKCS11::Attribute::KeyType->new->set(Crypt::PKCS11::CKK_AES),
    Crypt::PKCS11::Attribute::Token->new->set(0),
    Crypt::PKCS11::Attribute::Sensitive->new->set(1),
    Crypt::PKCS11::Attribute::ValueLen->new->set(32),
    Crypt::PKCS11::Attribute::Private->new->set(1),
    Crypt::PKCS11::Attribute::Encrypt->new->set(1),
    Crypt::PKCS11::Attribute::Decrypt->new->set(1),
    Crypt::PKCS11::Attribute::Sign->new->set(1),
    Crypt::PKCS11::Attribute::Verify->new->set(1),
    Crypt::PKCS11::Attribute::Wrap->new->set(1),
    Crypt::PKCS11::Attribute::Unwrap->new->set(1),
    Crypt::PKCS11::Attribute::Derive->new->set(1),
    Crypt::PKCS11::Attribute::Extractable->new->set(1),
  );
  my $wrapping_key = $session->GenerateKey(pkcs11_mechanism(Crypt::PKCS11::CKM_AES_KEY_GEN), $wrapping_key_template) or die "wrapping key creation failed: " . $session->errstr;
  return $wrapping_key;
}

sub pkcs11_import_key {
  my ($session, $keydata, $privkey_der, $label) = @_;

  my $keytype;
  if ($keydata->{'algo'} eq 'rsa') {
    $keytype = Crypt::PKCS11::CKK_RSA;
  } elsif ($keydata->{'algo'} eq 'ecdsa') {
    $keytype = Crypt::PKCS11::CKK_EC;
  } elsif ($keydata->{'algo'} eq 'eddsa') {
    $keytype = Crypt::PKCS11::CKK_EC_EDWARDS;
  }
  die("pkcs11_import_key: unsupported key algo $keydata->{'algo'}\n") unless defined $keytype;

  my $wrapping_key = pkcs11_generate_wrapping_key($session);

  my $iv = $session->GenerateRandom(16) or die "random generation failed: " . $session->errstr;
  my $mechanism_aes_cbc_pad = pkcs11_mechanism(Crypt::PKCS11::CKM_AES_CBC_PAD);
  $mechanism_aes_cbc_pad->set_pParameter($iv);

  $session->EncryptInit($mechanism_aes_cbc_pad, $wrapping_key) or die "EncryptInit failed: " . $session->errstr;
  my $wrapped_key = $session->Encrypt($privkey_der);

  my $unwrap_key_template = Crypt::PKCS11::Attributes->new->push(
    Crypt::PKCS11::Attribute::Class->new->set(Crypt::PKCS11::CKO_PRIVATE_KEY),
    Crypt::PKCS11::Attribute::KeyType->new->set($keytype),
    Crypt::PKCS11::Attribute::Label->new->set($label),
    Crypt::PKCS11::Attribute::Token->new->set(1),
    Crypt::PKCS11::Attribute::Sensitive->new->set(1),
    Crypt::PKCS11::Attribute::Extractable->new->set(0),
    Crypt::PKCS11::Attribute::Sign->new->set(1),
    Crypt::PKCS11::Attribute::Unwrap->new->set(1),
  );
  my $unwrapped_key = $session->UnwrapKey($mechanism_aes_cbc_pad, $wrapping_key , $wrapped_key, $unwrap_key_template) or die "key unwrapping failed: " . $session->errstr;

  my $sensitive_template = Crypt::PKCS11::Attributes->new->push(
    Crypt::PKCS11::Attribute::Sensitive->new->set(1),
  );
  $session->SetAttributeValue($unwrapped_key, $sensitive_template) or die "Set Sensitive failed: ".$session->errstr;

  return $unwrapped_key;
}

my %pkcs11_pkcs1prefix = ( 
  'sha1'   => '3021300906052b0e03021a05000414',
  'sha224' => '3031300d06096086480165030402040500041c',
  'sha256' => '3031300d060960864801650304020105000420',
  'sha384' => '3041300d060960864801650304020205000430',
  'sha512' => '3051300d060960864801650304020305000440',
);

sub pkcs11_find_signing_key {
  my ($session, $label) = @_;
  my $object_template = Crypt::PKCS11::Attributes->new->push(
    Crypt::PKCS11::Attribute::Label->new->set($label),
    Crypt::PKCS11::Attribute::Sign->new->set(1),
  );
  $session->FindObjectsInit($object_template);
  my $objects = $session->FindObjects(1);
  return $objects && @$objects ? $objects->[0] : undef;
}

sub pkcs11_sign {
  my ($session, $key, $hashalgo, $data) = @_;
  my ($keytype) = $session->GetAttributeValue($key, Crypt::PKCS11::Attributes->new->push(Crypt::PKCS11::Attribute::KeyType->new->set(0)));
  die("could not determine key type\n") unless defined $keytype;
  $keytype = $keytype->get();
  my $mech;
  if ($keytype == Crypt::PKCS11::CKK_RSA) {
    $mech = Crypt::PKCS11::CKM_RSA_PKCS;
    die("unsupported hash algorithm for rsa\n") unless $pkcs11_pkcs1prefix{$hashalgo};
    $data = pack('H*', $pkcs11_pkcs1prefix{$hashalgo}).$data;
  } elsif ($keytype == Crypt::PKCS11::CKK_EC) {
    $mech = Crypt::PKCS11::CKM_ECDSA;
  } elsif ($keytype == Crypt::PKCS11::CKK_EC_EDWARDS) {
    $mech = Crypt::PKCS11::CKM_EDDSA;
  }
  die("unsupported key type $keytype\n") unless defined $mech;
  $session->SignInit(pkcs11_mechanism($mech), $key) or die "Failed to set init signing: " . $session->errstr;
  my $sig = $session->Sign($data) or die "Failed to sign: " . $session->errstr;
  return $sig;
}


##########  SEXP helpers

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

sub unparse_sexp {
  my ($l) = @_;
  my $sexp = '';
  for (@$l) {
    if (ref($_) eq 'ARRAY') {
      $sexp .= unparse_sexp($_);
    } else {
      $sexp .= length($_).":$_";
    }
  }
  return "($sexp)";
}

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 in sexp\n") unless defined $d;
  return $d;
}

##########  gpg private key parsing

sub gpg_sexp2keydata {
  my ($key) = @_;

  my $info;
  my $type = $key->[0] || '?';
  if ($type eq 'rsa') {
    $info = {'algo' => 'rsa', 'mpis' => ['n', 'e'], 'smpis' => ['d', 'p', 'q', 'u']};
  } elsif ($type eq 'dsa') {
    $info = {'algo' => 'dsa', 'mpis' => ['p', 'q', 'g', 'y'], 'smpis' => ['x']};
  } elsif ($type eq 'ecc') {
    $info = {'algo' => 'ecdsa', 'mpis' => ['q'], 'smpis' => ['d']};
    my $curve = find_in_sexp($key->[1], 'curve') || '?';
    $info->{'curve'} = 'ed25519' if $curve eq 'Ed25519';
    $info->{'curve'} = 'nistp256' if $curve eq 'NIST P-256';
    $info->{'curve'} = 'nistp384' if $curve eq 'NIST P-384';
    die("unsupported ecc curve '$curve'\n") unless $info->{'curve'};
    $info->{'algo'} = 'eddsa' if $info->{'curve'} eq 'ed25519';
  }
  die("unsupported private key type $type\n") unless $info;
  for (@{$info->{'mpis'}}, @{$info->{'smpis'} || []}) {
    $_ = find_in_sexp($key, $_);
    die("missing mpi in privkey\n") unless $_;
  }
  return $info;
}

######## X509 private key encoding

sub pack_raw {
  my ($tag, $data) = @_;
  my $l = length($data);
  return pack("CC", $tag, $l) . $data if $l < 128;
  my $ll = $l >> 8 ? $l >> 16 ? $l >> 24 ? 4 : 3 : 2 : 1;
  return pack("CCa*", $tag, $ll | 0x80,  substr(pack("N", $l), -$ll)) . $data;
}

sub pack_integer {
  return pack_raw(0x02, pack('c', $_[0])) if $_[0] >= -128 && $_[0] <= 127;
  return pack_raw(0x02, substr(pack('N', $_[0]), 3 - (length(sprintf('%b', $_[0] >= 0 ? $_[0] : ~$_[0])) >> 3)));
}

sub pack_mpi {
  my $mpi = $_[0];
  $mpi = pack('C', 0) if length($mpi) == 0;
  $mpi = substr($mpi, 1) while length($mpi) > 1 && unpack('C', $mpi) == 0;
  return pack_raw(0x02, unpack('C', $mpi) >= 128 ? pack('C', 0).$mpi : $mpi);
}

sub pack_sequence {
  return pack_raw(0x30, join('', @_));
}

sub pack_bytes {
  return pack_raw(0x03, pack('C', 0).$_[0]);
}

sub pack_octet_string {
  return pack_raw(0x04, $_[0]);
}

sub x509_keydata2privkey {
  my ($keydata) = @_;
  my $algo = $keydata->{'algo'} || '?';
  my $param;
  my $x509algo;
  if ($algo eq 'rsa') {
    my @s = (@{$keydata->{'mpis'}}, @{$keydata->{'smpis'}});
    die unless @s == 6;
    my $d = Math::BigInt->from_bytes($s[2]);
    push @s, $d->copy()->bmod(Math::BigInt->from_bytes($s[3])->bdec())->as_bytes();
    push @s, $d->copy()->bmod(Math::BigInt->from_bytes($s[4])->bdec())->as_bytes();
    $x509algo = pack('H*', '300d06092a864886f70d0101010500');
    $param = pack_sequence(pack_integer(0), pack_mpi($s[0]), pack_mpi($s[1]), pack_mpi($s[2]), pack_mpi($s[4]), pack_mpi($s[3]), pack_mpi($s[7]), pack_mpi($s[6]), pack_mpi($s[5]));
  } elsif ($algo eq 'ecdsa' && $keydata->{'curve'} eq 'nistp256') {
    die unless @{$keydata->{'mpis'}} == 1 && @{$keydata->{'smpis'}} == 1;
    $x509algo = pack('H*', '301306072a8648ce3d020106082a8648ce3d030107');
    $param = pack_sequence(pack_integer(1), pack_octet_string($keydata->{'smpis'}->[0]), pack_raw(0xa1, pack_bytes($keydata->{'mpis'}->[0])));
  } elsif ($algo eq 'ecdsa' && $keydata->{'curve'} eq 'nistp384') {
    die unless @{$keydata->{'mpis'}} == 1 && @{$keydata->{'smpis'}} == 1;
    $x509algo = pack('H*', '301006072a8648ce3d020106052b81040022');
    $param = pack_sequence(pack_integer(1), pack_octet_string($keydata->{'smpis'}->[0]), pack_raw(0xa1, pack_bytes($keydata->{'mpis'}->[0])));
  } elsif ($algo eq 'eddsa' && $keydata->{'curve'} eq 'ed25519') {
    die unless @{$keydata->{'mpis'}} == 1 && @{$keydata->{'smpis'}} == 1;
    $x509algo = pack('H*', '300506032b6570');
    $param = pack_octet_string(substr(("\0" x 32).$keydata->{'smpis'}->[0], -32));
  }
  die("x509_keydata2privkey: unsupported key algorithm $algo\n") unless defined $param;
  return pack_sequence(pack_integer(0), $x509algo, pack_octet_string($param));
}


######## Assuan protocol

my $assuan_default_source = 0;

sub assuan_readline {
  my $line = <STDIN>;
  return undef if !defined($line) || $line eq '' || substr($line, -1, 1) ne "\n";
  chomp($line);
  return $line;
}

sub assuan_writeline {
  print "$_[0]\n";
}

sub assuan_inquire {
  my ($what) = @_;
  assuan_writeline("INQUIRE $what");
  my $data = '';
  while (1) {
    my $line = assuan_readline();
    die("ERR 16383 End of file\n") unless defined $line;
    next if $line eq '' || $line =~ /^#/;
    die("ERR 276 IPC syntax error - leading white-space\n") if $line =~ /^\s+/;
    if (substr($line, 0, 2) eq 'D ') {
      $line =~ s/%(25|0a|0A|0d|0D|5c|5C)/chr(hex($1))/sge;
      $data .= substr($line, 2);
      next;
    }
    my @cmd = split(' ', $line);
    return $data if $cmd[0] eq 'END';
    die("ERR 277 IPC call has been cancelled\n") if $cmd[0] eq 'CAN';
    die("ERR 274 Unexpected IPC command\n");
  }
}

sub assuan_senddata {
  my ($data) = @_;
  $data =~ s/([\r\n%])/sprintf("%%%02X",ord($1))/sge;
  while (length($data) > 1000 - 2) {
    my $chunk = substr($data, 0, 1000 - 2);
    $chunk =~ s/%.?$//s;
    assuan_writeline("D $chunk");
    $data = substr($data, length($chunk));
  }
  assuan_writeline("D $data");
}

sub assuan_error {
  my ($err) = @_;
  $err = '' unless defined $err;
  $err = "ERR 1 $err" unless $err =~ /^ERR \d/;
  $err =~ s/^ERR (\d+) /ERR $assuan_default_source.$1 /;
  $err =~ s/^ERR (\d+)\.(\d+)/'ERR '.(($1 << 24) + $2)/e;
  $err =~ s/\n.*$//s;
  $err =~ s/\s+$//;
  assuan_writeline($err);
}

sub assuan_ok {
  my ($ok) = @_;
  $ok = '' unless defined $ok;
  $ok = "OK $ok" unless $ok =~ /^OK/;
  $ok =~ s/\s+$//;
  assuan_writeline($ok);
}

####### Commands

sub pksign {
  my (@args) = @_;
  die("ERR 280 IPC parameter error - additional parameters given\n") if @args;
  my $keydata_sexp = assuan_inquire('KEYDATA');
  my ($keydata) = eval { parse_sexp($keydata_sexp) };
  die("ERR 83 $@") if $@;
  die("ERR 83 bad keydata\n") unless @$keydata == 3 && $keydata->[0] eq 'pkcs11';
  my $label = $keydata->[2];
  my $extra = assuan_inquire('EXTRA');
  my $hashalgo;
  if (length($extra) == 20) {
    $hashalgo = 'sha1';
  } elsif (length($extra) == 32) {
    $hashalgo = 'sha256';
  } elsif (length($extra) == 48) {
    $hashalgo = 'sha384';
  } elsif (length($extra) == 64) {
    $hashalgo = 'sha512';
  }
  die("ERR 84 could not determine hash algorithm\n") unless $hashalgo;
  my $session = pkcs11_open_session(0);
  my $key = pkcs11_find_signing_key($session, $label);
  die("could not find private key '$label'\n") unless $key;
  my $sig = pkcs11_sign($session, $key, $hashalgo, $extra);
  assuan_senddata($sig);
  assuan_ok();
}

sub import {
  my (@args) = @_;
  die("ERR 280 IPC parameter error - additional parameters given\n") if @args;
  my $sexp = assuan_inquire('KEYDATA');
  chop($sexp) if substr($sexp, -1, 1) eq "\0";	# XXX hmmm
  my ($key) = eval { parse_sexp($sexp) };
  die("ERR 83 $@") if $@;
  die("ERR 54 not a unprotected private key\n") unless @$key > 1 && $key->[0] eq 'private-key' && ref($key->[1]) eq 'ARRAY';
  my $keydata = gpg_sexp2keydata($key->[1]);
  my $privkey_der = x509_keydata2privkey($keydata);
  my $session = pkcs11_open_session(1);
  my $token = pkcs11_generate_token_url(pkcs11_get_session_slot($session));
  die("ERR 83 could not create token url\n") unless $token;
  my $label = 'gnupg-'. Digest::SHA::sha256_hex($sexp);
  my $newkey = pkcs11_import_key($session, $keydata, $privkey_der, $label);
  my $shadow_info = unparse_sexp([ 'pkcs11', $token, $label ]);
  assuan_senddata($shadow_info);
  assuan_ok();
}

####### Main

my $pipe_server;
my $multi_server;

while (@ARGV) {
  if ($ARGV[0] eq '--server') {
    $pipe_server = 1;
    shift @ARGV;
  } elsif ($ARGV[0] eq '--multi-server') {
    $pipe_server = $multi_server = 1;
    shift @ARGV;
  } elsif ($ARGV[0] eq '--homedir') {
    (undef, $homedir) = splice(@ARGV, 0, 2);
  } elsif ($ARGV[0] eq '--') {
    shift @ARGV;
    last;
  } elsif ($ARGV[0] =~ /^-/) {
    die("Unknown option $ARGV[0]\n");
  } else {
    last;
  }
}
die("Usage: gpg_pkcs11_tpm --server|--multi-server\n") if @ARGV;
die("Only server mode supported\n") unless $pipe_server;

$homedir = $ENV{'GNUPGHOME'} unless defined $homedir;
$homedir = "$ENV{'HOME'}/.gnupg" unless defined $homedir;

read_config();
pkcs11_init();

$| = 1;
$assuan_default_source = 16;
assuan_ok('gpg_pkcs11_tpm server ready');

while (1) {
  my $line = assuan_readline();
  last unless defined $line;
  next if $line eq '' || $line =~ /^#/;
  if ($line =~ /^\s+/) {
    assuan_error("ERR 276 IPC syntax error - leading white-space\n");
    next;
  }
  my @cmd = split(' ', $line);
  my $cmd = shift @cmd;
  #s/%(25|0a|0A|0d|0D|5c|5C)/chr(hex($1))/sge for @cmd;
  if ($cmd eq 'NOP' || $cmd eq 'RESET') {
    assuan_ok();
  } elsif ($cmd eq 'HELP') {
    assuan_writeline("# $_") for qw{NOP CANCEL OPTION BYE AUTH RESET END HELP IMPORT PKSIGN PKDECRYPT KILLTPM2D};
    assuan_ok();
  } elsif ($cmd eq 'PKSIGN') {
    eval { pksign(@cmd) };
    assuan_error($@) if $@;
  } elsif ($cmd eq 'IMPORT') {
    eval { import(@cmd) };
    assuan_error($@) if $@;
  } elsif ($cmd eq 'PKDECRYPT') {
    assuan_error("ERR 69 Not implemented\n");
  } elsif ($cmd eq 'BYE' || $cmd eq 'KILLTPM2D') {
    assuan_ok('closing connection');
    last;
  } elsif ($cmd eq 'CANCEL' || $cmd eq 'D' || $cmd eq 'OPTION' || $cmd eq 'AUTH' || $cmd eq 'END') {
    assuan_error("ERR 69 Not implemented\n");
  } else {
    assuan_error("ERR 275 Unknown IPC command\n");
  }
}
exit(0);
