CACreateCert

   1 #!/usr/bin/env perl
   2
   3 # CACreateCert - Create various types of certificates
   4 # Copyright (c) 2011,2012,2013 Kyle J. McKay.  All rights reserved.
   5
   6 # This program is free software: you can redistribute it and/or modify
   7 # it under the terms of the GNU Affero General Public License as published by
   8 # the Free Software Foundation, either version 3 of the License, or
   9 # (at your option) any later version.
  10 #
  11 # This program is distributed in the hope that it will be useful,
  12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 # GNU Affero General Public License for more details.
  15 #
  16 # You should have received a copy of the GNU Affero General Public License
  17 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 exit(&main());
  20
  21 use strict;
  22 use warnings;
  23 use bytes;
  24
  25 use MIME::Base64;
  26 use IPC::Open2;
  27 use Digest::MD5 qw(md5 md5_hex md5_base64);
  28 use Getopt::Long qw(:config gnu_getopt);
  29
  30 our $VERSION;
  31 my $VERSIONMSG;
  32 my $HELP;
  33 my $USAGE;
  34
  35 my $hasSha2;
  36
  37 BEGIN {
  38   *VERSION = \'1.2.18';
  39   $VERSIONMSG = "CACreateCert version $VERSION\n" .
  40     "Copyright (c) 2011-2014 Kyle J. McKay.  All rights reserved.\n" .
  41     "License AGPLv3+: GNU Affero GPL version 3 or later.\n" .
  42     "http://gnu.org/licenses/agpl.html\n" .
  43     "This is free software: you are free to change and redistribute it.\n" .
  44     "There is NO WARRANTY, to the extent permitted by law.\n";
  45 }
  46
  47 BEGIN {
  48   $hasSha2 = 0;
  49
  50   eval {
  51     require Digest::SHA;
  52     Digest::SHA->import(
  53       qw(
  54         sha1 sha1_hex sha1_base64
  55         sha224 sha224_hex sha224_base64
  56         sha256 sha256_hex sha256_base64
  57         sha384 sha384_hex sha384_base64
  58         sha512 sha512_hex sha512_base64
  59       )
  60     ); $hasSha2=1} ||
  61   eval {
  62     require Digest::SHA::PurePerl;
  63     require Digest::SHA1;
  64     Digest::SHA1->import(
  65       qw(
  66         sha1 sha1_hex sha1_base64
  67       )
  68     );
  69     Digest::SHA::PurePerl->import(
  70       qw(
  71         sha224 sha224_hex sha224_base64
  72         sha256 sha256_hex sha256_base64
  73         sha384 sha384_hex sha384_base64
  74         sha512 sha512_hex sha512_base64
  75       )
  76     ); $hasSha2=1} ||
  77   eval {
  78     require Digest::SHA::PurePerl;
  79     Digest::SHA::PurePerl->import(
  80       qw(
  81         sha1 sha1_hex sha1_base64
  82         sha224 sha224_hex sha224_base64
  83         sha256 sha256_hex sha256_base64
  84         sha384 sha384_hex sha384_base64
  85         sha512 sha512_hex sha512_base64
  86       )
  87     ); $hasSha2=1} ||
  88   eval {
  89     require Digest::SHA1;
  90     Digest::SHA1->import(
  91       qw(
  92         sha1 sha1_hex sha1_base64
  93       )
  94     ); 1} ||
  95   die "One of Digest::SHA1 or Digest::SHA or Digest::SHA::PurePerl "
  96     . "must be available\n";
  97
  98   eval {(`openssl version -v 2>/dev/null` || '') =~ /^OpenSSL /} ||
  99     die "OpenSSL (as the openssl command) is not available in the PATH\n";
 100 }
 101
 102 BEGIN {
 103   $USAGE = <<USAGE;
 104 Usage: CACreateCert [-h] [--version] [--verbose] [--debug] [--quiet] [--check]
 105          [--now] [--pubx509] [-t] [--digest=sha1|sha224|sha256|sha384|sha512]
 106          [--root | --subca | --server | --codesign | --applecodesign | --email]
 107          [--client] [--rootauth] [--authext] [--pathlen n] [--suffix suffix.pem]
 108          [--random | --no-random] [--in pub_key_file] [--out out_cert.pem]
 109          [--cert signing_cert] [--dns "name-or-ip"] [--dnq "qual"]
 110          --key priv_key_file "name string"
 111 USAGE
 112   $HELP = <<HELP;
 113 NAME
 114        CACreateCert -- create X.509 certificate
 115
 116 SYNOPSIS
 117        CACreateCert [-h] [--version] [--verbose] [--debug] [--quiet] [--check]
 118          [--now] [--pubx509] [-t] [--digest=sha1|sha224|sha256|sha384|sha512]
 119          [--root | --subca | --server | --codesign | --applecodesign | --email]
 120          [--client] [--rootauth] [--authext] [--pathlen n] [--suffix suffix.pem]
 121          [--random | --no-random] [--in pubkeyfile] [--out pemcertfile]
 122          [--cert signing_cert] [--dns "name-or-ip"] [--dnq "qual"]
 123          --key priv_key_file "name string"
 124        CACreateCert --root [--random] --key priv_key_file "name string" > ca.pem
 125        CACreateCert --key priv_key_file --cert signing_cert "name string"
 126          < pub_key_file > out_cert.pem
 127
 128 DESCRIPTION
 129        CACreateCert creates a new certificate.  Various certificate types are
 130        supported including root CA certificates, sub CA certificates, server
 131        certificates, code signing certificates, email certificates and client
 132        certificates.
 133
 134        When creating a certificate, the only private key required is that of
 135        the signer.  This means that, for example, a new client authentication
 136        certifcate can be created given only the public key of the client and
 137        the private key of the signing certificate.
 138
 139        The public key for the certificate being created may be provided in
 140        either OpenSSH .pub format or X.509 public key format.  The
 141        "openssl rsa -pubout" or "openssl x509 -noout -pubkey" commands can be
 142        used to produce an X.509 format public key from either an RSA private key
 143        or an X.509 certificate respectively.  Note that only OpenSSH RSA public
 144        keys in protocol format 2 are supported (they start with "ssh-rsa ").
 145
 146        When creating a root certificate no public key is required.
 147
 148        The "name string" value given must be appropriate for the type of
 149        certificate being created.  For a client authentication certificate it
 150        will typically be a *nix user login (all lowercase) on the server to
 151        which clients connect to.  For an email certificate it will typically
 152        be the full email address.  For a server it will generally be the
 153        canonical DNS name of the server.
 154
 155        No validation is performed on the "name string" value except that it
 156        must not be the empty string.  It may be provided in either Latin-1 or
 157        UTF-8.
 158
 159        The priv_key_file must be an RSA private key file in PEM or DER format
 160        and furthermore it must not have a password (both openssl genrsa and
 161        ssh-keygen -t rsa can create these kinds of RSA private key files).  If
 162        a host is running an OpenSSH sshd daemon, then it probably already has a
 163        suitable host private RSA key in either /etc/ssh/ssh_host_rsa_key or
 164        /etc/ssh_host_rsa_key that can be used if desired.
 165
 166        The signing_cert must be an X.509 certificate that uses priv_key_file as
 167        its private key.  It may be in either PEM or DER format.  The created
 168        certificate will be signed by the signing_cert.  The CACreateCert utility
 169        can be used to create a suitable signing_cert certificate authority
 170        certificate from the priv_key_file if desired by using the --root option.
 171
 172        When creating a root certificate no signing_cert is required.
 173
 174        On success the new certificate is written in PEM format to standard
 175        output.  (All error/information messages are written to standard error.)
 176
 177        Note that certificates created by CACreateCert are deterministic (i.e.
 178        the bytewise identical certificate will be output) given the identical
 179        input arguments only so long as neither the --random nor --now options
 180        are used.
 181
 182        Also note that the certificates created by this utility do not expire.
 183
 184 OPTIONS
 185        -h/--help
 186               Show this help
 187
 188        -V/--version
 189               Show the CACreateCert version
 190
 191        -v/--verbose
 192               Produce extra informational messages to standard error.
 193               Suppresses --quiet.
 194
 195        --debug
 196               Show debugging information.  Automatically enables --verbose.
 197               Suppresses --quiet.
 198
 199        --quiet
 200               Suppress all messages except errors.  Ignored if --debug or
 201               --verbose given.
 202
 203        --check
 204               Perform all normal validation checks (except for a non-empty
 205               "name string") but do not actually produce a certificate.
 206               Automatically enables --verbose.
 207
 208        --now
 209               Normally the validity not before date will be set to the signing
 210               certificate's not before date or the approval date of the X.509
 211               v3 standard (root certificates).  Using this option causes the
 212               not before validity date of the generated certificate to be set
 213               to the current time.  Use of this option will preclude production
 214               of byte-exact matching output certificates for the same input
 215               arguments.
 216
 217        --pubx509/--pubX509
 218               Force the public key read from standard input to be interpreted
 219               as an X.509 format public key.  Normally this should be
 220               automatically detected and this option should not be needed.
 221               This option is ignored if --root is given.
 222
 223        -t
 224               Allow reading the public key from standard input when standard
 225               input is a tty.  In most cases attempting to read the public key
 226               from standard input that is a tty indicates that the public key
 227               was accidentally omitted.  If that is not the case, the -t option
 228               must be given to allow reading the public key from standard input
 229               when standard input is a tty.  This option is always implied if
 230               the --in option is used with a value other than "-".
 231
 232        --digest name
 233               Select the digest to use in the generated certificate.  Must be
 234               one of sha1, sha224, sha256, sha384 or sha512.  By default sha256
 235               will be used if available otherwise sha1 will be used (and a
 236               warning issued).  All systems support sha1 digest certificates,
 237               but sha1 should really not be used anymore (see NIST
 238               recommendation SP 800-131A).  OpenSSL starting with version 0.9.8
 239               (released 2005-07-05) supports the SHA-2 family of hash functions
 240               (sha224, sha256, sha384 and sha512) which should be used instead
 241               of sha1.  Note that either Digest::SHA or Digest::SHA::PurePerl
 242               must be available to use sha224, sha256, sha384 or sha512.
 243
 244        --root
 245        --subca
 246        --server
 247        --codesign
 248        --applecodesign
 249        --email
 250        --client
 251               Select the type of certificate to generate.  If --root is given
 252               then a root certificate will be created and any --cert option will
 253               be ignored as well as standard input.  If none of these options is
 254               given then --client will be assumed.  Both --root and --subca
 255               generate certificate authority certificates (CA:TRUE).
 256               Specifying any of --root, --subca, --server, --codesign or
 257               --applecodesign will cause the "name string" to be embedded as
 258               a commonName (CN).  Otherwise if --email is specified
 259               "name string" will be embedded as an emailAddress (and a subject
 260               alternative name email type).  Finally if none of those apply then
 261               "name string" will be embedded as a userId (UID) instead
 262               (client certificates).  The certificate's key usage bits will be
 263               set to one of four values.  --root or --subca select the first,
 264               --server selects the second, --email selects the third otherwise
 265               the fourth is used.  If any of --server, --client (explicit or
 266               implied), --codesign, --email or --applecodesign are given then
 267               extended key usage items will be included (up to five -- one for
 268               each option given).
 269
 270        --pathlen n
 271               The --pathlen option will be ignored unless --subca is given in
 272               which case the X509v3 Basic Constraints will include the
 273               specified pathlen value.
 274
 275        --rootauth
 276               Ignored unless --root given.  Normally --root certificates do not
 277               include an X509v3 Authority Key Identifier.  If this option is
 278               given then they will (with only a keyid value).
 279
 280        --authext
 281               Ignored if --root given.  Normally non --root certificates include
 282               an X509v3 Authority Key Identifier section with only a keyid
 283               value.  If this option is given, then the name and serial number
 284               will also be included.
 285
 286        --random
 287               Ignored unless --root given.  When generating a --root certificate
 288               normally only the "name string" value is embedded (as the CN
 289               attribute).  If this option is given, a random serialNumber will
 290               be generated and the issuer name will be the serialNumber followed
 291               by the CN.  If this option is given, the "name string" may be set
 292               to the empty string (it must be explicit, e.g. "") in which case
 293               the issuer name will be just the random serialNumber.  Use of this
 294               option will preclude production of byte-exact matching output
 295               certificates for the same input arguments.  This is now the
 296               default when --root is given.
 297
 298        --no-random
 299               Ignored unless --root given.  Turns off the default --random
 300               option that is normally enabled by default when --root is given.
 301
 302        --key priv_key_file
 303               The RSA private key in either PEM or DER format.  This option
 304               is always required.
 305
 306        --cert signing_cert
 307               Ignored if --root is given.  The signing X.509 certificate in
 308               either PEM or DER format.  The public key embedded in signing_cert
 309               must match the one in the priv_key_file or an error will occur.
 310
 311        --in pub_key_file
 312               Ignored if --root is given.  The public key for the certificate
 313               to be created.  Must be different than the public key contained in
 314               priv_key_file.  May be an OpenSSH protocol 2 format RSA public key
 315               or an X.509 format public key (in either PEM or DER format).  See
 316               also the --pubx509 option.  If pub_key_file is "-" or this option
 317               is omitted then standard input is read.
 318
 319        --out out_cert.pem
 320               The generated certificate will be written to out_cert.pem.  If
 321               this option is omitted or out_cert.pem is "-" then the generated
 322               certificate is written to standard output.
 323
 324        --suffix suffix.pem
 325               Primarily intended to be used when generating client certificates,
 326               if this option is given, then the entire contents of suffix.pem is
 327               written to the same location as the generated certificate
 328               immediately following the certificate.  This option may be given
 329               more than once in which case the files will be appended to the
 330               output in the order the --suffix options were given.
 331
 332        --dns domain-name-or-ip
 333               Ignored unless --server given.  Adds the given domain-name-or-ip
 334               as a subject alternative name (either DNS or IPAddress).  May
 335               be repeated to add multiple alternative names.  A DNS name must
 336               satisfy RFC 1034 section 3.5 as modified by RFC 1123 section 2.1
 337               except that the leftmost label may be the single character '*'.
 338               An IP address may be either IPv4 or IPv6 (do NOT use surrounding
 339               '[', ']' characters on an IPv6 address). An IPv6 address MUST NOT
 340               have a scope identifier.  Note that when --server is given, the
 341               common name (CN) value is NOT automatically added as a subject
 342               alternative name -- it must be specified explicitly with a --dns
 343               option if that is desired (and normally it IS desirable).
 344
 345        --dnq qual
 346               Optional for all certificate types.  If given must not be the
 347               empty string.  Will be embedded into the subject's distinguished
 348               name as the final component.  Use of this option is not
 349               recommended when using --server or --email.  The value must be
 350               a PrintableString (needs to match [A-Za-z0-9 '()+,./:=?-]+).
 351
 352        name string
 353               The name to embed in the certificate as the subject.  This will
 354               be embedded as a common name (CN) except when --client is in
 355               effect in which case it will be embedded as a user id (UID) or
 356               when --email is in effect in which case it will be embedded as
 357               an email address in both the subject and subject alternative name.
 358               The "name string" value may never be omitted but may be explictly
 359               given as the empty string ('' or "") when generating a root
 360               certificate using a random serial number.
 361
 362 NOTES
 363        All systems support sha1 digest certificates, but sha1 should really not
 364        be used anymore (NIST recommendation SP 800-131A).  OpenSSL starting
 365        with versions 0.9.8 (released 2005-07-05) supports the SHA-2 family of
 366        hash functions (sha224, sha256, sha384 and sha512) which should be used
 367        instead.
 368
 369        NIST SP 800-131A requires use of an RSA key with 2048 or more bits and
 370        a hash function with 224 or more bits after December 31 2010.
 371
 372        RFC 6194 states sha256 is the most commonly used alternative to sha1
 373        (and will be used by default if a suitable SHA module is available).
 374
 375        Note that NIST SP 800-78-3 requires RSA public key exponents to be
 376        greater than or equal to 65537.  OpenSSH version 5.4 and later generate
 377        RSA keys with a public exponent of 65537 otherwise openssl genrsa can
 378        be used together with ssh-keygen -y to create a suitable OpenSSH key that
 379        uses an exponent of 65537 instead of 35.
 380
 381 TIPS
 382        Display the currently available version of OpenSSL with:
 383
 384            openssl version
 385
 386        Display the currently available version of OpenSSH with:
 387
 388            ssh -V
 389
 390 BUGS
 391        The ability to create self-signed types other than --root by combining
 392        the --root option with one of the others (e.g. --client, --email,
 393        --codesign, --server) is poorly documented.  Furthermore, since the
 394        standard (see RFC 5280) effectively requires at least two certificates
 395        in a valid certificate chain since a chain must have a non-root leaf
 396        to be valid.
 397
 398        The ability to sign using whirlpool, which requires use of an unofficial
 399        OID (1.2.840.113549.1.1.15) should, perhaps, not be allowed.
 400
 401 HELP
 402 }
 403
 404 sub IsUTF8($)
 405 {
 406   # Return 0 if non-UTF-8 sequences present
 407   # Return -1 if no characters > 0x7F found
 408   # Return 1 if valid UTF-8 sequences present
 409   use bytes;
 410   return -1 if $_[0] !~ /[\x80-\xFF]/so;
 411   my $l = length($_[0]);
 412   for (my $i=0; $i<$l; ++$i) {
 413     my $c = ord(substr($_[0],$i,1));
 414     next if $c < 0x80;
 415     return 0 if $c < 0xC0 || $c >= 0xF8;
 416     if ($c <= 0xDF) {
 417       # Need 1 more byte
 418       ++$i;
 419       return 0 if $i >= $l;
 420       my $c2 = ord(substr($_[0],$i,1));
 421       return 0 if $c2 < 0x80 || $c2 > 0xBF;
 422       my $u = (($c & 0x1F) << 6) | ($c2 & 0x3F);
 423       return 0 if $u < 0x80;
 424       next;
 425     }
 426     if ($c <= 0xEF) {
 427       # Need 2 more bytes
 428       $i += 2;
 429       return 0 if $i >= $l;
 430       my $c2 = ord(substr($_[0],$i-1,1));
 431       return 0 if $c2 < 0x80 || $c2 > 0xBF;
 432       my $c3 = ord(substr($_[0],$i,1));
 433       return 0 if $c3 < 0x80 || $c3 > 0xBF;
 434       my $u = (($c & 0x0F) << 12) | (($c2 & 0x3F) << 6) | ($c3 & 0x3F);
 435       return 0 if $u < 0x800 || ($u >= 0xD800 && $u <= 0xDFFFF) || $u >= 0xFFFE;
 436       next;
 437     }
 438     # Need 3 more bytes
 439     $i += 3;
 440     return 0 if $i >= $l;
 441     my $c2 = ord(substr($_[0],$i-2,1));
 442     return 0 if $c2 < 0x80 || $c2 > 0xBF;
 443     my $c3 = ord(substr($_[0],$i-1,1));
 444     return 0 if $c3 < 0x80 || $c3 > 0xBF;
 445     my $c4 = ord(substr($_[0],$i,1));
 446     return 0 if $c4 < 0x80 || $c4 > 0xBF;
 447     my $u = (($c & 0x07) << 18) | (($c2 & 0x3F) << 12) | (($c3 & 0x3F) << 6)
 448                                                                  | ($c4 & 0x3F);
 449     return 0 if $u < 0x10000 || $u >= 0x10FFFE || (($u & 0xFFFF) >= 0xFFFE);
 450   }
 451   return 1;
 452 }
 453
 454 sub Make1252()
 455 {
 456   use bytes;
 457   our %W1252;
 458
 459   # Provide translations for 0x80-0x9F into UTF-8
 460   $W1252{0x80} = pack('H*','E282AC'); # 0x20AC Euro
 461   $W1252{0x82} = pack('H*','E2809A'); # 0X201A Single Low-9 Quote
 462   $W1252{0x83} = pack('H*','C692');   # 0x0192 Latin Small Letter f With Hook
 463   $W1252{0x84} = pack('H*','E2809E'); # 0x201E Double Low-9 Quote
 464   $W1252{0x85} = pack('H*','E280A6'); # 0x2026 Horizontal Ellipsis
 465   $W1252{0x86} = pack('H*','E280A0'); # 0x2020 Dagger
 466   $W1252{0x87} = pack('H*','E280A1'); # 0x2021 Double Dagger
 467   $W1252{0x88} = pack('H*','CB86');   # 0x02C6 Modifier Letter Circumflex Accent
 468   $W1252{0x89} = pack('H*','E28080'); # 0x2030 Per Mille Sign
 469   $W1252{0x8A} = pack('H*','C5A0');   # 0x0160 Latin Capital Letter S With Caron
 470   $W1252{0x8B} = pack('H*','E28089'); # 0x2039 Left Single Angle Quote
 471   $W1252{0x8C} = pack('H*','C592');   # 0x0152 Latin Capital Ligature OE
 472   $W1252{0x8E} = pack('H*','C5BD');   # 0x017D Latin Capital Letter Z With Caron
 473   $W1252{0x91} = pack('H*','E28098'); # 0x2018 Left Single Quote
 474   $W1252{0x92} = pack('H*','E28099'); # 0x2019 Right Single Quote
 475   $W1252{0x93} = pack('H*','E2809C'); # 0x201C Left Double Quote
 476   $W1252{0x94} = pack('H*','E2809D'); # 0x201D Right Double Quote
 477   $W1252{0x95} = pack('H*','E280A2'); # 0x2022 Bullet
 478   $W1252{0x96} = pack('H*','E28093'); # 0x2013 En Dash
 479   $W1252{0x97} = pack('H*','E28094'); # 0x2014 Em Dash
 480   $W1252{0x98} = pack('H*','CB9C');   # 0x02DC Small Tilde
 481   $W1252{0x99} = pack('H*','E284A2'); # 0x2122 Trade Mark Sign
 482   $W1252{0x9A} = pack('H*','C5A1');   # 0x0161 Latin Small Letter s With Caron
 483   $W1252{0x9B} = pack('H*','E2808A'); # 0x203A Right Single Angle Quote
 484   $W1252{0x9C} = pack('H*','C593');   # 0x0153 Latin Small Ligature oe
 485   $W1252{0x9E} = pack('H*','C5BE');   # 0x017E Latin Small Letter z With Caron
 486   $W1252{0x9F} = pack('H*','C5B8');   # 0x0178 Latin Cap Letter Y With Diaeresis
 487 }
 488
 489 sub MakeUTF8($)
 490 {
 491   use bytes;
 492   our %W1252;
 493
 494   return $_[0] if (IsUTF8($_[0]));
 495   my $ans = '';
 496   foreach my $c (unpack('C*',$_[0])) {
 497     if ($c < 0x80) {
 498       $ans .= chr($c);
 499     }
 500     else {
 501       # Ass/u/me we have Latin-1 (ISO-8859-1) but per the HTML 5 draft treat
 502       # it as windows-1252
 503       if ($c >= 0xA0 || !defined($W1252{$c})) {
 504         $ans .= chr(0xC0 | ($c >> 6));
 505         $ans .= chr(0x80 | ($c & 0x3F));
 506       }
 507       else {
 508         $ans .= $W1252{$c};
 509       }
 510     }
 511   }
 512   return $ans;
 513 }
 514
 515 sub formatbold($;$)
 516 {
 517   my $str = shift;
 518   my $fancy = shift || 0;
 519   if ($fancy) {
 520     $str = join('',map($_."\b".$_, split(//,$str)));
 521   }
 522   return $str;
 523 }
 524
 525 sub formatul($;$)
 526 {
 527   my $str = shift;
 528   my $fancy = shift || 0;
 529   if ($fancy) {
 530     $str = join('',map("_\b".$_, split(//,$str)));
 531   }
 532   return $str;
 533 }
 534
 535 sub formatman($;$)
 536 {
 537   my $man = shift;
 538   my $fancy = shift || 0;
 539   my @inlines = split(/\n/, $man, -1);
 540   my @outlines = ();
 541   foreach my $line (@inlines) {
 542     if ($line =~ /^[A-Z]+$/) {
 543       $line = formatbold($line, $fancy);
 544     }
 545     else {
 546       $line =~ s/'''(.+?)'''/formatbold($1,$fancy)/gse;
 547       $line =~ s/''(.+?)''/formatul($1,$fancy)/gse;
 548     }
 549     push (@outlines, $line);
 550   }
 551   my $result = join("\n", @outlines);
 552   $result =~ s/\\\n//gso;
 553   return $result;
 554 }
 555
 556 sub DERLength($)
 557 {
 558   # return a DER encoded length
 559   my $len = shift;
 560   return pack('C',$len) if $len <= 127;
 561   return pack('C2',0x81, $len) if $len <= 255;
 562   return pack('Cn',0x82, $len) if $len <= 65535;
 563   return pack('CCn',0x83, ($len >> 16), $len & 0xFFFF) if $len <= 16777215;
 564   # Silently returns invalid result if $len > 2^32-1
 565   return pack('CN',0x84, $len);
 566 }
 567
 568 sub SingleOID($)
 569 {
 570   # return a single DER encoded OID component
 571   no warnings;
 572   my $num = shift;
 573   $num += 0;
 574   my $result = pack('C', $num & 0x7F);
 575   $num >>= 7;
 576   while ($num) {
 577     $result = pack('C', 0x80 | ($num & 0x7F)) . $result;
 578     $num >>= 7;
 579   }
 580   return $result;
 581 }
 582
 583 sub DEROID($)
 584 {
 585   # return a DER encoded OID complete with leading 0x06 and DER length
 586   # Input is a string of decimal numbers separated by '.' with at least
 587   # two numbers required.
 588   no warnings;
 589   my @ids = split(/[.]/,$_[0]);
 590   push(@ids, 0) while @ids < 2; # return something that's kind of valid
 591   unshift(@ids, shift(@ids) * 40 + shift(@ids)); # combine first two
 592   my $ans = '';
 593   foreach my $num (@ids) {
 594     $ans .= SingleOID($num);
 595   }
 596   return pack('C',0x6).DERLength(length($ans)).$ans;
 597 }
 598
 599 sub DERTime($)
 600 {
 601   my $t = shift; # a time() value
 602   my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($t);
 603   $year += 1900;
 604   ++$mon;
 605   my $tag;
 606   my $tstr;
 607   if (1950 <= $year && $year < 2050) {
 608     # UTCTime
 609     $tag = 0x17;
 610     $tstr = sprintf("%02d%02d%02d%02d%02d%02dZ", $year % 100, $mon, $mday,
 611       $hour, $min, $sec);
 612   }
 613   else {
 614     # GeneralizedTime
 615     $tag = 0x18;
 616     $tstr = sprintf("%04d%02d%02d%02d%02d%02dZ", $year, $mon, $mday,
 617       $hour, $min, $sec);
 618   }
 619   return pack('C',$tag).DERLength(length($tstr)).$tstr;
 620 }
 621
 622 sub DERInteger($)
 623 {
 624   my $int = shift; # an integer value, may be negative
 625   my @bytes = unpack('C*',pack('N',$int));
 626   shift @bytes while @bytes >= 2 && $bytes[0] == 255 && ($bytes[1] & 0x80);
 627   shift @bytes while @bytes >= 2 && $bytes[0] == 0 && !($bytes[1] & 0x80);
 628   return pack('C*',0x02,scalar(@bytes),@bytes);
 629 }
 630
 631 sub RandomID(;$)
 632 {
 633   # return 20 random bytes except that the first byte has its high bit clear
 634   my $suppress = shift || 0;
 635   print STDERR "Generating serial number, please wait...\n" unless $suppress;
 636   my $randfile = "/dev/random";
 637   $randfile = "/dev/urandom" if -e "/dev/urandom";
 638   open(RANDIN, "<", $randfile)
 639     or die "Cannot open $randfile for input: $!\n";
 640   my $result = '';
 641   for (my $cnt = 0; $cnt < 20; ++$cnt) {
 642     my $byte;
 643     sysread(RANDIN, $byte, 1)
 644       or die "Cannot read from $randfile: $!\n";
 645     if (!$cnt) {
 646       my $val = unpack('C', $byte);
 647       $val &= 0x7F;
 648       $byte = pack('C', $val);
 649     }
 650     $result .= $byte;
 651   }
 652   close(RANDIN);
 653   print STDERR "...done creating serial number.\n" unless $suppress;
 654   return $result;
 655 }
 656
 657 sub ReadDERLength($)
 658 {
 659   # Input is a DER encoded length with possibly extra trailing bytes
 660   # Output is an array of length and bytes-used-for-encoded-length
 661   my $der = shift;
 662   return undef unless length($der);
 663   my $byte = unpack('C',substr($der,0,1));
 664   return ($byte, 1) if $byte <= 127;
 665   return undef if $byte == 128 || $byte > 128+8; # Fail if greater than 2^64
 666   my $cnt = $byte & 0x7F;
 667   return undef unless length($der) >= $cnt+1; # Fail if not enough bytes
 668   my $val = 0;
 669   for (my $i = 0; $i < $cnt; ++$i) {
 670     $val <<= 8;
 671     $val |= unpack('C',substr($der,$i+1,1));
 672   }
 673   return ($val, $cnt+1);
 674 }
 675
 676 sub DERTimeStr($)
 677 {
 678   my $der = shift;
 679   return undef unless length($der) >= 2;
 680   my $byte = unpack('C',substr($der,0,1));
 681   return undef unless $byte == 0x17 || $byte == 0x18;
 682   my ($len, $lenbytes) = ReadDERLength(substr($der,1));
 683   return undef unless length($der) == 1 + $lenbytes + $len;
 684   return undef
 685     unless ($byte == 0x17 && $len == 13) || ($byte == 0x18 && $len == 15);
 686   substr($der,0,1+$lenbytes) = '';
 687   if ($byte == 0x17) {
 688     no warnings;
 689     my $year = substr($der,0,2) + 1900;
 690     $year += 100 if $year < 1950;
 691     $der = sprintf("%04d",$year).substr($der,2);
 692   }
 693   return substr($der,0,4).'-'.substr($der,4,2).'-'.substr($der,6,2).'_'.
 694     substr($der,8,2).':'.substr($der,10,2).':'.substr($der,12,3);
 695 }
 696
 697 sub GetOpenSSHKeyInfo($)
 698 {
 699   # Input is an OpenSSH public key in .pub format
 700   # Output is an array of:
 701   #   how many bits in the modulus
 702   #   the public exponent
 703   #   the key id
 704   #   the OpenSSH md5 fingerprint
 705   #   the OpenSSH sha1 fingerprint
 706   #   the OpenSSH comment (may be '')
 707   #   the OpenSSH public key in OpenSSL PUBLIC KEY DER format
 708   # or undef if the key is unparseable
 709   # or just the key type if it's not ssh-rsa
 710   #
 711   # Expected format is:
 712   #   ssh-rsa BASE64PUBLICKEYDATA optional comment here
 713   # where the BASE64PUBLICKEYDATA when decoded produces:
 714   #   4 Byte Big-Endian length of Key type (must be 7 for RSA)
 715   #   Key type WITHOUT terminating NUL (must be ssh-rsa for RSA)
 716   #   4 Byte Big-Endian length of public exponent
 717   #   Public exponent integer bytes
 718   #   4 Byte Big-Endian length of modulus
 719   #   Modulus integer bytes
 720   # no extra trailing bytes are permitted
 721   my $input = shift;
 722   $input =~ s/((?:\r\n|\n|\r).*)$//os;
 723   my @fields = split(' ', $input, 3);
 724   return undef unless @fields >= 2;
 725   my $data = decode_base64($fields[1]);
 726   my $origData = $data;
 727   my @parts = ();
 728   while (length($data) >= 4) {
 729     my $len = unpack('N',substr($data,0,4));
 730     my $value = '';
 731     if ($len > 0) {
 732       return undef if $len + 4 > length($data);
 733       $value = substr($data,4,$len);
 734     }
 735     push(@parts, $value);
 736     substr($data, 0, 4+$len) = '';
 737   }
 738   return undef unless length($data) == 0;
 739   return $parts[0]
 740     if @parts >= 1 && defined($parts[0]) && $parts[0] && $parts[0] ne 'ssh-rsa';
 741   return undef unless @parts == 3;
 742
 743   my $rsaEncryption = DEROID('1.2.840.113549.1.1.1'); # :rsaEncryption
 744   $rsaEncryption = pack('C',0x30).DERLength(length($rsaEncryption)+2)
 745     .$rsaEncryption.pack('C2',0x05,0x00);
 746   my $pubrsa = pack('C',0x2).DERLength(length($parts[2])).$parts[2]; # modulus
 747   $pubrsa .= pack('C',0x2).DERLength(length($parts[1])).$parts[1]; # exponent
 748   $pubrsa = pack('C',0x30).DERLength(length($pubrsa)).$pubrsa;
 749   my $id = sha1($pubrsa); # The id is the sha1 hash of the private key part
 750   $pubrsa = pack('C',0x3).DERLength(length($pubrsa)+1).pack('C',0x0).$pubrsa;
 751   $pubrsa = $rsaEncryption.$pubrsa;
 752   $pubrsa = pack('C',0x30).DERLength(length($pubrsa)).$pubrsa;
 753
 754   my $bits = length($parts[2]) * 8;
 755   # But we have to discount any leading 0 bits in the first byte
 756   my $byte = unpack('C',substr($parts[2],0,1));
 757   if (!$byte) {
 758     $bits -= 8;
 759   }
 760   else {
 761     return undef if $byte & 0x80; # negative modulus is not allowed
 762     while (!($byte & 0x80)) {
 763       --$bits;
 764       $byte <<= 1;
 765     }
 766   }
 767
 768   my $rawexp = $parts[1];
 769   my $exp;
 770   if (length($rawexp) > 8) {
 771     # Fudge the result because it's bigger than a 64-bit number
 772     my $lastbyte = unpack('C',substr($rawexp,-1,1));
 773     $exp = $lastbyte & 0x01 ? 65537 : 65536;
 774   }
 775   else {
 776     $exp = 0;
 777     while (length($rawexp)) {
 778       $exp <<= 8;
 779       $exp |= unpack('C',substr($rawexp,0,1));
 780       substr($rawexp,0,1) = '';
 781     }
 782   }
 783
 784   return ($bits,$exp,$id,md5($origData),sha1($origData),$fields[2]||'',$pubrsa);
 785 }
 786
 787 sub GetKeyInfo($)
 788 {
 789   # Input is an RSA PRIVATE KEY in DER format
 790   # Output is an array of:
 791   #   how many bits in the modulus
 792   #   the public exponent
 793   #   the key id
 794   #   the OpenSSH md5 fingerprint
 795   #   the OpenSSH sha1 fingerprint
 796   # or undef if the key is unparseable
 797   #
 798   # Expected format is:
 799   #   SEQUENCE {
 800   #     SEQUENCE {
 801   #       OBJECT IDENTIFIER :rsaEncryption = 1.2.840.113549.1.1.1
 802   #       NULL
 803   #     }
 804   #     BIT STRING (primitive) {
 805   #       0 unused bits
 806   #       SEQUENCE { # this part is the contents of an "RSA PUBLIC KEY" file
 807   #         INTEGER modulus
 808   #         INTEGER publicExponent
 809   #       }
 810   #     }
 811   #   }
 812
 813   no warnings;
 814   my $der = shift;
 815   my $rawmod;
 816   my $rawexp;
 817
 818   return undef if unpack('C',substr($der,0,1)) != 0x30;
 819   my ($len, $lenbytes) = ReadDERLength(substr($der,1));
 820   return undef unless length($der) == 1 + $lenbytes + $len;
 821   substr($der, 0, 1 + $lenbytes) = '';
 822
 823   # the algorithm part always encodes as 30 0d 06092a864886f70d010101 0500
 824   return undef
 825     unless substr($der, 0, 15) = pack('H*',"300d06092a864886f70d0101010500");
 826   substr($der, 0, 15) = '';
 827
 828   return undef if unpack('C',substr($der,0,1)) != 0x03;
 829   ($len, $lenbytes) = ReadDERLength(substr($der,1));
 830   return undef unless length($der) == 1 + $lenbytes + $len && $len >= 1;
 831   return undef unless unpack('C',substr($der, 1 + $lenbytes, 1)) == 0x00;
 832   substr($der, 0, 1 + $lenbytes + 1) = '';
 833
 834   return undef if unpack('C',substr($der,0,1)) != 0x30;
 835   ($len, $lenbytes) = ReadDERLength(substr($der,1));
 836   return undef unless length($der) == 1 + $lenbytes + $len;
 837   my $id = sha1($der); # The id is the sha1 hash of the private key part
 838   substr($der, 0, 1 + $lenbytes) = '';
 839
 840   return undef if unpack('C',substr($der,0,1)) != 0x02;
 841   ($len, $lenbytes) = ReadDERLength(substr($der,1));
 842   substr($der, 0, 1 + $lenbytes) = '';
 843   my $derexp = substr($der, $len);
 844   substr($der, $len) = '';
 845   return undef unless $len >= 1;
 846   $rawmod = $der;
 847   my $bits = length($der) * 8;
 848   # But we have to discount any leading 0 bits in the first byte
 849   my $byte = unpack('C',substr($der,0,1));
 850   if (!$byte) {
 851     $bits -= 8;
 852   }
 853   else {
 854     return undef if $byte & 0x80; # negative modulus is not allowed
 855     while (!($byte & 0x80)) {
 856       --$bits;
 857       $byte <<= 1;
 858     }
 859   }
 860
 861   $der = $derexp;
 862   return undef if unpack('C',substr($der,0,1)) != 0x02;
 863   ($len, $lenbytes) = ReadDERLength(substr($der,1));
 864   substr($der, 0, 1 + $lenbytes) = '';
 865   return undef unless length($der) == $len && $len >= 1;
 866   return undef if unpack('C',substr($der,0,1)) & 0x80; # negative pub exp bad
 867   $rawexp = $der;
 868   my $exp;
 869   if ($len > 8) {
 870     # Fudge the result because it's bigger than a 64-bit number
 871     my $lastbyte = unpack('C',substr($der,-1,1));
 872     $exp = $lastbyte & 0x01 ? 65537 : 65536;
 873   }
 874   else {
 875     $exp = 0;
 876     while (length($der)) {
 877       $exp <<= 8;
 878       $exp |= unpack('C',substr($der,0,1));
 879       substr($der,0,1) = '';
 880     }
 881   }
 882
 883   my $tohash = pack('N',7)."ssh-rsa".pack('N',length($rawexp)).$rawexp
 884     .pack('N',length($rawmod)).$rawmod;
 885
 886   return ($bits,$exp,$id,md5($tohash),sha1($tohash));
 887 }
 888
 889 sub GetCertInfo($)
 890 {
 891   # Input is an X.509 "Certificate" (RFC 5280) in DER format
 892   # Output is an array of:
 893   #   version (1, 2, or 3)
 894   #   serial number (just the serial number data bytes, no header or length)
 895   #   issuer name as a DER "Name"
 896   #   validity start as a DER "Time"
 897   #   validity end as a DER "Time"
 898   #   subject name as a DER "Name"
 899   #   subject public key as a DER "SubjectPublicKeyInfo"
 900   #   subject public key id if v3 Extension SubjectKeyIdentifier is present
 901   #     otherwise undef.  This is just the raw bytes of the key id, no DER
 902   #     header.  (Same format as returned by GetKeyInfo and GetOpenSSHKeyInfo.)
 903   # or undef if the certificate is unparseable
 904
 905   no warnings;
 906   my $der = shift;
 907   my $subjectKeyIdentifier = DEROID('2.5.29.14');
 908   return undef if unpack('C',substr($der,0,1)) != 0x30;
 909   my ($len, $lenbytes) = ReadDERLength(substr($der,1));
 910   return undef unless length($der) == 1 + $lenbytes + $len;
 911   substr($der, 0, 1 + $lenbytes) = '';
 912   return undef if unpack('C',substr($der,0,1)) != 0x30;
 913   ($len, $lenbytes) = ReadDERLength(substr($der,1));
 914   return undef unless length($der) >= 1 + $lenbytes + $len;
 915   substr($der, 0, 1 + $lenbytes) = '';
 916   substr($der, $len) = '';
 917   my $byte = unpack('C',substr($der,0,1));
 918   my $ver = 1;
 919   if ($byte == 0xA0) {
 920     return undef if length($der) < 5 || substr($der,1,3) != pack('H*','030201');
 921     $byte = unpack('C',substr($der,4,1));
 922     # Zero shouldn't be allowed as it's DEFAULT but we'll let it go by
 923     return undef if $byte > 2; # unrecognized version
 924     $ver = $byte + 1;
 925     substr($der,0,5) = '';
 926   }
 927   return undef if unpack('C',substr($der,0,1)) != 0x02;
 928   ($len, $lenbytes) = ReadDERLength(substr($der,1));
 929   return undef unless length($der) > 1+$lenbytes+$len && $len >= 1;
 930   substr($der, 0, 1 + $lenbytes) = '';
 931   my $serial = substr($der, 0, $len);
 932   substr($der, 0, $len) = '';
 933   return undef if unpack('C',substr($der,0,1)) != 0x30; # Alg ID
 934   ($len, $lenbytes) = ReadDERLength(substr($der,1));
 935   return undef unless length($der) > 1+$lenbytes+$len;
 936   substr($der,0,1+$lenbytes+$len) = '';
 937   return undef if unpack('C',substr($der,0,1)) != 0x30; # Issuer
 938   ($len, $lenbytes) = ReadDERLength(substr($der,1));
 939   return undef unless length($der) > 1+$lenbytes+$len;
 940   my $issuer = substr($der, 0, 1 + $lenbytes + $len);
 941   substr($der,0,1+$lenbytes+$len) = '';
 942   return undef if unpack('C',substr($der,0,1)) != 0x30; # Validity
 943   ($len, $lenbytes) = ReadDERLength(substr($der,1));
 944   return undef unless length($der) > 1+$lenbytes+$len;
 945   my $validlen = $len;
 946   substr($der, 0, 1 + $lenbytes) = '';
 947   $byte = unpack('C', substr($der, 0, 1));
 948   return undef unless $byte == 0x17 || $byte == 0x18;
 949   ($len, $lenbytes) = ReadDERLength(substr($der,1));
 950   return undef unless length($der) > 1+$lenbytes+$len;
 951   my $vst = substr($der, 0, 1 + $lenbytes + $len);
 952   substr($der, 0, 1+$lenbytes+$len) = '';
 953   $byte = unpack('C', substr($der, 0, 1));
 954   return undef unless $byte == 0x17 || $byte == 0x18;
 955   ($len, $lenbytes) = ReadDERLength(substr($der,1));
 956   return undef unless length($der) > 1+$lenbytes+$len;
 957   my $vnd = substr($der, 0, 1 + $lenbytes + $len);
 958   substr($der, 0, 1+$lenbytes+$len) = '';
 959   return undef unless $validlen == length($vst) + length($vnd);
 960   return undef if unpack('C',substr($der,0,1)) != 0x30; # Subject
 961   ($len, $lenbytes) = ReadDERLength(substr($der,1));
 962   return undef unless length($der) > 1+$lenbytes+$len;
 963   my $subj = substr($der, 0, 1 + $lenbytes + $len);
 964   substr($der, 0, 1+$lenbytes+$len) = '';
 965   return undef if unpack('C',substr($der,0,1)) != 0x30; # Subject PubKey
 966   ($len, $lenbytes) = ReadDERLength(substr($der,1));
 967   return undef unless length($der) >= 1+$lenbytes+$len;
 968   my $subjkey = substr($der, 0, 1 + $lenbytes + $len);
 969   substr($der, 0, 1+$lenbytes+$len) = '';
 970   return ($ver,$serial,$issuer,$vst,$vnd,$subj,$subjkey,undef)
 971     if !length($der) || $ver < 3;
 972   $byte = unpack('C',substr($der,0,1));
 973   if ($byte == 0x81) {
 974     ($len, $lenbytes) = ReadDERLength(substr($der,1));
 975     return undef unless length($der) >= 1+$lenbytes+$len;
 976     substr($der,0,1+$lenbytes+$len) = '';
 977     $byte = unpack('C',substr($der,0,1));
 978   }
 979   if ($byte == 0x82) {
 980     ($len, $lenbytes) = ReadDERLength(substr($der,1));
 981     return undef unless length($der) >= 1+$lenbytes+$len;
 982     substr($der,0,1+$lenbytes+$len) = '';
 983     $byte = unpack('C',substr($der,0,1));
 984   }
 985   return undef if length($der) && $byte != 0xA3; # exts tag
 986   ($len, $lenbytes) = ReadDERLength(substr($der,1));
 987   return undef unless length($der) == 1+$lenbytes+$len;
 988   my $skid = undef;
 989   substr($der, 0, 1+$lenbytes) = '';
 990   return undef unless unpack('C',substr($der,0,1)) == 0x30; # Extensions
 991   ($len, $lenbytes) = ReadDERLength(substr($der,1));
 992   return undef unless length($der) == 1+$lenbytes+$len;
 993   substr($der, 0, 1+$lenbytes) = '';
 994   while (length($der)) {
 995     return undef unless unpack('C',substr($der,0,1)) == 0x30;
 996     ($len, $lenbytes) = ReadDERLength(substr($der,1));
 997     return undef unless length($der) >= 1+$lenbytes+$len;
 998     substr($der,0,1+$lenbytes) = '';
 999     return undef unless unpack('C',substr($der,0,1)) == 0x06;
1000     if (substr($der,0,length($subjectKeyIdentifier)) ne $subjectKeyIdentifier) {
1001       substr($der,0,$len) = '';
1002       next;
1003     }
1004     substr($der,0,length($subjectKeyIdentifier)) = '';
1005     if (unpack('C',substr($der,0,1)) == 0x01) {
1006       # SHOULDn't really be here, but allow it anyway
1007       return undef unless unpack('C',substr($der,1,1)) == 0x01;
1008       substr($der,0,3) = '';
1009     }
1010     return undef unless unpack('C',substr($der,0,1)) == 0x04;
1011     ($len, $lenbytes) = ReadDERLength(substr($der,1));
1012     return undef unless length($der) >= 1+$lenbytes+$len && $len > 1;
1013     substr($der,0,1+$lenbytes) = '';
1014     return undef unless unpack('C',substr($der,0,1)) == 0x04;
1015     ($len, $lenbytes) = ReadDERLength(substr($der,1));
1016     return undef unless length($der) >= 1+$lenbytes+$len && $len >= 1;
1017     $skid = substr($der,1+$lenbytes,$len);
1018     last;
1019   }
1020   return ($ver,$serial,$issuer,$vst,$vnd,$subj,$subjkey,$skid)
1021 }
1022
1023 sub BreakLine($$)
1024 {
1025   my ($line,$width) = @_;
1026   my @ans = ();
1027   return $line if $width < 1;
1028   while (length($line) > $width) {
1029     push(@ans, substr($line, 0, $width));
1030     substr($line, 0, $width) = '';
1031   }
1032   push(@ans, $line) if length($line);
1033   return @ans;
1034 }
1035
1036 sub tests
1037 {
1038   print STDERR unpack('H*', DEROID('2.100.3')),"\n"; # should be 0603813403
1039   for (my $i=0; $i<16; ++$i) {
1040     print STDERR unpack('H*', RandomID(1)),"\n"; # Hi bit should NOT be set
1041   }
1042 }
1043
1044 sub whirlpool($)
1045 {
1046   my $data = shift;
1047   my $hash;
1048   {
1049     local(*CHLD_OUT, *CHLD_IN);
1050     #open(my $olderr, ">&STDERR") or die "Cannot dup STDERR: $!\n";
1051     #open(STDERR, '>', "/dev/null") or die "Cannot redirect STDERR: $!";
1052     (my $pid = open2(\*CHLD_OUT, \*CHLD_IN, "openssl", "dgst", "-whirlpool",
1053         "-binary"))
1054       or die "Cannot start openssl dgst\n";
1055     print CHLD_IN $data;
1056     close(CHLD_IN);
1057     local $/;
1058     die "Error reading whirlpool digest from openssl dgst\n"
1059       unless !!($hash = <CHLD_OUT>);
1060     waitpid($pid, 0);
1061     close(CHLD_OUT);
1062     #open(STDERR, ">&", $olderr) or die "Cannot dup \$olderr: $!";
1063   }
1064   return $hash;
1065 }
1066
1067 sub GetDigest($)
1068 {
1069   my $dgst = shift;
1070   my $sha1   = DEROID('1.3.14.3.2.26');
1071   my $sha224 = DEROID('2.16.840.1.101.3.4.2.4');
1072   my $sha256 = DEROID('2.16.840.1.101.3.4.2.1');
1073   my $sha384 = DEROID('2.16.840.1.101.3.4.2.2');
1074   my $sha512 = DEROID('2.16.840.1.101.3.4.2.3');
1075   my $whirlpoolAlgorithm = DEROID('1.0.10118.3.0.55');
1076   my $sha1WithRSAEncryption   = DEROID('1.2.840.113549.1.1.5');
1077   my $sha224WithRSAEncryption = DEROID('1.2.840.113549.1.1.14');
1078   my $sha256WithRSAEncryption = DEROID('1.2.840.113549.1.1.11');
1079   my $sha384WithRSAEncryption = DEROID('1.2.840.113549.1.1.12');
1080   my $sha512WithRSAEncryption = DEROID('1.2.840.113549.1.1.13');
1081   my $whirlpoolWithRSAEncryption = DEROID('1.2.840.113549.1.1.15');
1082   return ($sha1, $sha1WithRSAEncryption, \&sha1) if $dgst eq 'sha1';
1083   my $h = undef;
1084   my $oid = undef;
1085   my $func = undef;
1086   for (;;) {
1087     $h=$sha224,$oid=$sha224WithRSAEncryption,$func=\&sha224,last
1088       if $dgst eq 'sha224';
1089     $h=$sha256,$oid=$sha256WithRSAEncryption,$func=\&sha256,last
1090       if $dgst eq 'sha256';
1091     $h=$sha384,$oid=$sha384WithRSAEncryption,$func=\&sha384,last
1092       if $dgst eq 'sha384';
1093     $h=$sha512,$oid=$sha512WithRSAEncryption,$func=\&sha512,last
1094       if $dgst eq 'sha512';
1095     $h=$whirlpoolAlgorithm,$oid=$whirlpoolWithRSAEncryption,
1096       $func=\&whirlpool,last if $dgst eq 'whirlpool';
1097     last;
1098   }
1099   die "Invalid digest ($dgst) must be one of:\n"
1100     . "  sha1 sha224 sha256 sha384 sha512\n" unless $h && $oid;
1101   die "Digest $dgst requires Digest::SHA or Digest::SHA::PurePerl "
1102     . "to be available\n" if !$hasSha2;
1103   return ($h,$oid,$func);
1104 }
1105
1106 sub GetDigestStrength($)
1107 {
1108   return 80 if $_[0] eq 'sha1';
1109   return 112 if $_[0] eq 'sha224';
1110   return 128 if $_[0] eq 'sha256';
1111   return 192 if $_[0] eq 'sha384';
1112   return 256 if $_[0] eq 'sha512';
1113   return 256 if $_[0] eq 'whirlpool';
1114 }
1115
1116 sub GetDigestNameForBits($)
1117 {
1118   return 'sha1' if $_[0] <= 80;
1119   return 'sha224' if $_[0] <= 112;
1120   return 'sha256' if $_[0] <= 128;
1121   return 'sha384' if $_[0] <= 192;
1122   return 'sha512';
1123 }
1124
1125 sub toupper($)
1126 {
1127   my $str = shift;
1128   $str =~ tr/a-z/A-Z/;
1129   return $str;
1130 }
1131
1132 sub tolower($)
1133 {
1134   my $str = shift;
1135   $str =~ tr/A-Z/a-z/;
1136   return $str;
1137 }
1138
1139 sub RSASign($$)
1140 {
1141   my ($data, $keyfile) = @_;
1142   my $sig;
1143   {
1144     local(*CHLD_OUT, *CHLD_IN);
1145     #open(my $olderr, ">&STDERR") or die "Cannot dup STDERR: $!\n";
1146     #open(STDERR, '>', "/dev/null") or die "Cannot redirect STDERR: $!";
1147     (my $pid = open2(\*CHLD_OUT, \*CHLD_IN, "openssl", "rsautl", "-sign",
1148         "-inkey", $keyfile))
1149       or die "Cannot start openssl rsautl\n";
1150     print CHLD_IN $data;
1151     close(CHLD_IN);
1152     local $/;
1153     die "Error reading RSA signature from openssl rsautl\n"
1154       unless !!($sig = <CHLD_OUT>);
1155     waitpid($pid, 0);
1156     close(CHLD_OUT);
1157     #open(STDERR, ">&", $olderr) or die "Cannot dup \$olderr: $!";
1158   }
1159   return $sig;
1160 }
1161
1162 my %rsadsa_known_strengths;
1163 BEGIN {
1164   %rsadsa_known_strengths = (
1165     1024 => 80,
1166     2048 => 112,
1167     3072 => 128,
1168     7680 => 192,
1169     15360 => 256,
1170   );
1171 }
1172
1173 sub compute_rsa_strength($)
1174 {
1175   my $rsadsabits = shift;
1176   return 0 unless $rsadsabits && $rsadsabits > 0;
1177   return ($rsadsa_known_strengths{$rsadsabits},'')
1178     if $rsadsa_known_strengths{$rsadsabits};
1179   my $guess;
1180   if ($rsadsabits < 1024) {
1181     $guess = 80 * sqrt($rsadsabits/1024);
1182   } elsif ($rsadsabits > 15360) {
1183     $guess = 256 * sqrt($rsadsabits/15360);
1184   } else {
1185     $guess = 34.141 + sqrt(34.141*34.141 - 4*0.344*(1554.7-$rsadsabits));
1186     $guess = $guess / (2 * 0.344);
1187   }
1188   $guess = 79 if $rsadsabits < 1024 && $guess >= 80;
1189   $guess = 80 if $rsadsabits > 1024 && $guess < 80;
1190   $guess = 111 if $rsadsabits > 1024 && $rsadsabits < 2048 && $guess >= 112;
1191   $guess = 112 if $rsadsabits > 2048 && $guess < 112;
1192   $guess = 127 if $rsadsabits > 2048 && $rsadsabits < 3072 && $guess >= 128;
1193   $guess = 128 if $rsadsabits > 3072 && $guess < 128;
1194   $guess = 191 if $rsadsabits > 3072 && $rsadsabits < 7680 && $guess >= 192;
1195   $guess = 192 if $rsadsabits > 7680 && $guess < 192;
1196   $guess = 255 if $rsadsabits > 7680 && $rsadsabits < 15360 && $guess >= 256;
1197   $guess = 256 if $rsadsabits > 15360 && $guess < 256;
1198   return (int($guess),1);
1199 }
1200
1201 sub is_ipv4($)
1202 {
1203   my $octet = '(?:\d|[1-9]\d|1\d{2}|2[0-4]\d|25[0-5])';
1204   return $_[0] =~ /^$octet\.$octet\.$octet\.$octet$/o;
1205 }
1206
1207 # 1-8 groups of 1-4 hex digits separated by ':' except that the groups may be
1208 # divided into two and separated by '::' instead and finally the last two
1209 # groups may be specified using IPv4 notation.  No scope allowed.
1210 sub parseipv6($)
1211 {
1212   my $a = shift;
1213   return undef unless $a =~ /^[:0-9a-fA-F.]+$/;
1214   my $two = 0;
1215   my @group1 = ();
1216   my @group2 = ();
1217   if ($a =~ /^(.*)::(.*)$/) {
1218     @group1 = split(/:/, $1) if $1;
1219     @group2 = split(/:/, $2) if $2;
1220     $two = 1;
1221   } else {
1222     @group2 = split(/:/, $a);
1223   }
1224   if (@group2 && is_ipv4($group2[@group2 - 1])) {
1225     my @ipv4 = split(/\./, pop(@group2));
1226     push(@group2, sprintf("%x", ($ipv4[0] << 8) | $ipv4[1]));
1227     push(@group2, sprintf("%x", ($ipv4[2] << 8) | $ipv4[3]));
1228   }
1229   return undef unless @group1 + @group2 >= 1 && @group1 + @group2 <= 8;
1230   return undef if $two && @group1 + @group2 >= 8;
1231   if ($two) {
1232     my $zcomps = 8 - (@group1 + @group2);
1233     for (my $i=0; $i < $zcomps; ++$i) {
1234       push(@group1, 0);
1235     }
1236   }
1237   my $ans = '';
1238   foreach my $comp (@group1,@group2) {
1239     return undef unless $comp =~ /^[0-9a-fA-F]{1,4}$/;
1240     $ans .= pack('n', hex($comp));
1241   }
1242   return $ans;
1243 }
1244
1245 sub parseip($)
1246 {
1247   my $a = shift;
1248   if (is_ipv4($a)) {
1249     return pack('CCCC', split(/\./, $a, 4));
1250   } else {
1251     return parseipv6($a);
1252   }
1253 }
1254
1255 # See these RFCs:
1256 #   RFC 1034 section 3.5
1257 #   RFC 1123 section 2.1
1258 #   RFC 1738 section 3.1
1259 #   RFC 3986 section 3.2.2
1260 sub is_dns_valid($)
1261 {
1262   my $dns = shift;
1263   defined($dns) or $dns = '';
1264   return 0 if $dns eq '' || $dns =~ /\s/;
1265   my @labels = split(/\./, $dns, -1);
1266   # Check each label
1267   my $i = -1;
1268   foreach my $label (@labels) {
1269     ++$i;
1270     return 0 unless length($label) > 0 && length($label) <= 63;
1271     return 0 unless $label =~ /^[A-Za-z0-9](?:[A-Za-z0-9-]*[A-Za-z0-9])?$/ ||
1272                               ($i == 0 && $label eq '*' && @labels > 1);
1273   }
1274   return 0 unless length($dns) <= 255;
1275   return 1;
1276 }
1277
1278 sub handle_dns_opt($$)
1279 {
1280   my $val = shift;
1281   my $altsref = shift;
1282   my $ip = parseip($val);
1283   if (defined($ip)) {
1284     die "Internal error: parsed IP not 4 or 16 bytes long"
1285       unless length($ip) == 4 || length($ip) == 16;
1286     push(@$altsref, [0x87, $ip]);
1287   } else {
1288     $val =~ s/\.$//;
1289     die "Not a valid dns name or IPv4/IPv6 address: $val\n"
1290       unless is_dns_valid($val);
1291     push(@$altsref, [0x82, $val]);
1292   }
1293 }
1294
1295 sub main
1296 {
1297   Make1252(); # Set up the UTF-8 auxiliary conversion table
1298
1299   my $help = '';
1300   my $verbose = '';
1301   my $quiet = '';
1302   my $keyfile = '';
1303   my $certfile = '';
1304   my $useNow = '';
1305   my $useRandom = '';
1306   my $useNoRandom = '';
1307   my $termOK = '';
1308   my $server = '';
1309   my @serverAltNames = ();
1310   my $codesign = '';
1311   my $applecodesign = '';
1312   my $client = '';
1313   my $email = '';
1314   my $subca = '';
1315   my $root = '';
1316   my $rootauth = '';
1317   my $authext = '';
1318   my $digest = $hasSha2 ? 'sha256' : 'sha1';
1319   my $digestChoice = '';
1320   my $debug = 0;
1321   my $pubx509 = '';
1322   my $check = '';
1323   my $pathlen = '';
1324   my $commonName = DEROID('2.5.4.3'); # :commonName
1325   my $serialNumber = DEROID('2.5.4.5'); # :serialNumber
1326   my $userId = DEROID('0.9.2342.19200300.100.1.1'); # :userId
1327   my $emailAddress = DEROID('1.2.840.113549.1.9.1'); # :emailAddress
1328   my $dnQualifier = DEROID('2.5.4.46'); # :dnQualifier
1329   my $basicConstraints = DEROID('2.5.29.19');
1330   my $keyUsage = DEROID('2.5.29.15');
1331   my $extKeyUsage = DEROID('2.5.29.37');
1332   my $serverAuth = DEROID('1.3.6.1.5.5.7.3.1');
1333   my $clientAuth = DEROID('1.3.6.1.5.5.7.3.2');
1334   my $codeSigning = DEROID('1.3.6.1.5.5.7.3.3');
1335   my $emailProtection = DEROID('1.3.6.1.5.5.7.3.4');
1336   my $appleCodeSigning = DEROID('1.2.840.113635.100.4.1');
1337   my $authKeyId = DEROID('2.5.29.35');
1338   my $subjKeyId = DEROID('2.5.29.14');
1339   my $subjAltName = DEROID('2.5.29.17');
1340   my $boolTRUE = pack('C*',0x01,0x01,0xFF);
1341   my $boolFALSE = pack('C*',0x01,0x01,0x00);
1342   my $v3Begin = pack('C',0x17).DERLength(13)."970811000000Z";
1343   my $noExpiry = pack('C',0x18).DERLength(15)."99991231235959Z";
1344   my $infile = '-';
1345   my $outfile = '-';
1346   my @suffixfiles = ();
1347   my $suffix = '';
1348   my $qualifier = undef;
1349
1350   #tests;
1351   eval {GetOptions(
1352       "help|h" => sub{$help=1;die"!FINISH"},
1353       "verbose|v" => \$verbose,
1354       "version|V" => sub{print STDERR $VERSIONMSG;exit(0)},
1355       "debug" => \$debug,
1356       "quiet" => \$quiet,
1357       "pubx509" => \$pubx509,
1358       "pubX509" => \$pubx509,
1359       "check" => \$check,
1360       "now" => \$useNow,
1361       "random" => \$useRandom,
1362       "no-random" => \$useNoRandom,
1363       "t" => \$termOK,
1364       "server" => \$server,
1365       "codesign" => \$codesign,
1366       "applecodesign" => \$applecodesign,
1367       "email" => \$email,
1368       "client" => \$client,
1369       "subca" => \$subca,
1370       "root" => \$root,
1371       "rootauth" => \$rootauth,
1372       "authext" => \$authext,
1373       "digest=s" => \$digestChoice,
1374       "key|k=s" => \$keyfile,
1375       "cert|c=s" => \$certfile,
1376       "pathlen=i" => \$pathlen,
1377       "in=s" => \$infile,
1378       "out=s" => \$outfile,
1379       "suffix=s" => sub{push(@suffixfiles, $_[1]);},
1380       "dnq=s" => \$qualifier,
1381       "dns=s" => sub{handle_dns_opt($_[1], \@serverAltNames);}
1382     )} || $help
1383       or die $USAGE;
1384   if ($help) {
1385     local *MAN;
1386     my $pager = $ENV{'PAGER'} || 'less';
1387     if (-t STDOUT && open(MAN, "|-", $pager)) {
1388       print MAN formatman($HELP,1);
1389       close(MAN);
1390     }
1391     else {
1392       print formatman($HELP);
1393     }
1394     exit(0);
1395   }
1396   die "--in requires a filename\n" if !$root && !$infile;
1397   die "--out requires a filename\n" if !$outfile;
1398   foreach my $suffixfile (@suffixfiles) {
1399     die "--suffix requires a filename\n" if defined($suffixfile) && !$suffixfile;
1400     die "--suffix file '$suffixfile' does not exist or is not readable\n"
1401       if ! -e $suffixfile || ! -r $suffixfile;
1402   }
1403   $client = 1 if
1404     !$root && !$subca && !$server && !$codesign && !$applecodesign && !$email;
1405   $verbose = 1 if $debug || $check;
1406   $quiet = 0 if $verbose || $check;
1407   print STDERR $VERSIONMSG if $verbose;
1408   my $keytype = 'OpenSSH';
1409   my $n = 'n';
1410   $keytype = 'pubx509', $n = '' if $pubx509;
1411   die $USAGE if $root && $useRandom && $useNoRandom;
1412   die $USAGE if !$keyfile || (!$root && !$certfile) || (!$check && @ARGV != 1);
1413   die "Standard input is a tty (which is an unlikely source of a$n $keytype "
1414     . "public key)\n"
1415     . "If that's what you truly meant, add the -t option to allow it.\n"
1416     if !$root && $infile eq '-' && -t STDIN && !$termOK;
1417   $useRandom = 1 if $root && !$useNoRandom;
1418   die "Name may not be empty\n"
1419     unless $check || $ARGV[0] || ($root && $useRandom);
1420   die "Distinguished name qualifier may not be empty string\n"
1421     unless !defined($qualifier) || $qualifier;
1422   die "Invalid distinguished name qualifier (must match [A-Za-z0-9 '()+,./:=?-]+)\n"
1423     unless !$qualifier || $qualifier =~ m|^[A-Za-z0-9 '()+,./:=?-]+$|;
1424   my $opensshdotpub;
1425   my $infilename;
1426   foreach my $suffixfile (@suffixfiles) {
1427     open(SUFFIX, '<', $suffixfile)
1428       or die "Cannot open '$suffixfile' for input: $!\n";
1429     local $/;
1430     $suffix .= <SUFFIX>;
1431     close(SUFFIX);
1432   }
1433   if (!$root) {
1434     local $/ if $pubx509;
1435     my $input;
1436     if ($infile ne '-') {
1437       $infilename = "\"$infile\"";
1438       open($input, '<', $infile)
1439         or die "Cannot open $infilename for input: $!\n";
1440     } else {
1441       $input = *STDIN;
1442       $infilename = 'standard input';
1443     }
1444     !!($opensshdotpub = <$input>)
1445       or die "Cannot read $keytype public key from $infilename\n";
1446     if (!$pubx509) {
1447       my $auto509 = 0;
1448       if ($opensshdotpub =~ /^----[- ]BEGIN PUBLIC KEY[- ]----/) {
1449         $auto509 = 1;
1450       }
1451       else {
1452         my $input = $opensshdotpub;
1453         $input =~ s/((?:\r\n|\n|\r).*)$//os;
1454         my @fields = split(' ', $input, 3);
1455         if (@fields < 2 ||
1456             length($fields[1]) < 16 ||
1457             $fields[1] !~ m|^[0-9A-Za-z+/=]+$|) {
1458           $auto509 = 1;
1459         }
1460       }
1461       if ($auto509) {
1462         $pubx509 = 1;
1463         $keytype = 'pubx509';
1464         print STDERR "auto detected --pubx509 option\n" if $debug;
1465         local $/;
1466         my $extra = <$input>;
1467         $opensshdotpub .= $extra if $extra;
1468       }
1469     }
1470     close($input) if $infile ne '-';
1471   }
1472   die "Cannot read key file $keyfile\n" if ! -r $keyfile;
1473   die "Cannot read certificate file $certfile\n" if !$root && ! -r $certfile;
1474
1475   my ($sshkeybits,$sshkeyexp,$sshkeyid,$sfmd5,$sfsha1,$sshcmnt,$opensshpub);
1476   if ($root) {
1477     # need to set $sshkeyid to $pubkeyid
1478     # need to set $opensshpub to $pubkey
1479     # but don't have either yet, so do it later
1480   }
1481   elsif ($pubx509) {
1482     local (*READKEY, *WRITEKEY);
1483     my $inform = $opensshdotpub =~ m|^[\t\n\r\x20-\x7E]*$|os ? 'PEM' : 'DER';
1484     print STDERR "pubx509 -inform $inform\n" if $debug;
1485     open(my $olderr, ">&STDERR") or die "Cannot dup STDERR: $!\n";
1486     open(STDERR, '>', "/dev/null") or die "Cannot redirect STDERR: $!";
1487     my $pid = open2(\*READKEY, \*WRITEKEY, "openssl", "rsa", "-inform",
1488       $inform, "-pubin", "-outform", "DER", "-pubout");
1489     open(STDERR, ">&", $olderr) or die "Cannot dup \$olderr: $!";
1490     $pid or die "Cannot start openssl rsa\n";
1491     print WRITEKEY $opensshdotpub;
1492     close(WRITEKEY);
1493     local $/;
1494     die "Error reading X.509 format RSA public key from $infilename\n"
1495       unless !!($opensshpub = <READKEY>);
1496     waitpid($pid, 0);
1497     close(READKEY);
1498     $sshcmnt = undef;
1499     ($sshkeybits,$sshkeyexp,$sshkeyid,$sfmd5,$sfsha1) = GetKeyInfo($opensshpub);
1500     die "Unparseable X.509 public key format read from $infilename\n"
1501       unless $sshkeybits;
1502   }
1503   else {
1504     ($sshkeybits,$sshkeyexp,$sshkeyid,$sfmd5,$sfsha1,$sshcmnt,$opensshpub) =
1505       GetOpenSSHKeyInfo($opensshdotpub);
1506     die "Unparseable OpenSSH public key read from $infilename\n"
1507       unless $sshkeybits;
1508     die "Unsupported OpenSSH public key type ($sshkeybits), must be ssh-rsa\n"
1509       unless $sshkeyexp;
1510   }
1511   my $sshkeystrength;
1512   if (!$root) {
1513     my $sshkeyapprox;
1514     ($sshkeystrength, $sshkeyapprox) = compute_rsa_strength($sshkeybits);
1515     printf(STDERR "$keytype Public Key Info:\n".
1516         "  bits=$sshkeybits pubexp=$sshkeyexp secstrenth=%s%s\n",
1517         $sshkeystrength, ($sshkeyapprox ? ' (approximately)' : '')) if $verbose;
1518     print STDERR "  keyid=",
1519       join(":", toupper(unpack("H*",$sshkeyid))=~/../g), "\n" if $verbose;
1520     print STDERR "  fingerprint(md5)=",
1521       join(":", tolower(unpack("H*",$sfmd5))=~/../g), "\n" if $verbose;
1522     print STDERR "  fingerprint(sha1)=",
1523       join(":", tolower(unpack("H*",$sfsha1))=~/../g), "\n" if $verbose;
1524     print STDERR "  comment=",$sshcmnt||'<none present>',"\n"
1525       if $verbose && !$pubx509;
1526     die "*** Error: $keytype key has less than 512 bits ($sshkeybits)\n"
1527       . "***        You might as well just donate your system to hackers now.\n"
1528       if $sshkeybits < 512;
1529     die "*** Error: The $keytype key's public exponent is even ($sshkeyexp)!\n"
1530       if !($sshkeyexp & 0x01);
1531     warn "*** Warning: The $keytype key has less than 2048 bits ($sshkeybits), "
1532       . "continuing anyway\n" if !$quiet && $sshkeybits < 2048;
1533     die "*** Error: The $keytype public key's exponent of $sshkeyexp is "
1534       . "unacceptably weak!\n" if $sshkeyexp < 35; # OpenSSH used 35 until v5.4
1535     warn "*** Warning: The $keytype public key's exponent ($sshkeyexp) is weak "
1536       . "(< 65537), continuing anyway\n" if !$quiet && $sshkeyexp < 65537;
1537   }
1538
1539   my $inform = -T $keyfile ? 'PEM' : 'DER';
1540   print STDERR "keyfile -inform $inform\n" if $debug;
1541   die "Input key does not appear to be in PEM format: $keyfile\n"
1542     unless $inform eq 'PEM';
1543   my $pubkey;
1544   {
1545     local *READKEY;
1546     open(my $olderr, ">&STDERR") or die "Cannot dup STDERR: $!\n";
1547     open(STDERR, '>', "/dev/null") or die "Cannot redirect STDERR: $!";
1548     open(READKEY, "-|", "openssl", "rsa", "-inform", $inform, "-outform", "DER",
1549         "-pubout", "-passin", "pass:", "-in", $keyfile)
1550       or die "Cannot read RSA private key in \"$keyfile\": $!\n";
1551     open(STDERR, ">&", $olderr) or die "Cannot dup \$olderr: $!";
1552     local $/;
1553     die "Error reading RSA private key in \"$keyfile\"\n"
1554       unless !!($pubkey = <READKEY>);
1555     close(READKEY);
1556   }
1557   $opensshpub = $pubkey if $root;
1558   my ($pubkeybits,$pubkeyexp,$pubkeyid,$pfmd5,$pfsha1) = GetKeyInfo($pubkey);
1559   $sshkeyid = $pubkeyid if $root;
1560   die "Unparseable public key format in \"$keyfile\"\n" unless $pubkeybits;
1561   my ($pubkeystrength, $pubkeyapprox) = compute_rsa_strength($pubkeybits);
1562   printf(STDERR "RSA Private Key $keyfile:\n".
1563     "  bits=$pubkeybits pubexp=$pubkeyexp secstrength=%s%s\n",
1564     $pubkeystrength, ($pubkeyapprox?' (approximately)':'')) if $verbose;
1565   print STDERR "  keyid=",
1566     join(":", toupper(unpack("H*",$pubkeyid))=~/../g), "\n" if $verbose;
1567   print STDERR "  fingerprint(md5)=",
1568     join(":", tolower(unpack("H*",$pfmd5))=~/../g), "\n" if $verbose;
1569   print STDERR "  fingerprint(sha1)=",
1570     join(":", tolower(unpack("H*",$pfsha1))=~/../g), "\n" if $verbose;
1571   die "*** Error: Private key has less than 512 bits ($pubkeybits)\n"
1572     . "***        You might as well just donate your system to hackers now.\n"
1573     if $pubkeybits < 512;
1574   die "*** Error: The private key's public exponent is even ($pubkeyexp)!\n"
1575     if !($pubkeyexp & 0x01);
1576   warn "*** Warning: The private key has less than 2048 bits ($pubkeybits), "
1577     . "continuing anyway\n" if !$quiet && $pubkeybits < 2048;
1578   die "*** Error: The private key's public key exponent of $pubkeyexp is "
1579     . "unacceptably weak!\n" if $pubkeyexp < 35; # ssh-keygen used 35 'til v5.4
1580   warn "*** Warning: The private key's public exponent ($pubkeyexp) is weak "
1581     . "(< 65537), continuing anyway\n" if !$quiet && $pubkeyexp < 65537;
1582
1583   my $maxkeystrength = $pubkeystrength;
1584   $maxkeystrength = $sshkeystrength
1585     if $sshkeystrength && $sshkeystrength > $maxkeystrength;
1586   my $digeststrength = GetDigestStrength($digestChoice || $digest);
1587   my $digestsuggest = GetDigestNameForBits($maxkeystrength);
1588   my $digestsuggestbits = GetDigestStrength($digestsuggest);
1589   # Never warn or auto-choose if both keys are <= 1024 bits in length
1590   if ($maxkeystrength > 80) {
1591     if (!$digestChoice) {
1592       if (!$hasSha2 && $digestsuggestbits > $digeststrength) {
1593         warn "*** Warning: automatic digest selection $digestsuggest ".
1594           "support not available\n" unless $quiet;
1595       } else {
1596         $digest = $digestsuggest;
1597       }
1598     }
1599   }
1600   my ($did, $dalg, $dfunc) = GetDigest($digestChoice || $digest);
1601   print STDERR "default digest: $digest\n" if $debug;
1602   if ($digestChoice && $digestsuggestbits > $digeststrength) {
1603     warn "*** Warning: $digestsuggest (or stronger) is recommended for strength ".
1604       "$maxkeystrength keys, continuing anyway\n" unless $quiet;
1605   }
1606   warn "*** Warning: defaulting to sha1 since SHA-2 support not available\n"
1607     if !$quiet && $digest eq 'sha1' && !$digestChoice;
1608   $digest = $digestChoice if $digestChoice;
1609   warn "*** Warning: sha1 use is strongly discouraged, continuing anyway\n"
1610     if !$quiet && $digest eq 'sha1';
1611   warn <<EOT if !$quiet && $digest eq 'whirlpool';
1612 *** Warning: whirlpool use requires an unofficial OID (1.2.840.113549.1.1.15)
1613 ***          be used for whirlpoolWithRSAEncryption.  See the following:
1614 ***          http://openssl.6102.n7.nabble.com/Creating-a-x509-request-with-Whirlpool-td27209.html#message27213
1615 ***          Such certificates are unlikely to work.  So unless you have a
1616 ***          specific application that you know supports the unofficial value
1617 ***          for whirlpoolWithRSAEncryption you should select a different
1618 ***          signing digest.  Continuing anyway.
1619 EOT
1620   print STDERR "Using digest $digest\n" if $verbose;
1621
1622   my ($cver,$cser,$issuer,$vst,$vnd,$subj,$subjkey,$subjkeyid);
1623   if ($root) {
1624     $vst = $v3Begin;
1625     $vnd = $noExpiry;
1626     $subjkeyid = $pubkeyid;
1627   }
1628   else {
1629     $inform = -T $certfile ? 'PEM' : 'DER';
1630     print STDERR "certfile -inform $inform\n" if $debug;
1631     my $signcert;
1632     {
1633       local *READCERT;
1634       #open(my $olderr, ">&STDERR") or die "Cannot dup STDERR: $!\n";
1635       #open(STDERR, '>', "/dev/null") or die "Cannot redirect STDERR: $!";
1636       open(READCERT, "-|", "openssl", "x509", "-inform", $inform, "-outform",
1637           "DER", "-in", $certfile)
1638         or die "Cannot read X.509 certificate in \"$certfile\"\n";
1639       #open(STDERR, ">&", $olderr) or die "Cannot dup \$olderr: $!";
1640       local $/;
1641       die "Error reading X.509 certificate in \"$certfile\"\n"
1642         unless !!($signcert = <READCERT>);
1643       close(READCERT);
1644     }
1645     ($cver,$cser,$issuer,$vst,$vnd,$subj,$subjkey,$subjkeyid) =
1646       GetCertInfo($signcert);
1647     die "Unparseable certificate format in \"$certfile\"\n" unless $cver;
1648     my $dser = $cser;
1649     substr($dser,0,1) = '' if unpack('C',substr($cser,0,1)) == 0x00;
1650     print STDERR "X.509 Certificate $certfile:\n",
1651       "  ver=v$cver serial=", join(":", tolower(unpack("H*",$dser))=~/../g),"\n"
1652       if $verbose;
1653     print STDERR "  notBefore=",DERTimeStr($vst)||'Invalid Time',
1654       " notAfter=",DERTimeStr($vnd)||'Invalid Time',"\n" if $verbose;
1655     #print STDERR "  issuer=",DERNameStr($issuer),"\n" if $verbose;
1656     #print STDERR "  name=",DERNameStr($subj),"\n" if $verbose;
1657     print STDERR "  subj_keyid=", join(":", toupper(
1658       unpack("H*",$subjkeyid))=~/../g), "\n" if defined($subjkeyid) && $verbose;
1659     die "The private key is not the correct one for the certificate:\n".
1660       "  certificate: $certfile\n".
1661       "  private key: $keyfile\n" unless $subjkey eq $pubkey;
1662     if (!defined($subjkeyid)) {
1663       warn "*** Warning: The certificate has no subjectKeyIdentifier, "
1664         . "using RFC 5280 (1)\n";
1665       $subjkeyid = $pubkeyid;
1666     }
1667     warn "*** Warning: subjectKeyIdentifier non-standard, continuing anyway\n"
1668       unless $subjkeyid eq $pubkeyid;
1669     die "*** Error: The $keytype public key is the same as the certificate's "
1670       . "public key.\n"
1671       . "***        They must be different for security reasons.\n"
1672       if $pubkey eq $opensshpub;
1673   }
1674   return 0 if $check;
1675
1676   my $version = pack('CCCCC', 0xA0, 0x03, 0x02, 0x01, 0x02); # v3
1677   my $randval = $useRandom ? RandomID($quiet) : undef;
1678   my $sigAlg = $dalg . pack('CC',0x05,0x00);
1679   $sigAlg = pack('C',0x30).DERLength(length($sigAlg)).$sigAlg;
1680   my $name = MakeUTF8($ARGV[0]);
1681   $name = pack('C',$email?0x16:0x0C).DERLength(length($name)).$name;
1682   $name = ($client ? $userId : ($email ? $emailAddress : $commonName)) . $name;
1683   $name = pack('C',0x30).DERLength(length($name)).$name;
1684   $name = pack('C',0x31).DERLength(length($name)).$name;
1685   if ($root && $useRandom) {
1686     my $serialRDN = join(":", tolower(unpack("H*",$randval))=~/../g);
1687     $serialRDN = pack('C',0x13).DERLength(length($serialRDN)).$serialRDN;
1688     $serialRDN = $serialNumber . $serialRDN;
1689     $serialRDN = pack('C',0x30).DERLength(length($serialRDN)).$serialRDN;
1690     $serialRDN = pack('C',0x31).DERLength(length($serialRDN)).$serialRDN;
1691     $name = $serialRDN . ($ARGV[0] ? $name : '');
1692   }
1693   if ($qualifier) {
1694     my $dnq = $qualifier;
1695     $dnq = pack('C',0x13).DERLength(length($dnq)).$dnq;
1696     $dnq = $dnQualifier . $dnq;
1697     $dnq = pack('C',0x30).DERLength(length($dnq)).$dnq;
1698     $dnq = pack('C',0x31).DERLength(length($dnq)).$dnq;
1699     $name .= $dnq;
1700   }
1701   $name = pack('C',0x30).DERLength(length($name)).$name;
1702   $subj = $name if $root;
1703   my $validity = ($useNow ? DERTime(time()) : $vst).$vnd;
1704   $validity = pack('C',0x30).DERLength(length($validity)).$validity;
1705   my $extCAVal;
1706   if ($subca || $root) {
1707     $extCAVal = $boolTRUE;
1708     if ($subca && $pathlen ne '') {
1709       $extCAVal .= DERInteger($pathlen);
1710     }
1711     $extCAVal = pack('C',0x30).DERLength(length($extCAVal)).$extCAVal;
1712   }
1713   else {
1714     #$extCAVal = pack('C',0x30).DERLength(length($boolFALSE)).$boolFALSE;
1715     $extCAVal = pack('C',0x30).DERLength(0); # do not include DEFAULT value
1716   }
1717   $extCAVal = pack('C',0x04).DERLength(length($extCAVal)).$extCAVal;
1718   $extCAVal = $basicConstraints . $boolTRUE . $extCAVal;
1719   $extCAVal = pack('C',0x30).DERLength(length($extCAVal)).$extCAVal;
1720   my $extKeyBits = 0x80;
1721   $extKeyBits |= 0x06 if $subca || $root;
1722   $extKeyBits |= 0x20 if $server;
1723   $extKeyBits |= 0x60 if $email;
1724   my $extKeySpare = scalar(@{[
1725     unpack("B*", chr((($extKeyBits & ($extKeyBits-1)) ^ $extKeyBits) - 1))
1726     =~ /1/g]});
1727   my $extKeyUse = pack('H*', '04040302').pack('CC',$extKeySpare,$extKeyBits);
1728   $extKeyUse = $keyUsage . $boolTRUE. $extKeyUse;
1729   $extKeyUse = pack('C',0x30).DERLength(length($extKeyUse)).$extKeyUse;
1730   my $extXKeyUse = '';
1731   if ($server || $client || $codesign || $email || $applecodesign) {
1732     $extXKeyUse .= $serverAuth if $server;
1733     $extXKeyUse .= $clientAuth if $client;
1734     $extXKeyUse .= $codeSigning if $codesign;
1735     $extXKeyUse .= $emailProtection if $email;
1736     $extXKeyUse .= $appleCodeSigning if $applecodesign;
1737     $extXKeyUse = pack('C',0x30).DERLength(length($extXKeyUse)).$extXKeyUse;
1738     $extXKeyUse = pack('C',0x04).DERLength(length($extXKeyUse)).$extXKeyUse;
1739     $extXKeyUse = $extKeyUsage . $boolTRUE . $extXKeyUse;
1740     $extXKeyUse = pack('C',0x30).DERLength(length($extXKeyUse)).$extXKeyUse;
1741   }
1742   my $extSubjKey = pack('C',0x04).DERLength(length($sshkeyid)).$sshkeyid;
1743   $extSubjKey = pack('C',0x04).DERLength(length($extSubjKey)).$extSubjKey;
1744   $extSubjKey = $subjKeyId . $extSubjKey;
1745   $extSubjKey = pack('C',0x30).DERLength(length($extSubjKey)).$extSubjKey;
1746   my $extAuthKey = '';
1747   if (!$root || $rootauth) {
1748     $extAuthKey = pack('C',0x80).DERLength(length($pubkeyid)).$pubkeyid;
1749     if (!$root && $authext) {
1750       my $gen = pack('C',0xA4).DERLength(length($issuer)).$issuer;
1751       $extAuthKey .= pack('C',0xA1).DERLength(length($gen)).$gen;
1752       $extAuthKey .= pack('C',0x82).DERLength(length($cser)).$cser;
1753     }
1754     $extAuthKey = pack('C',0x30).DERLength(length($extAuthKey)).$extAuthKey;
1755     $extAuthKey = pack('C',0x04).DERLength(length($extAuthKey)).$extAuthKey;
1756     $extAuthKey = $authKeyId . $extAuthKey;
1757     $extAuthKey = pack('C',0x30).DERLength(length($extAuthKey)).$extAuthKey;
1758   }
1759   my $exts = $extCAVal . $extKeyUse . $extXKeyUse . $extSubjKey . $extAuthKey;
1760   if ($email || ($server && @serverAltNames)) {
1761     my $extSubjAlt;
1762     if ($email) {
1763       $extSubjAlt = MakeUTF8($ARGV[0]);
1764       $extSubjAlt = pack('C',0x81).DERLength(length($extSubjAlt)).$extSubjAlt;
1765     } else {
1766       $extSubjAlt = '';
1767       foreach my $alt (@serverAltNames) {
1768         $extSubjAlt .= pack('C',$$alt[0]).DERLength(length($$alt[1])).$$alt[1];
1769       }
1770     }
1771     $extSubjAlt = pack('C',0x30).DERLength(length($extSubjAlt)).$extSubjAlt;
1772     $extSubjAlt = pack('C',0x04).DERLength(length($extSubjAlt)).$extSubjAlt;
1773     $extSubjAlt = $subjAltName . $extSubjAlt; # not crit unless empty DN
1774     $extSubjAlt = pack('C',0x30).DERLength(length($extSubjAlt)).$extSubjAlt;
1775     $exts .= $extSubjAlt;
1776   }
1777   $exts = pack('C',0x30).DERLength(length($exts)).$exts;
1778   $exts = pack('C',0xA3).DERLength(length($exts)).$exts;
1779   my $serial;
1780   if ($useRandom) {
1781     $serial = pack('C',0x2).DERLength(length($randval)).$randval;
1782   }
1783   else {
1784     my $idtohash = $version.$sigAlg.$subj.$validity.$name.$opensshpub.$exts;
1785     $idtohash = pack('C',0x30).DERLength(length($idtohash)).$idtohash;
1786     my $idhash = sha1($idtohash);
1787     my $byte0 = unpack('C',substr($idhash,0,1));
1788     $byte0 &= 0x7F;
1789     substr($idhash,0,1) = pack('C',$byte0);
1790     $serial = pack('C',0x2).DERLength(length($idhash)).$idhash;
1791   }
1792   my $tbs = $version.$serial.$sigAlg.$subj.$validity.$name.$opensshpub.$exts;
1793   $tbs = pack('C',0x30).DERLength(length($tbs)).$tbs;
1794   my $tbsseq = &$dfunc($tbs);
1795   $tbsseq = pack('C',0x04).DERLength(length($tbsseq)).$tbsseq;
1796   my $algid = $did . pack('CC',0x05,0x00);
1797   $algid = pack('C',0x30).DERLength(length($algid)).$algid;
1798   $tbsseq = $algid . $tbsseq;
1799   $tbsseq = pack('C',0x30).DERLength(length($tbsseq)).$tbsseq;
1800   my $sig = RSASign($tbsseq, $keyfile);
1801   $sig = pack('C',0x03).DERLength(length($sig)+1).pack('C',0x00).$sig;
1802   my $cert = $tbs . $sigAlg . $sig;
1803   $cert = pack('C',0x30).DERLength(length($cert)).$cert;
1804   my $base64 = join("\n", BreakLine(encode_base64($cert, ''), 64))."\n";
1805   my $output;
1806   if ($outfile ne '-') {
1807     open($output, ">", $outfile)
1808       or die "Cannot open \"$outfile\" for output: $!\n";
1809   } else {
1810     $output = *STDOUT;
1811   }
1812   print $output "-----BEGIN CERTIFICATE-----\n",
1813                 $base64,
1814                 "-----END CERTIFICATE-----\n",
1815                 $suffix;
1816   close($output) if $outfile ne '-';
1817   return 0;
1818 }