summaryrefslogtreecommitdiff
path: root/src/share/keytrans
blob: c09f664f6d9b926ad25f6ff037d87320b620b3ef (plain)
  1. #!/usr/bin/perl -T
  2. # keytrans: this is an RSA key translation utility; it is capable of
  3. # transforming RSA keys (both public keys and secret keys) between
  4. # several popular representations, including OpenPGP, PEM-encoded
  5. # PKCS#1 DER, and OpenSSH-style public key lines.
  6. # How it behaves depends on the name under which it is invoked. The
  7. # two implementations currently are: pem2openpgp and openpgp2ssh.
  8. # pem2openpgp: take a PEM-encoded RSA private-key on standard input, a
  9. # User ID as the first argument, and generate an OpenPGP secret key
  10. # and certificate from it.
  11. # WARNING: the secret key material *will* appear on stdout (albeit in
  12. # OpenPGP form) -- if you redirect stdout to a file, make sure the
  13. # permissions on that file are appropriately locked down!
  14. # Usage:
  15. # pem2openpgp 'ssh://'$(hostname -f) < /etc/ssh/ssh_host_rsa_key | gpg --import
  16. # openpgp2ssh: take a stream of OpenPGP packets containing public or
  17. # secret key material on standard input, and a Key ID (or fingerprint)
  18. # as the first argument. Find the matching key in the input stream,
  19. # and emit it on stdout in an OpenSSH-compatible format. If the input
  20. # key is an OpenPGP public key (either primary or subkey), the output
  21. # will be an OpenSSH single-line public key. If the input key is an
  22. # OpenPGP secret key, the output will be a PEM-encoded RSA key.
  23. # Example usage:
  24. # gpg --export-secret-subkeys --export-options export-reset-subkey-passwd $KEYID | \
  25. # openpgp2ssh $KEYID | ssh-add /dev/stdin
  26. # Authors:
  27. # Jameson Rollins <jrollins@finestructure.net>
  28. # Daniel Kahn Gillmor <dkg@fifthhorseman.net>
  29. # Started on: 2009-01-07 02:01:19-0500
  30. # License: GPL v3 or later (we may need to adjust this given that this
  31. # connects to OpenSSL via perl)
  32. use strict;
  33. use warnings;
  34. use File::Basename;
  35. use Crypt::OpenSSL::RSA;
  36. use Crypt::OpenSSL::Bignum;
  37. use Crypt::OpenSSL::Bignum::CTX;
  38. use Digest::SHA;
  39. use MIME::Base64;
  40. use POSIX;
  41. ## make sure all length() and substr() calls use bytes only:
  42. use bytes;
  43. my $old_format_packet_lengths = { one => 0,
  44. two => 1,
  45. four => 2,
  46. indeterminate => 3,
  47. };
  48. # see RFC 4880 section 9.1 (ignoring deprecated algorithms for now)
  49. my $asym_algos = { rsa => 1,
  50. elgamal => 16,
  51. dsa => 17,
  52. };
  53. # see RFC 4880 section 9.2
  54. my $ciphers = { plaintext => 0,
  55. idea => 1,
  56. tripledes => 2,
  57. cast5 => 3,
  58. blowfish => 4,
  59. aes128 => 7,
  60. aes192 => 8,
  61. aes256 => 9,
  62. twofish => 10,
  63. };
  64. # see RFC 4880 section 9.3
  65. my $zips = { uncompressed => 0,
  66. zip => 1,
  67. zlib => 2,
  68. bzip2 => 3,
  69. };
  70. # see RFC 4880 section 9.4
  71. my $digests = { md5 => 1,
  72. sha1 => 2,
  73. ripemd160 => 3,
  74. sha256 => 8,
  75. sha384 => 9,
  76. sha512 => 10,
  77. sha224 => 11,
  78. };
  79. # see RFC 4880 section 5.2.3.21
  80. my $usage_flags = { certify => 0x01,
  81. sign => 0x02,
  82. encrypt_comms => 0x04,
  83. encrypt_storage => 0x08,
  84. encrypt => 0x0c, ## both comms and storage
  85. split => 0x10, # the private key is split via secret sharing
  86. authenticate => 0x20,
  87. shared => 0x80, # more than one person holds the entire private key
  88. };
  89. # see RFC 4880 section 4.3
  90. my $packet_types = { pubkey_enc_session => 1,
  91. sig => 2,
  92. symkey_enc_session => 3,
  93. onepass_sig => 4,
  94. seckey => 5,
  95. pubkey => 6,
  96. sec_subkey => 7,
  97. compressed_data => 8,
  98. symenc_data => 9,
  99. marker => 10,
  100. literal => 11,
  101. trust => 12,
  102. uid => 13,
  103. pub_subkey => 14,
  104. uat => 17,
  105. symenc_w_integrity => 18,
  106. mdc => 19,
  107. };
  108. # see RFC 4880 section 5.2.1
  109. my $sig_types = { binary_doc => 0x00,
  110. text_doc => 0x01,
  111. standalone => 0x02,
  112. generic_certification => 0x10,
  113. persona_certification => 0x11,
  114. casual_certification => 0x12,
  115. positive_certification => 0x13,
  116. subkey_binding => 0x18,
  117. primary_key_binding => 0x19,
  118. key_signature => 0x1f,
  119. key_revocation => 0x20,
  120. subkey_revocation => 0x28,
  121. certification_revocation => 0x30,
  122. timestamp => 0x40,
  123. thirdparty => 0x50,
  124. };
  125. # see RFC 4880 section 5.2.3.23
  126. my $revocation_reasons = { no_reason_specified => 0,
  127. key_superseded => 1,
  128. key_compromised => 2,
  129. key_retired => 3,
  130. user_id_no_longer_valid => 32,
  131. };
  132. # see RFC 4880 section 5.2.3.1
  133. my $subpacket_types = { sig_creation_time => 2,
  134. sig_expiration_time => 3,
  135. exportable => 4,
  136. trust_sig => 5,
  137. regex => 6,
  138. revocable => 7,
  139. key_expiration_time => 9,
  140. preferred_cipher => 11,
  141. revocation_key => 12,
  142. issuer => 16,
  143. notation => 20,
  144. preferred_digest => 21,
  145. preferred_compression => 22,
  146. keyserver_prefs => 23,
  147. preferred_keyserver => 24,
  148. primary_uid => 25,
  149. policy_uri => 26,
  150. usage_flags => 27,
  151. signers_uid => 28,
  152. revocation_reason => 29,
  153. features => 30,
  154. signature_target => 31,
  155. embedded_signature => 32,
  156. };
  157. # bitstring (see RFC 4880 section 5.2.3.24)
  158. my $features = { mdc => 0x01
  159. };
  160. # bitstring (see RFC 4880 5.2.3.17)
  161. my $keyserver_prefs = { nomodify => 0x80
  162. };
  163. ###### end lookup tables ######
  164. # FIXME: if we want to be able to interpret openpgp data as well as
  165. # produce it, we need to produce key/value-swapped lookup tables as well.
  166. ########### Math/Utility Functions ##############
  167. # see the bottom of page 44 of RFC 4880 (http://tools.ietf.org/html/rfc4880#page-44)
  168. sub simple_checksum {
  169. my $bytes = shift;
  170. return unpack("%16C*",$bytes);
  171. }
  172. # calculate/print the fingerprint of an openssh-style keyblob:
  173. sub sshfpr {
  174. my $keyblob = shift;
  175. use Digest::MD5;
  176. return join(':', map({unpack("H*", $_)} split(//, Digest::MD5::md5($keyblob))));
  177. }
  178. # calculate the multiplicative inverse of a mod b this is euclid's
  179. # extended algorithm. For more information see:
  180. # http://en.wikipedia.org/wiki/Extended_Euclidean_algorithm the
  181. # arguments here should be Crypt::OpenSSL::Bignum objects. $a should
  182. # be the larger of the two values, and the two values should be
  183. # coprime.
  184. sub modular_multi_inverse {
  185. my $a = shift;
  186. my $b = shift;
  187. my $origdivisor = $b->copy();
  188. my $ctx = Crypt::OpenSSL::Bignum::CTX->new();
  189. my $x = Crypt::OpenSSL::Bignum->zero();
  190. my $y = Crypt::OpenSSL::Bignum->one();
  191. my $lastx = Crypt::OpenSSL::Bignum->one();
  192. my $lasty = Crypt::OpenSSL::Bignum->zero();
  193. my $finalquotient;
  194. my $finalremainder;
  195. while (! $b->is_zero()) {
  196. my ($quotient, $remainder) = $a->div($b, $ctx);
  197. $a = $b;
  198. $b = $remainder;
  199. my $temp = $x;
  200. $x = $lastx->sub($quotient->mul($x, $ctx));
  201. $lastx = $temp;
  202. $temp = $y;
  203. $y = $lasty->sub($quotient->mul($y, $ctx));
  204. $lasty = $temp;
  205. }
  206. if (!$a->is_one()) {
  207. die "did this math wrong.\n";
  208. }
  209. # let's make sure that we return a positive value because RFC 4880,
  210. # section 3.2 only allows unsigned values:
  211. ($finalquotient, $finalremainder) = $lastx->add($origdivisor)->div($origdivisor, $ctx);
  212. return $finalremainder;
  213. }
  214. ############ OpenPGP formatting functions ############
  215. # make an old-style packet out of the given packet type and body.
  216. # old-style (see RFC 4880 section 4.2)
  217. sub make_packet {
  218. my $type = shift;
  219. my $body = shift;
  220. my $options = shift;
  221. my $len = length($body);
  222. my $pseudolen = $len;
  223. # if the caller wants to use at least N octets of packet length,
  224. # pretend that we're using that many.
  225. if (defined $options && defined $options->{'packet_length'}) {
  226. $pseudolen = 2**($options->{'packet_length'} * 8) - 1;
  227. }
  228. if ($pseudolen < $len) {
  229. $pseudolen = $len;
  230. }
  231. my $lenbytes;
  232. my $lencode;
  233. if ($pseudolen < 2**8) {
  234. $lenbytes = $old_format_packet_lengths->{one};
  235. $lencode = 'C';
  236. } elsif ($pseudolen < 2**16) {
  237. $lenbytes = $old_format_packet_lengths->{two};
  238. $lencode = 'n';
  239. } elsif ($pseudolen < 2**31) {
  240. ## not testing against full 32 bits because i don't want to deal
  241. ## with potential overflow.
  242. $lenbytes = $old_format_packet_lengths->{four};
  243. $lencode = 'N';
  244. } else {
  245. ## what the hell do we do here?
  246. $lenbytes = $old_format_packet_lengths->{indeterminate};
  247. $lencode = '';
  248. }
  249. return pack('C'.$lencode, 0x80 + ($type * 4) + $lenbytes, $len).
  250. $body;
  251. }
  252. # takes a Crypt::OpenSSL::Bignum, returns it formatted as OpenPGP MPI
  253. # (RFC 4880 section 3.2)
  254. sub mpi_pack {
  255. my $num = shift;
  256. my $val = $num->to_bin();
  257. my $mpilen = length($val)*8;
  258. # this is a kludgy way to get the number of significant bits in the
  259. # first byte:
  260. my $bitsinfirstbyte = length(sprintf("%b", ord($val)));
  261. $mpilen -= (8 - $bitsinfirstbyte);
  262. return pack('n', $mpilen).$val;
  263. }
  264. # takes a Crypt::OpenSSL::Bignum, returns an MPI packed in preparation
  265. # for an OpenSSH-style public key format. see:
  266. # http://marc.info/?l=openssh-unix-dev&m=121866301718839&w=2
  267. sub openssh_mpi_pack {
  268. my $num = shift;
  269. my $val = $num->to_bin();
  270. my $mpilen = length($val);
  271. my $ret = pack('N', $mpilen);
  272. # if the first bit of the leading byte is high, we should include a
  273. # 0 byte:
  274. if (ord($val) & 0x80) {
  275. $ret = pack('NC', $mpilen+1, 0);
  276. }
  277. return $ret.$val;
  278. }
  279. sub openssh_pubkey_pack {
  280. my $key = shift;
  281. my ($modulus, $exponent) = $key->get_key_parameters();
  282. return openssh_mpi_pack(Crypt::OpenSSL::Bignum->new_from_bin("ssh-rsa")).
  283. openssh_mpi_pack($exponent).
  284. openssh_mpi_pack($modulus);
  285. }
  286. # pull an OpenPGP-specified MPI off of a given stream, returning it as
  287. # a Crypt::OpenSSL::Bignum.
  288. sub read_mpi {
  289. my $instr = shift;
  290. my $readtally = shift;
  291. my $bitlen;
  292. read($instr, $bitlen, 2) or die "could not read MPI length.\n";
  293. $bitlen = unpack('n', $bitlen);
  294. $$readtally += 2;
  295. my $bytestoread = POSIX::floor(($bitlen + 7)/8);
  296. my $ret;
  297. read($instr, $ret, $bytestoread) or die "could not read MPI body.\n";
  298. $$readtally += $bytestoread;
  299. return Crypt::OpenSSL::Bignum->new_from_bin($ret);
  300. }
  301. # FIXME: genericize these to accept either RSA or DSA keys:
  302. sub make_rsa_pub_key_body {
  303. my $key = shift;
  304. my $key_timestamp = shift;
  305. my ($n, $e) = $key->get_key_parameters();
  306. return
  307. pack('CN', 4, $key_timestamp).
  308. pack('C', $asym_algos->{rsa}).
  309. mpi_pack($n).
  310. mpi_pack($e);
  311. }
  312. sub make_rsa_sec_key_body {
  313. my $key = shift;
  314. my $key_timestamp = shift;
  315. # we're not using $a and $b, but we need them to get to $c.
  316. my ($n, $e, $d, $p, $q) = $key->get_key_parameters();
  317. my $c3 = modular_multi_inverse($p, $q);
  318. my $secret_material = mpi_pack($d).
  319. mpi_pack($p).
  320. mpi_pack($q).
  321. mpi_pack($c3);
  322. # according to Crypt::OpenSSL::RSA, the closest value we can get out
  323. # of get_key_parameters is 1/q mod p; but according to sec 5.5.3 of
  324. # RFC 4880, we're actually looking for u, the multiplicative inverse
  325. # of p, mod q. This is why we're calculating the value directly
  326. # with modular_multi_inverse.
  327. return
  328. pack('CN', 4, $key_timestamp).
  329. pack('C', $asym_algos->{rsa}).
  330. mpi_pack($n).
  331. mpi_pack($e).
  332. pack('C', 0). # seckey material is not encrypted -- see RFC 4880 sec 5.5.3
  333. $secret_material.
  334. pack('n', simple_checksum($secret_material));
  335. }
  336. # expects an RSA key (public or private) and a timestamp
  337. sub fingerprint {
  338. my $key = shift;
  339. my $key_timestamp = shift;
  340. my $rsabody = make_rsa_pub_key_body($key, $key_timestamp);
  341. return Digest::SHA::sha1(pack('Cn', 0x99, length($rsabody)).$rsabody);
  342. }
  343. # FIXME: handle DSA keys as well!
  344. sub makeselfsig {
  345. my $rsa = shift;
  346. my $uid = shift;
  347. my $args = shift;
  348. # strong assertion of identity is the default (for a self-sig):
  349. if (! defined $args->{certification_type}) {
  350. $args->{certification_type} = $sig_types->{positive_certification};
  351. }
  352. if (! defined $args->{sig_timestamp}) {
  353. $args->{sig_timestamp} = time();
  354. }
  355. my $key_timestamp = $args->{key_timestamp} + 0;
  356. # generate and aggregate subpackets:
  357. # key usage flags:
  358. my $flags = 0;
  359. if (! defined $args->{usage_flags}) {
  360. $flags = $usage_flags->{certify};
  361. } else {
  362. my @ff = split(",", $args->{usage_flags});
  363. foreach my $f (@ff) {
  364. if (! defined $usage_flags->{$f}) {
  365. die "No such flag $f";
  366. }
  367. $flags |= $usage_flags->{$f};
  368. }
  369. }
  370. my $usage_subpacket = pack('CCC', 2, $subpacket_types->{usage_flags}, $flags);
  371. # how should we determine how far off to set the expiration date?
  372. # default is no expiration. Specify the timestamp in seconds from the
  373. # key creation.
  374. my $expiration_subpacket = '';
  375. if (defined $args->{expiration}) {
  376. my $expires_in = $args->{expiration} + 0;
  377. $expiration_subpacket = pack('CCN', 5, $subpacket_types->{key_expiration_time}, $expires_in);
  378. }
  379. # prefer AES-256, AES-192, AES-128, CAST5, 3DES:
  380. my $pref_sym_algos = pack('CCCCCCC', 6, $subpacket_types->{preferred_cipher},
  381. $ciphers->{aes256},
  382. $ciphers->{aes192},
  383. $ciphers->{aes128},
  384. $ciphers->{cast5},
  385. $ciphers->{tripledes}
  386. );
  387. # prefer SHA-512, SHA-384, SHA-256, SHA-224, RIPE-MD/160, SHA-1
  388. my $pref_hash_algos = pack('CCCCCCCC', 7, $subpacket_types->{preferred_digest},
  389. $digests->{sha512},
  390. $digests->{sha384},
  391. $digests->{sha256},
  392. $digests->{sha224},
  393. $digests->{ripemd160},
  394. $digests->{sha1}
  395. );
  396. # prefer ZLIB, BZip2, ZIP
  397. my $pref_zip_algos = pack('CCCCC', 4, $subpacket_types->{preferred_compression},
  398. $zips->{zlib},
  399. $zips->{bzip2},
  400. $zips->{zip}
  401. );
  402. # we support the MDC feature:
  403. my $feature_subpacket = pack('CCC', 2, $subpacket_types->{features},
  404. $features->{mdc});
  405. # keyserver preference: only owner modify (???):
  406. my $keyserver_pref = pack('CCC', 2, $subpacket_types->{keyserver_prefs},
  407. $keyserver_prefs->{nomodify});
  408. $args->{hashed_subpackets} =
  409. $usage_subpacket.
  410. $expiration_subpacket.
  411. $pref_sym_algos.
  412. $pref_hash_algos.
  413. $pref_zip_algos.
  414. $feature_subpacket.
  415. $keyserver_pref;
  416. return gensig($rsa, $uid, $args);
  417. }
  418. # FIXME: handle non-RSA keys
  419. # FIXME: this currently only makes self-sigs -- we should parameterize
  420. # it to make certifications over keys other than the issuer.
  421. sub gensig {
  422. my $rsa = shift;
  423. my $uid = shift;
  424. my $args = shift;
  425. # FIXME: allow signature creation using digests other than SHA256
  426. $rsa->use_sha256_hash();
  427. # see page 22 of RFC 4880 for why i think this is the right padding
  428. # choice to use:
  429. $rsa->use_pkcs1_padding();
  430. if (! $rsa->check_key()) {
  431. die "key does not check\n";
  432. }
  433. my $certtype = $args->{certification_type} + 0;
  434. my $version = pack('C', 4);
  435. my $sigtype = pack('C', $certtype);
  436. # RSA
  437. my $pubkey_algo = pack('C', $asym_algos->{rsa});
  438. # SHA256 FIXME: allow signature creation using digests other than SHA256
  439. my $hash_algo = pack('C', $digests->{sha256});
  440. # FIXME: i'm worried about generating a bazillion new OpenPGP
  441. # certificates from the same key, which could easily happen if you run
  442. # this script more than once against the same key (because the
  443. # timestamps will differ). How can we prevent this?
  444. # this argument (if set) overrides the current time, to
  445. # be able to create a standard key. If we read the key from a file
  446. # instead of stdin, should we use the creation time on the file?
  447. my $sig_timestamp = ($args->{sig_timestamp} + 0);
  448. my $key_timestamp = ($args->{key_timestamp} + 0);
  449. if ($key_timestamp > $sig_timestamp) {
  450. die "key timestamp must not be later than signature timestamp\n";
  451. }
  452. my $creation_time_packet = pack('CCN', 5, $subpacket_types->{sig_creation_time}, $sig_timestamp);
  453. my $hashed_subs = $creation_time_packet.$args->{hashed_subpackets};
  454. my $subpacket_octets = pack('n', length($hashed_subs));
  455. my $sig_data_to_be_hashed =
  456. $version.
  457. $sigtype.
  458. $pubkey_algo.
  459. $hash_algo.
  460. $subpacket_octets.
  461. $hashed_subs;
  462. my $pubkey = make_rsa_pub_key_body($rsa, $key_timestamp);
  463. # this is for signing. it needs to be an old-style header with a
  464. # 2-packet octet count.
  465. my $key_data = make_packet($packet_types->{pubkey}, $pubkey, {'packet_length'=>2});
  466. # take the last 8 bytes of the fingerprint as the keyid:
  467. my $keyid = substr(fingerprint($rsa, $key_timestamp), 20 - 8, 8);
  468. # the v4 signature trailer is:
  469. # version number, literal 0xff, and then a 4-byte count of the
  470. # signature data itself.
  471. my $trailer = pack('CCN', 4, 0xff, length($sig_data_to_be_hashed));
  472. my $uid_data =
  473. pack('CN', 0xb4, length($uid)).
  474. $uid;
  475. my $datatosign =
  476. $key_data.
  477. $uid_data.
  478. $sig_data_to_be_hashed.
  479. $trailer;
  480. # FIXME: handle signatures over digests other than SHA256:
  481. my $data_hash = Digest::SHA::sha256_hex($datatosign);
  482. my $issuer_packet = pack('CCa8', 9, $subpacket_types->{issuer}, $keyid);
  483. my $sig = Crypt::OpenSSL::Bignum->new_from_bin($rsa->sign($datatosign));
  484. my $sig_body =
  485. $sig_data_to_be_hashed.
  486. pack('n', length($issuer_packet)).
  487. $issuer_packet.
  488. pack('n', hex(substr($data_hash, 0, 4))).
  489. mpi_pack($sig);
  490. return make_packet($packet_types->{sig}, $sig_body);
  491. }
  492. # FIXME: switch to passing the whole packet as the arg, instead of the
  493. # input stream.
  494. # FIXME: think about native perl representation of the packets instead.
  495. # Put a user ID into the $data
  496. sub finduid {
  497. my $data = shift;
  498. my $instr = shift;
  499. my $tag = shift;
  500. my $packetlen = shift;
  501. my $dummy;
  502. ($tag == $packet_types->{uid}) or die "This should not be called on anything but a User ID packet\n";
  503. read($instr, $dummy, $packetlen);
  504. $data->{uid}->{$dummy} = {};
  505. $data->{current}->{uid} = $dummy;
  506. }
  507. # find signatures associated with the given fingerprint and user ID.
  508. sub findsig {
  509. my $data = shift;
  510. my $instr = shift;
  511. my $tag = shift;
  512. my $packetlen = shift;
  513. ($tag == $packet_types->{sig}) or die "No calling findsig on anything other than a signature packet.\n";
  514. my $dummy;
  515. my $readbytes = 0;
  516. read($instr, $dummy, $packetlen - $readbytes) or die "Could not read in this packet.\n";
  517. if ((! defined $data->{key}) ||
  518. (! defined $data->{uid}) ||
  519. (! defined $data->{uid}->{$data->{target}->{uid}})) {
  520. # the user ID we are looking for has not been found yet.
  521. return;
  522. }
  523. if ( (!defined($data->{current_key_match})) ||
  524. (! $data->{current_key_match})) {
  525. # this is not the key in question.
  526. return;
  527. }
  528. # the current ID is not what we're looking for:
  529. return if ($data->{current}->{uid} ne $data->{target}->{uid});
  530. # just storing the raw signatures for the moment:
  531. push @{$data->{sigs}}, make_packet($packet_types->{sig}, $dummy);
  532. return;
  533. }
  534. # given an input stream and data, store the found key in data and
  535. # consume the rest of the stream corresponding to the packet.
  536. # data contains: (fpr: fingerprint to find, key: current best guess at key)
  537. sub findkey {
  538. my $data = shift;
  539. my $instr = shift;
  540. my $tag = shift;
  541. my $packetlen = shift;
  542. my $dummy;
  543. my $ver;
  544. my $readbytes = 0;
  545. read($instr, $ver, 1) or die "could not read key version\n";
  546. $readbytes += 1;
  547. $ver = ord($ver);
  548. if ($ver != 4) {
  549. printf(STDERR "We only work with version 4 keys. This key appears to be version %s.\n", $ver);
  550. read($instr, $dummy, $packetlen - $readbytes) or die "Could not skip past this packet.\n";
  551. return;
  552. }
  553. my $key_timestamp;
  554. read($instr, $key_timestamp, 4) or die "could not read key timestamp.\n";
  555. $readbytes += 4;
  556. $key_timestamp = unpack('N', $key_timestamp);
  557. my $algo;
  558. read($instr, $algo, 1) or die "could not read key algorithm.\n";
  559. $readbytes += 1;
  560. $algo = ord($algo);
  561. if ($algo != $asym_algos->{rsa}) {
  562. printf(STDERR "We only support RSA keys (this key used algorithm %d).\n", $algo);
  563. read($instr, $dummy, $packetlen - $readbytes) or die "Could not skip past this packet.\n";
  564. return;
  565. }
  566. ## we have an RSA key.
  567. my $modulus = read_mpi($instr, \$readbytes);
  568. my $exponent = read_mpi($instr, \$readbytes);
  569. my $pubkey = Crypt::OpenSSL::RSA->new_key_from_parameters($modulus, $exponent);
  570. my $foundfpr = fingerprint($pubkey, $key_timestamp);
  571. my $foundfprstr = Crypt::OpenSSL::Bignum->new_from_bin($foundfpr)->to_hex();
  572. # left-pad with 0's to bring up to full 40-char (160-bit) fingerprint:
  573. $foundfprstr = sprintf("%040s", $foundfprstr);
  574. $data->{current_key_match} = 0;
  575. # is this a match?
  576. if ((!defined($data->{target}->{fpr})) ||
  577. (substr($foundfprstr, -1 * length($data->{target}->{fpr})) eq $data->{target}->{fpr})) {
  578. if (defined($data->{key})) {
  579. die "Found two matching keys.\n";
  580. }
  581. $data->{key} = { 'rsa' => $pubkey,
  582. 'timestamp' => $key_timestamp };
  583. $data->{current_key_match} = 1;
  584. }
  585. if ($tag != $packet_types->{seckey} &&
  586. $tag != $packet_types->{sec_subkey}) {
  587. if ($readbytes < $packetlen) {
  588. read($instr, $dummy, $packetlen - $readbytes) or die "Could not skip past this packet.\n";
  589. }
  590. return;
  591. }
  592. if (!$data->{current_key_match}) {
  593. # we don't think the public part of this key matches
  594. if ($readbytes < $packetlen) {
  595. read($instr, $dummy, $packetlen - $readbytes) or die "Could not skip past this packet.\n";
  596. }
  597. return;
  598. }
  599. my $s2k;
  600. read($instr, $s2k, 1) or die "Could not read S2K octet.\n";
  601. $readbytes += 1;
  602. $s2k = ord($s2k);
  603. if ($s2k != 0) {
  604. printf(STDERR "We cannot handle encrypted secret keys. Skipping!\n") ;
  605. read($instr, $dummy, $packetlen - $readbytes) or die "Could not skip past this packet.\n";
  606. return;
  607. }
  608. # secret material is unencrypted
  609. # see http://tools.ietf.org/html/rfc4880#section-5.5.3
  610. my $d = read_mpi($instr, \$readbytes);
  611. my $p = read_mpi($instr, \$readbytes);
  612. my $q = read_mpi($instr, \$readbytes);
  613. my $u = read_mpi($instr, \$readbytes);
  614. my $checksum;
  615. read($instr, $checksum, 2) or die "Could not read checksum of secret key material.\n";
  616. $readbytes += 2;
  617. $checksum = unpack('n', $checksum);
  618. # FIXME: compare with the checksum! how? the data is
  619. # gone into the Crypt::OpenSSL::Bignum
  620. $data->{key}->{rsa} = Crypt::OpenSSL::RSA->new_key_from_parameters($modulus,
  621. $exponent,
  622. $d,
  623. $p,
  624. $q);
  625. $data->{key}->{rsa}->check_key() or die "Secret key is not a valid RSA key.\n";
  626. if ($readbytes < $packetlen) {
  627. read($instr, $dummy, $packetlen - $readbytes) or die "Could not skip past this packet.\n";
  628. }
  629. }
  630. sub openpgp2rsa {
  631. my $instr = shift;
  632. my $fpr = shift;
  633. if (defined $fpr) {
  634. if (length($fpr) < 8) {
  635. die "We need at least 8 hex digits of fingerprint.\n";
  636. }
  637. $fpr = uc($fpr);
  638. }
  639. my $data = { target => { fpr => $fpr,
  640. },
  641. };
  642. my $subs = { $packet_types->{pubkey} => \&findkey,
  643. $packet_types->{pub_subkey} => \&findkey,
  644. $packet_types->{seckey} => \&findkey,
  645. $packet_types->{sec_subkey} => \&findkey };
  646. packetwalk($instr, $subs, $data);
  647. return $data->{key}->{rsa};
  648. }
  649. sub findkeyfprs {
  650. my $data = shift;
  651. my $instr = shift;
  652. my $tag = shift;
  653. my $packetlen = shift;
  654. findkey($data, $instr, $tag, $packetlen);
  655. if (defined($data->{key})) {
  656. if (defined($data->{key}->{rsa}) && defined($data->{key}->{timestamp})) {
  657. $data->{keys}->{fingerprint($data->{key}->{rsa}, $data->{key}->{timestamp})} = $data->{key};
  658. } else {
  659. die "should have found some key here";
  660. }
  661. undef($data->{key});
  662. }
  663. };
  664. sub getallprimarykeys {
  665. my $instr = shift;
  666. my $subs = { $packet_types->{pubkey} => \&findkeyfprs,
  667. $packet_types->{seckey} => \&findkeyfprs,
  668. };
  669. my $data = {target => { } };
  670. packetwalk($instr, $subs, $data);
  671. if (defined $data->{keys}) {
  672. return $data->{keys};
  673. } else {
  674. return {};
  675. }
  676. }
  677. sub adduserid {
  678. my $instr = shift;
  679. my $fpr = shift;
  680. my $uid = shift;
  681. my $args = shift;
  682. if ((! defined $fpr) ||
  683. (length($fpr) < 8)) {
  684. die "We need at least 8 hex digits of fingerprint.\n";
  685. }
  686. $fpr = uc($fpr);
  687. if (! defined $uid) {
  688. die "No User ID defined.\n";
  689. }
  690. my $data = { target => { fpr => $fpr,
  691. uid => $uid,
  692. },
  693. };
  694. my $subs = { $packet_types->{seckey} => \&findkey,
  695. $packet_types->{uid} => \&finduid,
  696. $packet_types->{sig} => \&findsig,
  697. };
  698. packetwalk($instr, $subs, $data);
  699. if ((! defined $data->{key}) ||
  700. (! defined $data->{key}->{rsa}) ||
  701. (! defined $data->{key}->{timestamp})) {
  702. die "The key requested was not found.\n"
  703. }
  704. if (defined $data->{uid}->{$uid} &&
  705. defined $data->{sigs} &&
  706. scalar(@{$data->{sigs}}) > 0 ) {
  707. die "The requested User ID '$uid' is already associated with this key.\n";
  708. }
  709. $args->{key_timestamp} = $data->{key}->{timestamp};
  710. return
  711. make_packet($packet_types->{pubkey}, make_rsa_pub_key_body($data->{key}->{rsa}, $data->{key}->{timestamp})).
  712. make_packet($packet_types->{uid}, $uid).
  713. makeselfsig($data->{key}->{rsa},
  714. $uid,
  715. $args);
  716. }
  717. sub revokeuserid {
  718. my $instr = shift;
  719. my $fpr = shift;
  720. my $uid = shift;
  721. my $sigtime = shift;
  722. if ((! defined $fpr) ||
  723. (length($fpr) < 8)) {
  724. die "We need at least 8 hex digits of fingerprint.\n";
  725. }
  726. $fpr = uc($fpr);
  727. if (! defined $uid) {
  728. die "No User ID defined.\n";
  729. }
  730. my $data = { target => { fpr => $fpr,
  731. uid => $uid,
  732. },
  733. };
  734. my $subs = { $packet_types->{seckey} => \&findkey,
  735. $packet_types->{uid} => \&finduid,
  736. $packet_types->{sig} => \&findsig,
  737. };
  738. packetwalk($instr, $subs, $data);
  739. if ((! defined $data->{uid}) ||
  740. (! defined $data->{uid}->{$uid})) {
  741. die "The User ID \"$uid\" is not associated with this key";
  742. }
  743. if ((! defined $data->{key}) ||
  744. (! defined $data->{key}->{rsa}) ||
  745. (! defined $data->{key}->{timestamp})) {
  746. die "The key requested was not found."
  747. }
  748. my $revocation_reason = 'No longer using this hostname';
  749. if (defined $data->{revocation_reason}) {
  750. $revocation_reason = $data->{revocation_reason};
  751. }
  752. my $rev_reason_subpkt = prefixsubpacket(pack('CC',
  753. $subpacket_types->{revocation_reason},
  754. $revocation_reasons->{user_id_no_longer_valid}).
  755. $revocation_reason);
  756. if (! defined $sigtime) {
  757. $sigtime = time();
  758. }
  759. # what does a signature like this look like?
  760. my $args = { key_timestamp => $data->{key}->{timestamp},
  761. sig_timestamp => $sigtime,
  762. certification_type => $sig_types->{certification_revocation},
  763. hashed_subpackets => $rev_reason_subpkt,
  764. };
  765. return
  766. make_packet($packet_types->{pubkey}, make_rsa_pub_key_body($data->{key}->{rsa}, $data->{key}->{timestamp})).
  767. make_packet($packet_types->{uid}, $uid).
  768. join('', @{$data->{sigs}}).
  769. gensig($data->{key}->{rsa}, $uid, $args);
  770. }
  771. # see 5.2.3.1 for tips on how to calculate the length of a subpacket:
  772. sub prefixsubpacket {
  773. my $subpacket = shift;
  774. my $len = length($subpacket);
  775. my $prefix;
  776. use bytes;
  777. if ($len < 192) {
  778. # one byte:
  779. $prefix = pack('C', $len);
  780. } elsif ($len < 16576) {
  781. my $in = $len - 192;
  782. my $second = $in%256;
  783. my $first = ($in - $second)>>8;
  784. $prefix = pack('CC', $first + 192, $second)
  785. } else {
  786. $prefix = pack('CN', 255, $len);
  787. }
  788. return $prefix.$subpacket;
  789. }
  790. sub packetwalk {
  791. my $instr = shift;
  792. my $subs = shift;
  793. my $data = shift;
  794. my $packettag;
  795. my $dummy;
  796. my $tag;
  797. while (! eof($instr)) {
  798. read($instr, $packettag, 1);
  799. $packettag = ord($packettag);
  800. my $packetlen;
  801. if ( ! (0x80 & $packettag)) {
  802. die "This is not an OpenPGP packet\n";
  803. }
  804. if (0x40 & $packettag) {
  805. # this is a new-format packet.
  806. $tag = (0x3f & $packettag);
  807. my $nextlen = 0;
  808. read($instr, $nextlen, 1);
  809. $nextlen = ord($nextlen);
  810. if ($nextlen < 192) {
  811. $packetlen = $nextlen;
  812. } elsif ($nextlen < 224) {
  813. my $newoct;
  814. read($instr, $newoct, 1);
  815. $newoct = ord($newoct);
  816. $packetlen = (($nextlen - 192) << 8) + ($newoct) + 192;
  817. } elsif ($nextlen == 255) {
  818. read($instr, $nextlen, 4);
  819. $packetlen = unpack('N', $nextlen);
  820. } else {
  821. # packet length is undefined.
  822. }
  823. } else {
  824. # this is an old-format packet.
  825. my $lentype;
  826. $lentype = 0x03 & $packettag;
  827. $tag = ( 0x3c & $packettag ) >> 2;
  828. if ($lentype == 0) {
  829. read($instr, $packetlen, 1) or die "could not read packet length\n";
  830. $packetlen = unpack('C', $packetlen);
  831. } elsif ($lentype == 1) {
  832. read($instr, $packetlen, 2) or die "could not read packet length\n";
  833. $packetlen = unpack('n', $packetlen);
  834. } elsif ($lentype == 2) {
  835. read($instr, $packetlen, 4) or die "could not read packet length\n";
  836. $packetlen = unpack('N', $packetlen);
  837. } else {
  838. # packet length is undefined.
  839. }
  840. }
  841. if (! defined($packetlen)) {
  842. die "Undefined packet lengths are not supported.\n";
  843. }
  844. if (defined $subs->{$tag}) {
  845. $subs->{$tag}($data, $instr, $tag, $packetlen);
  846. } else {
  847. read($instr, $dummy, $packetlen) or die "Could not skip past this packet!\n";
  848. }
  849. }
  850. return $data->{key};
  851. }
  852. for (basename($0)) {
  853. if (/^pem2openpgp$/) {
  854. my $rsa;
  855. my $stdin;
  856. my $uid = shift;
  857. defined($uid) or die "You must specify a user ID string.\n";
  858. # FIXME: fail if there is no given user ID; or should we default to
  859. # hostname_long() from Sys::Hostname::Long ?
  860. if (defined $ENV{PEM2OPENPGP_NEWKEY}) {
  861. $rsa = Crypt::OpenSSL::RSA->generate_key($ENV{PEM2OPENPGP_NEWKEY});
  862. } else {
  863. $stdin = do {
  864. local $/; # slurp!
  865. <STDIN>;
  866. };
  867. $rsa = Crypt::OpenSSL::RSA->new_private_key($stdin);
  868. }
  869. my $key_timestamp = $ENV{PEM2OPENPGP_KEY_TIMESTAMP};
  870. my $sig_timestamp = $ENV{PEM2OPENPGP_TIMESTAMP};
  871. $sig_timestamp = time() if (!defined $sig_timestamp);
  872. $key_timestamp = $sig_timestamp if (!defined $key_timestamp);
  873. print
  874. make_packet($packet_types->{seckey}, make_rsa_sec_key_body($rsa, $key_timestamp)).
  875. make_packet($packet_types->{uid}, $uid).
  876. makeselfsig($rsa,
  877. $uid,
  878. { sig_timestamp => $sig_timestamp,
  879. key_timestamp => $key_timestamp,
  880. expiration => $ENV{PEM2OPENPGP_EXPIRATION},
  881. usage_flags => $ENV{PEM2OPENPGP_USAGE_FLAGS},
  882. }
  883. );
  884. }
  885. elsif (/^openpgp2ssh$/) {
  886. my $fpr = shift;
  887. my $instream;
  888. open($instream,'-');
  889. binmode($instream, ":bytes");
  890. my $key = openpgp2rsa($instream, $fpr);
  891. if (defined($key)) {
  892. if ($key->is_private()) {
  893. print $key->get_private_key_string();
  894. } else {
  895. print "ssh-rsa ".encode_base64(openssh_pubkey_pack($key), '')."\n";
  896. }
  897. } else {
  898. die "No matching key found.\n";
  899. }
  900. }
  901. elsif (/^keytrans$/) {
  902. # subcommands when keytrans is invoked directly are UNSUPPORTED,
  903. # UNDOCUMENTED, and WILL NOT BE MAINTAINED.
  904. my $subcommand = shift;
  905. for ($subcommand) {
  906. if (/^revokeuserid$/) {
  907. my $fpr = shift;
  908. my $uid = shift;
  909. my $instream;
  910. open($instream,'-');
  911. binmode($instream, ":bytes");
  912. my $revcert = revokeuserid($instream, $fpr, $uid, $ENV{PEM2OPENPGP_TIMESTAMP});
  913. print $revcert;
  914. } elsif (/^adduserid$/) {
  915. my $fpr = shift;
  916. my $uid = shift;
  917. my $instream;
  918. open($instream,'-');
  919. binmode($instream, ":bytes");
  920. my $newuid = adduserid($instream, $fpr, $uid,
  921. { sig_timestamp => $ENV{PEM2OPENPGP_TIMESTAMP},
  922. expiration => $ENV{PEM2OPENPGP_EXPIRATION},
  923. usage_flags => $ENV{PEM2OPENPGP_USAGE_FLAGS},
  924. });
  925. print $newuid;
  926. } elsif (/^listfprs$/) {
  927. my $instream;
  928. open($instream,'-');
  929. binmode($instream, ":bytes");
  930. my $keys = getallprimarykeys($instream);
  931. printf("%s\n", join("\n", map { uc(unpack('H*', $_)) } keys(%{$keys})));
  932. } elsif (/^sshfpr$/) {
  933. use MIME::Base64;
  934. my $b64keyblob;
  935. my $dummy;
  936. while (($dummy,$b64keyblob) = split(/ /, <STDIN>)) {
  937. printf("%s\n", sshfpr(decode_base64($b64keyblob)));
  938. }
  939. } elsif (/^openpgp2sshfpr$/) {
  940. my $fpr = shift;
  941. my $instream;
  942. open($instream,'-');
  943. binmode($instream, ":bytes");
  944. my $key = openpgp2rsa($instream, $fpr);
  945. if (defined($key)) {
  946. # openssh uses MD5 for key fingerprints:
  947. printf("%d %s %s\n",
  948. $key->size() * 8, # size() is in bytes -- we want bits
  949. sshfpr(openssh_pubkey_pack($key)),
  950. '(RSA)', # FIXME when we support other than RSA.
  951. );
  952. } else {
  953. die "No matching key found.\n";
  954. }
  955. } else {
  956. die "Unrecognized subcommand. keytrans subcommands are not a stable interface!\n";
  957. }
  958. }
  959. }
  960. else {
  961. die "Unrecognized keytrans call.\n";
  962. }
  963. }