CACreateCertRoot

   1 #!/usr/bin/env perl
   2
   3 # CACreateCertRoot - Create a Root Certificate Authority
   4 # Copyright (C) 2011 Kyle J. McKay.  All rights reserved.
   5
   6 exit(&main());
   7
   8 use strict;
   9 use warnings;
  10 use bytes;
  11
  12 use MIME::Base64;
  13 use IPC::Open2;
  14 use Digest::MD5 qw(md5 md5_hex md5_base64);
  15 use Getopt::Long qw(:config gnu_getopt);
  16
  17 our $VERSION;
  18 my $VERSIONMSG;
  19 my $HELP;
  20 my $USAGE;
  21
  22 my $hasSha2;
  23
  24 BEGIN {
  25   *VERSION = \'1.1.1';
  26   $VERSIONMSG = "CACreateCertRoot version $VERSION\n" .
  27     "Copyright (C) 2011 Kyle J. McKay.  All rights reserved.\n";
  28 }
  29
  30 BEGIN {
  31   $hasSha2 = 0;
  32
  33   eval {
  34     require Digest::SHA;
  35     Digest::SHA->import(
  36       qw(
  37         sha1 sha1_hex sha1_base64
  38         sha224 sha224_hex sha224_base64
  39         sha256 sha256_hex sha256_base64
  40         sha384 sha384_hex sha384_base64
  41         sha512 sha512_hex sha512_base64
  42       )
  43     ); $hasSha2=1} ||
  44   eval {
  45     require Digest::SHA::PurePerl;
  46     require Digest::SHA1;
  47     Digest::SHA1->import(
  48       qw(
  49         sha1 sha1_hex sha1_base64
  50       )
  51     );
  52     Digest::SHA::PurePerl->import(
  53       qw(
  54         sha224 sha224_hex sha224_base64
  55         sha256 sha256_hex sha256_base64
  56         sha384 sha384_hex sha384_base64
  57         sha512 sha512_hex sha512_base64
  58       )
  59     ); $hasSha2=1} ||
  60   eval {
  61     require Digest::SHA::PurePerl;
  62     Digest::SHA::PurePerl->import(
  63       qw(
  64         sha1 sha1_hex sha1_base64
  65         sha224 sha224_hex sha224_base64
  66         sha256 sha256_hex sha256_base64
  67         sha384 sha384_hex sha384_base64
  68         sha512 sha512_hex sha512_base64
  69       )
  70     ); $hasSha2=1} ||
  71   eval {
  72     require Digest::SHA1;
  73     Digest::SHA1->import(
  74       qw(
  75         sha1 sha1_hex sha1_base64
  76       )
  77     ); 1} ||
  78   die "One of Digest::SHA1 or Digest::SHA or Digest::SHA::PurePerl "
  79     . "must be available\n";
  80
  81   eval {(`openssl version -v 2>/dev/null` || '') =~ /^OpenSSL /} ||
  82     die "OpenSSL (as the openssl command) is not available in the PATH\n";
  83 }
  84
  85 BEGIN {
  86   $USAGE = <<USAGE;
  87 Usage: CACreateCertRoot [-h] [--digest=sha1|sha224|sha256|sha384|sha512]
  88                           [--check] --key key_file "common name" > out_cert.pem
  89 USAGE
  90   $HELP = <<HELP;
  91 NAME
  92        CACreateCertRoot [-h] [--digest=sha1|sha224|sha256|sha384|sha512]
  93                           [--check] --key key_file "common name" > out_cert.pem
  94
  95 DESCRIPTION
  96        CACreateCertRoot creates a new root certificate suitable for signing
  97        and authenticating other certificates as used to connect to SSL/TLS
  98        servers.  Typically the "common name" provided will be the full DNS name
  99        (all lowercase) of the server to which clients connect to.  However, it
 100        can be any string desired as the created certificate is NOT intended to
 101        be usable as a server certificate or client certificate, but ONLY as a
 102        root certificate authority.
 103
 104        The "common name" value is expected to be either Latin-1 or UTF-8.
 105
 106        The key_file must be an RSA private key file in PEM format and
 107        furthermore it must not have a password (both openssl genrsa and
 108        ssh-keygen -t rsa can create these kinds of RSA private key files).  If
 109        a host is running an OpenSSH sshd daemon, then it probably already has a
 110        suitable host private RSA key in either /etc/ssh/ssh_host_rsa_key or
 111        /etc/ssh_host_rsa_key that can be used if desired.
 112
 113        All systems support sha1 digest certificates, but sha1 should really not
 114        be used anymore (NIST recommendation SP 800-131A).  OpenSSL starting
 115        with versions 0.9.8 (released 2005-07-05) supports the SHA-2 family of
 116        hash functions (sha224, sha256, sha384 and sha512) which should be used
 117        instead.
 118
 119        NIST SP 800-131A requires use of an RSA key with 2048 or more bits and
 120        a hash function with 224 or more bits after December 31 2010.
 121
 122        RFC 6194 states sha256 is the most commonly used alternative to sha1
 123        (and will be used by default if a suitable SHA module is available).
 124
 125        Note that NIST SP 800-78-3 requires RSA public key exponents to be
 126        greater than or equal to 65537.  OpenSSH version 5.4 and later generate
 127        RSA keys with a public exponent of 65537 otherwise openssl genrsa can
 128        be used together with ssh-keygen -y to create a suitable OpenSSH key.
 129
 130        There are a few seldom-used options not shown in the usage example
 131        above.  The --now option can be given to set the validity not before
 132        date to the current time rather than the beginning of the X.509v3
 133        standard's approval.  While this option will not create distinct root
 134        certificates for the purposes of certificate chain approval, it will
 135        cause the actual certificate data output by CACreateCertRoot to differ
 136        each time it's run.  The --random option can be given to generate a
 137        random serial number and include it in the certificate name as well as
 138        make it the certificate's serial number.  Using this option will produce
 139        a new, distinct, root certificate each time CACreateCertRoot is run.  If
 140        neither of these two options is used, then for any given pair of RSA
 141        private key and "common name", CACreateCertRoot will always output a
 142        bytewise-identical certificate which means that only the RSA private key
 143        and common name is needed to recreate the certificate at any time.
 144
 145        With the --check option, a new certificate is not output, but all the
 146        validity checks are still run.
 147
 148 TIPS
 149        Display the currently available version of OpenSSL with:
 150
 151            openssl version
 152
 153        Display the currently available version of OpenSSH with:
 154
 155            ssh -V
 156 HELP
 157 }
 158
 159 sub IsUTF8($)
 160 {
 161   # Return 0 if non-UTF-8 sequences present
 162   # Return -1 if no characters > 0x7F found
 163   # Return 1 if valid UTF-8 sequences present
 164   use bytes;
 165   return -1 if $_[0] !~ /[\x80-\xFF]/so;
 166   my $l = length($_[0]);
 167   for (my $i=0; $i<$l; ++$i) {
 168     my $c = ord(substr($_[0],$i,1));
 169     next if $c < 0x80;
 170     return 0 if $c < 0xC0 || $c >= 0xF8;
 171     if ($c <= 0xDF) {
 172       # Need 1 more byte
 173       ++$i;
 174       return 0 if $i >= $l;
 175       my $c2 = ord(substr($_[0],$i,1));
 176       return 0 if $c2 < 0x80 || $c2 > 0xBF;
 177       my $u = (($c & 0x1F) << 6) | ($c2 & 0x3F);
 178       return 0 if $u < 0x80;
 179       next;
 180     }
 181     if ($c <= 0xEF) {
 182       # Need 2 more bytes
 183       $i += 2;
 184       return 0 if $i >= $l;
 185       my $c2 = ord(substr($_[0],$i-1,1));
 186       return 0 if $c2 < 0x80 || $c2 > 0xBF;
 187       my $c3 = ord(substr($_[0],$i,1));
 188       return 0 if $c3 < 0x80 || $c3 > 0xBF;
 189       my $u = (($c & 0x0F) << 12) | (($c2 & 0x3F) << 6) | ($c3 & 0x3F);
 190       return 0 if $u < 0x800 || ($u >= 0xD800 && $u <= 0xDFFFF) || $u >= 0xFFFE;
 191       next;
 192     }
 193     # Need 3 more bytes
 194     $i += 3;
 195     return 0 if $i >= $l;
 196     my $c2 = ord(substr($_[0],$i-2,1));
 197     return 0 if $c2 < 0x80 || $c2 > 0xBF;
 198     my $c3 = ord(substr($_[0],$i-1,1));
 199     return 0 if $c3 < 0x80 || $c3 > 0xBF;
 200     my $c4 = ord(substr($_[0],$i,1));
 201     return 0 if $c4 < 0x80 || $c4 > 0xBF;
 202     my $u = (($c & 0x07) << 18) | (($c2 & 0x3F) << 12) | (($c3 & 0x3F) << 6)
 203                                                                  | ($c4 & 0x3F);
 204     return 0 if $u < 0x10000 || $u >= 0x10FFFE || (($u & 0xFFFF) >= 0xFFFE);
 205   }
 206   return 1;
 207 }
 208
 209 sub Make1252()
 210 {
 211   use bytes;
 212   our %W1252;
 213
 214   # Provide translations for 0x80-0x9F into UTF-8
 215   $W1252{0x80} = pack('H*','E282AC'); # 0x20AC Euro
 216   $W1252{0x82} = pack('H*','E2809A'); # 0X201A Single Low-9 Quote
 217   $W1252{0x83} = pack('H*','C692');   # 0x0192 Latin Small Letter f With Hook
 218   $W1252{0x84} = pack('H*','E2809E'); # 0x201E Double Low-9 Quote
 219   $W1252{0x85} = pack('H*','E280A6'); # 0x2026 Horizontal Ellipsis
 220   $W1252{0x86} = pack('H*','E280A0'); # 0x2020 Dagger
 221   $W1252{0x87} = pack('H*','E280A1'); # 0x2021 Double Dagger
 222   $W1252{0x88} = pack('H*','CB86');   # 0x02C6 Modifier Letter Circumflex Accent
 223   $W1252{0x89} = pack('H*','E28080'); # 0x2030 Per Mille Sign
 224   $W1252{0x8A} = pack('H*','C5A0');   # 0x0160 Latin Capital Letter S With Caron
 225   $W1252{0x8B} = pack('H*','E28089'); # 0x2039 Left Single Angle Quote
 226   $W1252{0x8C} = pack('H*','C592');   # 0x0152 Latin Capital Ligature OE
 227   $W1252{0x8E} = pack('H*','C5BD');   # 0x017D Latin Capital Letter Z With Caron
 228   $W1252{0x91} = pack('H*','E28098'); # 0x2018 Left Single Quote
 229   $W1252{0x92} = pack('H*','E28099'); # 0x2019 Right Single Quote
 230   $W1252{0x93} = pack('H*','E2809C'); # 0x201C Left Double Quote
 231   $W1252{0x94} = pack('H*','E2809D'); # 0x201D Right Double Quote
 232   $W1252{0x95} = pack('H*','E280A2'); # 0x2022 Bullet
 233   $W1252{0x96} = pack('H*','E28093'); # 0x2013 En Dash
 234   $W1252{0x97} = pack('H*','E28094'); # 0x2014 Em Dash
 235   $W1252{0x98} = pack('H*','CB9C');   # 0x02DC Small Tilde
 236   $W1252{0x99} = pack('H*','E284A2'); # 0x2122 Trade Mark Sign
 237   $W1252{0x9A} = pack('H*','C5A1');   # 0x0161 Latin Small Letter s With Caron
 238   $W1252{0x9B} = pack('H*','E2808A'); # 0x203A Right Single Angle Quote
 239   $W1252{0x9C} = pack('H*','C593');   # 0x0153 Latin Small Ligature oe
 240   $W1252{0x9E} = pack('H*','C5BE');   # 0x017E Latin Small Letter z With Caron
 241   $W1252{0x9F} = pack('H*','C5B8');   # 0x0178 Latin Cap Letter Y With Diaeresis
 242 }
 243
 244 sub MakeUTF8($)
 245 {
 246   use bytes;
 247   our %W1252;
 248
 249   return $_[0] if (IsUTF8($_[0]));
 250   my $ans = '';
 251   foreach my $c (unpack('C*',$_[0])) {
 252     if ($c < 0x80) {
 253       $ans .= chr($c);
 254     }
 255     else {
 256       # Ass/u/me we have Latin-1 (ISO-8859-1) but per the HTML 5 draft treat
 257       # it as windows-1252
 258       if ($c >= 0xA0 || !defined($W1252{$c})) {
 259         $ans .= chr(0xC0 | ($c >> 6));
 260         $ans .= chr(0x80 | ($c & 0x3F));
 261       }
 262       else {
 263         $ans .= $W1252{$c};
 264       }
 265     }
 266   }
 267   return $ans;
 268 }
 269
 270 sub formatbold($;$)
 271 {
 272   my $str = shift;
 273   my $fancy = shift || 0;
 274   if ($fancy) {
 275     $str = join('',map($_."\b".$_, split(//,$str)));
 276   }
 277   return $str;
 278 }
 279
 280 sub formatul($;$)
 281 {
 282   my $str = shift;
 283   my $fancy = shift || 0;
 284   if ($fancy) {
 285     $str = join('',map("_\b".$_, split(//,$str)));
 286   }
 287   return $str;
 288 }
 289
 290 sub formatman($;$)
 291 {
 292   my $man = shift;
 293   my $fancy = shift || 0;
 294   my @inlines = split(/\n/, $man, -1);
 295   my @outlines = ();
 296   foreach my $line (@inlines) {
 297     if ($line =~ /^[A-Z]+$/) {
 298       $line = formatbold($line, $fancy);
 299     }
 300     else {
 301       $line =~ s/'''(.+?)'''/formatbold($1,$fancy)/gse;
 302       $line =~ s/''(.+?)''/formatul($1,$fancy)/gse;
 303     }
 304     push (@outlines, $line);
 305   }
 306   my $result = join("\n", @outlines);
 307   $result =~ s/\\\n//gso;
 308   return $result;
 309 }
 310
 311 sub DERLength($)
 312 {
 313   # return a DER encoded length
 314   my $len = shift;
 315   return pack('C',$len) if $len <= 127;
 316   return pack('C2',0x81, $len) if $len <= 255;
 317   return pack('Cn',0x82, $len) if $len <= 65535;
 318   return pack('CCn',0x83, ($len >> 16), $len & 0xFFFF) if $len <= 16777215;
 319   # Silently returns invalid result if $len > 2^32-1
 320   return pack('CN',0x84, $len);
 321 }
 322
 323 sub SingleOID($)
 324 {
 325   # return a single DER encoded OID component
 326   no warnings;
 327   my $num = shift;
 328   $num += 0;
 329   my $result = pack('C', $num & 0x7F);
 330   $num >>= 7;
 331   while ($num) {
 332     $result = pack('C', 0x80 | ($num & 0x7F)) . $result;
 333     $num >>= 7;
 334   }
 335   return $result;
 336 }
 337
 338 sub DEROID($)
 339 {
 340   # return a DER encoded OID complete with leading 0x06 and DER length
 341   # Input is a string of decimal numbers separated by '.' with at least
 342   # two numbers required.
 343   no warnings;
 344   my @ids = split(/[.]/,$_[0]);
 345   push(@ids, 0) while @ids < 2; # return something that's kind of valid
 346   unshift(@ids, shift(@ids) * 40 + shift(@ids)); # combine first two
 347   my $ans = '';
 348   foreach my $num (@ids) {
 349     $ans .= SingleOID($num);
 350   }
 351   return pack('C',0x6).DERLength(length($ans)).$ans;
 352 }
 353
 354 sub DERTime($)
 355 {
 356   my $t = shift; # a time() value
 357   my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($t);
 358   $year += 1900;
 359   ++$mon;
 360   my $tag;
 361   my $tstr;
 362   if (1950 <= $year && $year < 2050) {
 363     # UTCTime
 364     $tag = 0x17;
 365     $tstr = sprintf("%02d%02d%02d%02d%02d%02dZ", $year % 100, $mon, $mday,
 366       $hour, $min, $sec);
 367   }
 368   else {
 369     # GeneralizedTime
 370     $tag = 0x18;
 371     $tstr = sprintf("%04d%02d%02d%02d%02d%02dZ", $year, $mon, $mday,
 372       $hour, $min, $sec);
 373   }
 374   return pack('C',$tag).DERLength(length($tstr)).$tstr;
 375 }
 376
 377 sub RandomID(;$)
 378 {
 379   # return 20 random bytes except that the first byte has its high bit clear
 380   my $suppress = shift || 0;
 381   print STDERR "Generating serial number, please wait...\n" unless $suppress;
 382   open(RANDIN, "<", "/dev/random")
 383     or die "Cannot open /dev/random for input\n";
 384   my $result = '';
 385   for (my $cnt = 0; $cnt < 20; ++$cnt) {
 386     my $byte;
 387     sysread(RANDIN, $byte, 1)
 388       or die "Cannot read from /dev/random\n";
 389     if (!$cnt) {
 390       my $val = unpack('C', $byte);
 391       $val &= 0x7F;
 392       $byte = pack('C', $val);
 393     }
 394     $result .= $byte;
 395   }
 396   close(RANDIN);
 397   print STDERR "...done creating serial number.\n" unless $suppress;
 398   return $result;
 399 }
 400
 401 sub ReadDERLength($)
 402 {
 403   # Input is a DER encoded length with possibly extra trailing bytes
 404   # Output is an array of length and bytes-used-for-encoded-length
 405   my $der = shift;
 406   return undef unless length($der);
 407   my $byte = unpack('C',substr($der,0,1));
 408   return ($byte, 1) if $byte <= 127;
 409   return undef if $byte == 128 || $byte > 128+8; # Fail if greater than 2^64
 410   my $cnt = $byte & 0x7F;
 411   return undef unless length($der) >= $cnt+1; # Fail if not enough bytes
 412   my $val = 0;
 413   for (my $i = 0; $i < $cnt; ++$i) {
 414     $val <<= 8;
 415     $val |= unpack('C',substr($der,$i+1,1));
 416   }
 417   return ($val, $cnt+1);
 418 }
 419
 420 sub GetKeyInfo($)
 421 {
 422   # Input is an RSA PRIVATE KEY in DER format
 423   # Output is an array of:
 424   #   how many bits in the modulus
 425   #   the public exponent
 426   #   the key id
 427   #   the OpenSSH md5 fingerprint
 428   #   the OpenSSH sha1 fingerprint
 429   # or undef if the key is unparseable
 430   #
 431   # Expected format is:
 432   #   SEQUENCE {
 433   #     SEQUENCE {
 434   #       OBJECT IDENTIFIER :rsaEncryption = 1.2.840.113549.1.1.1
 435   #       NULL
 436   #     }
 437   #     BIT STRING (primitive) {
 438   #       0 unused bits
 439   #       SEQUENCE { # this part is the contents of an "RSA PUBLIC KEY" file
 440   #         INTEGER modulus
 441   #         INTEGER publicExponent
 442   #       }
 443   #     }
 444   #   }
 445
 446   no warnings;
 447   my $der = shift;
 448   my $rawmod;
 449   my $rawexp;
 450
 451   return undef if unpack('C',substr($der,0,1)) != 0x30;
 452   my ($len, $lenbytes) = ReadDERLength(substr($der,1));
 453   return undef unless length($der) == 1 + $lenbytes + $len;
 454   substr($der, 0, 1 + $lenbytes) = '';
 455
 456   # the algorithm part always encodes as 30 0d 06092a864886f70d010101 0500
 457   return undef
 458     unless substr($der, 0, 15) = pack('H*',"300d06092a864886f70d0101010500");
 459   substr($der, 0, 15) = '';
 460
 461   return undef if unpack('C',substr($der,0,1)) != 0x03;
 462   ($len, $lenbytes) = ReadDERLength(substr($der,1));
 463   return undef unless length($der) == 1 + $lenbytes + $len && $len >= 1;
 464   return undef unless unpack('C',substr($der, 1 + $lenbytes, 1)) == 0x00;
 465   substr($der, 0, 1 + $lenbytes + 1) = '';
 466
 467   return undef if unpack('C',substr($der,0,1)) != 0x30;
 468   ($len, $lenbytes) = ReadDERLength(substr($der,1));
 469   return undef unless length($der) == 1 + $lenbytes + $len;
 470   my $id = sha1($der); # The id is the sha1 hash of the private key part
 471   substr($der, 0, 1 + $lenbytes) = '';
 472
 473   return undef if unpack('C',substr($der,0,1)) != 0x02;
 474   ($len, $lenbytes) = ReadDERLength(substr($der,1));
 475   substr($der, 0, 1 + $lenbytes) = '';
 476   my $derexp = substr($der, $len);
 477   substr($der, $len) = '';
 478   return undef unless $len >= 1;
 479   $rawmod = $der;
 480   my $bits = length($der) * 8;
 481   # But we have to discount any leading 0 bits in the first byte
 482   my $byte = unpack('C',substr($der,0,1));
 483   if (!$byte) {
 484     $bits -= 8;
 485   }
 486   else {
 487     return undef if $byte & 0x80; # negative modulus is not allowed
 488     while (!($byte & 0x80)) {
 489       --$bits;
 490       $byte <<= 1;
 491     }
 492   }
 493
 494   $der = $derexp;
 495   return undef if unpack('C',substr($der,0,1)) != 0x02;
 496   ($len, $lenbytes) = ReadDERLength(substr($der,1));
 497   substr($der, 0, 1 + $lenbytes) = '';
 498   return undef unless length($der) == $len && $len >= 1;
 499   return undef if unpack('C',substr($der,0,1)) & 0x80; # negative pub exp bad
 500   $rawexp = $der;
 501   my $exp;
 502   if ($len > 8) {
 503     # Fudge the result because it's bigger than a 64-bit number
 504     my $lastbyte = unpack('C',substr($der,-1,1));
 505     $exp = $lastbyte & 0x01 ? 65537 : 65536;
 506   }
 507   else {
 508     $exp = 0;
 509     while (length($der)) {
 510       $exp <<= 8;
 511       $exp |= unpack('C',substr($der,0,1));
 512       substr($der,0,1) = '';
 513     }
 514   }
 515
 516   my $tohash = pack('N',7)."ssh-rsa".pack('N',length($rawexp)).$rawexp
 517     .pack('N',length($rawmod)).$rawmod;
 518
 519   return ($bits,$exp,$id,md5($tohash),sha1($tohash));
 520 }
 521
 522 sub BreakLine($$)
 523 {
 524   my ($line,$width) = @_;
 525   my @ans = ();
 526   return $line if $width < 1;
 527   while (length($line) > $width) {
 528     push(@ans, substr($line, 0, $width));
 529     substr($line, 0, $width) = '';
 530   }
 531   push(@ans, $line) if length($line);
 532   return @ans;
 533 }
 534
 535 sub tests
 536 {
 537   print STDERR unpack('H*', DEROID('2.100.3')),"\n"; # should be 0603813403
 538   for (my $i=0; $i<16; ++$i) {
 539     print STDERR unpack('H*', RandomID(1)),"\n"; # Hi bit should NOT be set
 540   }
 541 }
 542
 543 sub GetDigest($)
 544 {
 545   my $dgst = shift;
 546   my $sha1   = DEROID('1.3.14.3.2.26');
 547   my $sha224 = DEROID('2.16.840.1.101.3.4.2.4');
 548   my $sha256 = DEROID('2.16.840.1.101.3.4.2.1');
 549   my $sha384 = DEROID('2.16.840.1.101.3.4.2.2');
 550   my $sha512 = DEROID('2.16.840.1.101.3.4.2.3');
 551   my $sha1WithRSAEncryption   = DEROID('1.2.840.113549.1.1.5');
 552   my $sha224WithRSAEncryption = DEROID('1.2.840.113549.1.1.14');
 553   my $sha256WithRSAEncryption = DEROID('1.2.840.113549.1.1.11');
 554   my $sha384WithRSAEncryption = DEROID('1.2.840.113549.1.1.12');
 555   my $sha512WithRSAEncryption = DEROID('1.2.840.113549.1.1.13');
 556   return ($sha1, $sha1WithRSAEncryption, \&sha1) if $dgst eq 'sha1';
 557   my $h = undef;
 558   my $oid = undef;
 559   my $func = undef;
 560   for (;;) {
 561     $h=$sha224,$oid=$sha224WithRSAEncryption,$func=\&sha224,last
 562       if $dgst eq 'sha224';
 563     $h=$sha256,$oid=$sha256WithRSAEncryption,$func=\&sha256,last
 564       if $dgst eq 'sha256';
 565     $h=$sha384,$oid=$sha384WithRSAEncryption,$func=\&sha384,last
 566       if $dgst eq 'sha384';
 567     $h=$sha512,$oid=$sha512WithRSAEncryption,$func=\&sha512,last
 568       if $dgst eq 'sha512';
 569     last;
 570   }
 571   die "Invalid digest ($dgst) must be one of:\n"
 572     . "  sha1 sha224 sha256 sha384 sha512\n" unless $h && $oid;
 573   die "Digest $dgst requires Digest::SHA or Digest::SHA::PurePerl "
 574     . "to be available\n" if !$hasSha2;
 575   return ($h,$oid,$func);
 576 }
 577
 578 sub toupper($)
 579 {
 580   my $str = shift;
 581   $str =~ tr/a-z/A-Z/;
 582   return $str;
 583 }
 584
 585 sub tolower($)
 586 {
 587   my $str = shift;
 588   $str =~ tr/A-Z/a-z/;
 589   return $str;
 590 }
 591
 592 sub RSASign($$)
 593 {
 594   my ($data, $keyfile) = @_;
 595   my $sig;
 596   {
 597     local(*CHLD_OUT, *CHLD_IN);
 598     #open(my $olderr, ">&STDERR") or die "Cannot dup STDERR: $!\n";
 599     #open(STDERR, '>', "/dev/null") or die "Cannot redirect STDERR: $!";
 600     (my $pid = open2(\*CHLD_OUT, \*CHLD_IN, "openssl", "rsautl", "-sign",
 601         "-inkey", $keyfile))
 602       or die "Cannot start openssl rsautl\n";
 603     print CHLD_IN $data;
 604     close(CHLD_IN);
 605     local $/;
 606     die "Error reading RSA signature from openssl rsautl\n"
 607       unless !!($sig = <CHLD_OUT>);
 608     waitpid($pid, 0);
 609     close(CHLD_OUT);
 610     #open(STDERR, ">&", $olderr) or die "Cannot dup \$olderr: $!";
 611   }
 612   return $sig;
 613 }
 614
 615 sub main
 616 {
 617   Make1252(); # Set up the UTF-8 auxiliary conversion table
 618
 619   my $help = '';
 620   my $verbose = '';
 621   my $quiet = '';
 622   my $keyfile = '';
 623   my $useNow = '';
 624   my $useRandom = '';
 625   my $digest = $hasSha2 ? 'sha256' : 'sha1';
 626   my $digestChoice = '';
 627   my $debug = 0;
 628   my $check = '';
 629   my $commonName = DEROID('2.5.4.3'); # :commonName
 630   my $serialNumber = DEROID('2.5.4.5'); # :serialNumber
 631   my $basicConstraints = DEROID('2.5.29.19');
 632   my $keyUsage = DEROID('2.5.29.15');
 633   my $authKeyId = DEROID('2.5.29.35');
 634   my $subjKeyId = DEROID('2.5.29.14');
 635   my $boolTRUE = pack('C*',0x01,0x01,0xFF);
 636   my $boolFALSE = pack('C*',0x01,0x01,0x00);
 637   my $v3Begin = pack('C',0x17).DERLength(13)."970811000000Z";
 638   my $noExpiry = pack('C',0x18).DERLength(15)."99991231235959Z";
 639
 640   #tests;
 641   eval {GetOptions(
 642       "help|h" => sub{$help=1;die"!FINISH"},
 643       "verbose|v" => \$verbose,
 644       "version|V" => sub{print STDERR $VERSIONMSG;exit(0)},
 645       "debug" => \$debug,
 646       "quiet" => \$quiet,
 647       "check" => \$check,
 648       "now" => \$useNow,
 649       "random" => \$useRandom,
 650       "digest=s" => \$digestChoice,
 651       "key|k=s" => \$keyfile
 652     )} || $help
 653       or die $USAGE;
 654   if ($help) {
 655     local *MAN;
 656     my $pager = $ENV{'PAGER'} || 'less';
 657     if (-t STDOUT && open(MAN, "|-", $pager)) {
 658       print MAN formatman($HELP,1);
 659       close(MAN);
 660     }
 661     else {
 662       print formatman($HELP);
 663     }
 664     exit(0);
 665   }
 666   $verbose = 1 if $debug || $check;
 667   $quiet = 0 if $verbose || $check;
 668   print STDERR $VERSIONMSG if $verbose;
 669   die $USAGE if !$keyfile || (!$check && @ARGV != 1);
 670   die "Cannot read key file $keyfile\n" if ! -r $keyfile;
 671   my ($did, $dalg, $dfunc) = GetDigest($digestChoice || $digest);
 672   print STDERR "default digest: $digest\n" if $debug;
 673   warn "*** Warning: defaulting to sha1 since sha256 support not available\n"
 674     if !$quiet && $digest eq 'sha1' && !$digestChoice;
 675   $digest = $digestChoice if $digestChoice;
 676   warn "*** Warning: sha1 use is strongly discouraged, continuing anyway\n"
 677     if !$quiet && $digest eq 'sha1';
 678   print STDERR "Using digest $digest\n" if $verbose;
 679   my $inform = -T $keyfile ? 'PEM' : 'DER';
 680   print STDERR "-inform $inform\n" if $debug;
 681   die "Input key does not appear to be in PEM format: $keyfile\n"
 682     unless $inform eq 'PEM';
 683   my $pubkey;
 684   {
 685     local *READKEY;
 686     open(my $olderr, ">&STDERR") or die "Cannot dup STDERR: $!\n";
 687     open(STDERR, '>', "/dev/null") or die "Cannot redirect STDERR: $!";
 688     open(READKEY, "-|", "openssl", "rsa", "-inform", $inform, "-outform", "DER",
 689         "-pubout", "-passin", "pass:", "-in", $keyfile)
 690       or die "Cannot read RSA private key in $keyfile\n";
 691     open(STDERR, ">&", $olderr) or die "Cannot dup \$olderr: $!";
 692     local $/;
 693     die "Error reading RSA private key in $keyfile\n"
 694       unless !!($pubkey = <READKEY>);
 695     close(READKEY);
 696   }
 697   my ($pubkeybits,$pubkeyexp,$pubkeyid,$fmd5,$fsha1) = GetKeyInfo($pubkey);
 698   die "Unparseable public key format in $keyfile\n" unless $pubkeybits;
 699   print STDERR "RSA Private Key $keyfile:\n",
 700     "  bits=$pubkeybits pubexp=$pubkeyexp\n" if $verbose;
 701   print STDERR "  keyid=",
 702     join(":", toupper(unpack("H*",$pubkeyid))=~/../g), "\n" if $verbose;
 703   print STDERR "  fingerprint(md5)=",
 704     join(":", tolower(unpack("H*",$fmd5))=~/../g), "\n" if $verbose;
 705   print STDERR "  fingerprint(sha1)=",
 706     join(":", tolower(unpack("H*",$fsha1))=~/../g), "\n" if $verbose;
 707   die "*** Error: Input key has less than 512 bits ($pubkeybits)\n"
 708     . "***        You might as well just donate your system to hackers now.\n"
 709     if $pubkeybits < 512;
 710   die "*** Error: The public exponent is even ($pubkeyexp)!\n"
 711     if !($pubkeyexp & 0x01);
 712   warn "*** Warning: Input key has less than 2048 bits ($pubkeybits), "
 713     . "continuing anyway\n" if !$quiet && $pubkeybits < 2048;
 714   die "*** Error: The public key exponent of $pubkeyexp is unacceptably weak!\n"
 715     if $pubkeyexp < 35; # OpenSSH ssh-keygen has used 35 until version 5.4
 716   warn "*** Warning: The public exponent ($pubkeyexp) is weak (< 65537), "
 717     . "continuing anyway\n" if !$quiet && $pubkeyexp < 65537;
 718
 719   return 0 if $check;
 720
 721   my $version = pack('CCCCC', 0xA0, 0x03, 0x02, 0x01, 0x02); # v3
 722   my $randval = $useRandom ? RandomID($quiet) : undef;
 723   my $sigAlg = $dalg . pack('CC',0x05,0x00);
 724   $sigAlg = pack('C',0x30).DERLength(length($sigAlg)).$sigAlg;
 725   my $name = MakeUTF8($ARGV[0]);
 726   $name = pack('C',0x0C).DERLength(length($name)).$name; # utf8String
 727   $name = $commonName . $name;
 728   $name = pack('C',0x30).DERLength(length($name)).$name;
 729   $name = pack('C',0x31).DERLength(length($name)).$name;
 730   if ($useRandom) {
 731     my $serialRDN = join(":", tolower(unpack("H*",$randval))=~/../g);
 732     $serialRDN = pack('C',0x13).DERLength(length($serialRDN)).$serialRDN;
 733     $serialRDN = $serialNumber . $serialRDN;
 734     $serialRDN = pack('C',0x30).DERLength(length($serialRDN)).$serialRDN;
 735     $serialRDN = pack('C',0x31).DERLength(length($serialRDN)).$serialRDN;
 736     $name = $serialRDN.$name;
 737   }
 738   $name = pack('C',0x30).DERLength(length($name)).$name;
 739   my $validity = ($useNow ? DERTime(time()) : $v3Begin).$noExpiry;
 740   $validity = pack('C',0x30).DERLength(length($validity)).$validity;
 741   my $extCATrue = pack('C',0x30).DERLength(length($boolTRUE)).$boolTRUE;
 742   $extCATrue = pack('C',0x04).DERLength(length($extCATrue)).$extCATrue;
 743   $extCATrue = $basicConstraints . $boolTRUE . $extCATrue;
 744   $extCATrue = pack('C',0x30).DERLength(length($extCATrue)).$extCATrue;
 745   my $extKeyUse = pack('C*',0x04,0x04,0x03,0x02,0x01,0x06); # OCT BIT 0x060
 746   $extKeyUse = $keyUsage . $boolTRUE. $extKeyUse;
 747   $extKeyUse = pack('C',0x30).DERLength(length($extKeyUse)).$extKeyUse;
 748   my $extSubjKey = pack('C',0x04).DERLength(length($pubkeyid)).$pubkeyid;
 749   $extSubjKey = pack('C',0x04).DERLength(length($extSubjKey)).$extSubjKey;
 750   $extSubjKey = $subjKeyId . $extSubjKey;
 751   $extSubjKey = pack('C',0x30).DERLength(length($extSubjKey)).$extSubjKey;
 752   my $extAuthKey = pack('C',0x80).DERLength(length($pubkeyid)).$pubkeyid;
 753   $extAuthKey = pack('C',0x30).DERLength(length($extAuthKey)).$extAuthKey;
 754   $extAuthKey = pack('C',0x04).DERLength(length($extAuthKey)).$extAuthKey;
 755   $extAuthKey = $authKeyId . $extAuthKey;
 756   $extAuthKey = pack('C',0x30).DERLength(length($extAuthKey)).$extAuthKey;
 757   my $exts = $extCATrue . $extKeyUse . $extSubjKey . $extAuthKey;
 758   $exts = pack('C',0x30).DERLength(length($exts)).$exts;
 759   $exts = pack('C',0xA3).DERLength(length($exts)).$exts;
 760   my $serial;
 761   if ($useRandom) {
 762     $serial = pack('C',0x2).DERLength(length($randval)).$randval;
 763   }
 764   else {
 765     my $idtohash = $version.$sigAlg.$name.$validity.$name.$pubkey.$exts;
 766     $idtohash = pack('C',0x30).DERLength(length($idtohash)).$idtohash;
 767     my $idhash = sha1($idtohash);
 768     my $byte0 = unpack('C',substr($idhash,0,1));
 769     $byte0 &= 0x7F;
 770     substr($idhash,0,1) = pack('C',$byte0);
 771     $serial = pack('C',0x2).DERLength(length($idhash)).$idhash;
 772   }
 773   my $tbs = $version.$serial.$sigAlg.$name.$validity.$name.$pubkey.$exts;
 774   $tbs = pack('C',0x30).DERLength(length($tbs)).$tbs;
 775   my $tbsseq = &$dfunc($tbs);
 776   $tbsseq = pack('C',0x04).DERLength(length($tbsseq)).$tbsseq;
 777   my $algid = $did . pack('CC',0x05,0x00);
 778   $algid = pack('C',0x30).DERLength(length($algid)).$algid;
 779   $tbsseq = $algid . $tbsseq;
 780   $tbsseq = pack('C',0x30).DERLength(length($tbsseq)).$tbsseq;
 781   my $sig = RSASign($tbsseq, $keyfile);
 782   $sig = pack('C',0x03).DERLength(length($sig)+1).pack('C',0x00).$sig;
 783   my $cert = $tbs . $sigAlg . $sig;
 784   $cert = pack('C',0x30).DERLength(length($cert)).$cert;
 785   my $base64 = join("\n", BreakLine(encode_base64($cert, ''), 64))."\n";
 786   print "-----BEGIN CERTIFICATE-----\n",
 787         $base64,
 788         "-----END CERTIFICATE-----\n";
 789   return 0;
 790 }