Crypt/Monkeysphere/MSVA.pm

   1 # Monkeysphere Validation Agent, Perl version
   2 # Copyright © 2010 Daniel Kahn Gillmor <dkg@fifthhorseman.net>,
   3 #                  Jameson Rollins <jrollins@finestructure.net>
   4 #
   5 # This program is free software: you can redistribute it and/or modify
   6 # it under the terms of the GNU General Public License as published by
   7 # the Free Software Foundation, either version 3 of the License, or
   8 # (at your option) any later version.
   9 #
  10 # This program is distributed in the hope that it will be useful,
  11 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 # GNU General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  17
  18 { package Crypt::Monkeysphere::MSVA;
  19
  20   use strict;
  21   use warnings;
  22   use vars qw($VERSION);
  23
  24   use parent qw(HTTP::Server::Simple::CGI);
  25   require Crypt::X509;
  26   use Regexp::Common qw /net/;
  27   use Convert::ASN1;
  28   use MIME::Base64;
  29   use IO::Socket;
  30   use IO::File;
  31   use Socket;
  32   use File::Spec;
  33   use File::HomeDir;
  34   use Config::General;
  35   use Crypt::Monkeysphere::MSVA::MarginalUI;
  36   use Crypt::Monkeysphere::MSVA::Logger;
  37   use Crypt::Monkeysphere::MSVA::Monitor;
  38
  39   use JSON;
  40   use POSIX qw(strftime);
  41   # we need the version of GnuPG::Interface that knows about pubkey_data, etc:
  42   use GnuPG::Interface 0.42.02;
  43
  44   $VERSION = '0.9~pre';
  45
  46   my $gnupg = GnuPG::Interface::->new();
  47   $gnupg->options->quiet(1);
  48   $gnupg->options->batch(1);
  49
  50   my %dispatch = (
  51                   '/' => { handler => \&noop,
  52                            methods => { 'GET' => 1 },
  53                          },
  54                   '/reviewcert' => { handler => \&reviewcert,
  55                                      methods => { 'POST' => 1 },
  56                                    },
  57                   '/extracerts' => { handler => \&extracerts,
  58                                      methods => { 'POST' => 1 },
  59                                    },
  60                  );
  61
  62   my $default_keyserver = 'hkp://pool.sks-keyservers.net';
  63   my $default_keyserver_policy = 'unlessvalid';
  64
  65   my $logger = Crypt::Monkeysphere::MSVA::Logger::->new($ENV{MSVA_LOG_LEVEL});
  66   sub logger {
  67     return $logger;
  68   }
  69
  70   my $rsa_decoder = Convert::ASN1::->new();
  71   $rsa_decoder->prepare(q<
  72
  73    SEQUENCE {
  74         modulus INTEGER,
  75         exponent INTEGER
  76    }
  77           >);
  78
  79   sub net_server {
  80     return 'Net::Server::MSVA';
  81   };
  82
  83   sub msvalog {
  84     return $logger->log(@_);
  85   };
  86
  87   sub new {
  88     my $class = shift;
  89
  90     my $port = 0;
  91     if (exists $ENV{MSVA_PORT} and $ENV{MSVA_PORT} ne '') {
  92       msvalog('debug', "MSVA_PORT set to %s\n", $ENV{MSVA_PORT});
  93       $port = $ENV{MSVA_PORT} + 0;
  94       die sprintf("not a reasonable port %d", $port) if (($port >= 65536) || $port <= 0);
  95     }
  96     # start the server on requested port
  97     my $self = $class->SUPER::new($port);
  98     if (! exists $ENV{MSVA_PORT}) {
  99       # we can't pass port 0 to the constructor because it evaluates
 100       # to false, so HTTP::Server::Simple just uses its internal
 101       # default of 8080.  But if we want to select an arbitrary open
 102       # port, we *can* set it here.
 103       $self->port(0);
 104     }
 105
 106     $self->{allowed_uids} = {};
 107     if (exists $ENV{MSVA_ALLOWED_USERS} and $ENV{MSVA_ALLOWED_USERS} ne '') {
 108       msvalog('verbose', "MSVA_ALLOWED_USERS environment variable is set.\nLimiting access to specified users.\n");
 109       foreach my $user (split(/ +/, $ENV{MSVA_ALLOWED_USERS})) {
 110         my ($name, $passwd, $uid);
 111         if ($user =~ /^[0-9]+$/) {
 112           $uid = $user + 0; # force to integer
 113         } else {
 114           ($name,$passwd,$uid) = getpwnam($user);
 115         }
 116         if (defined $uid) {
 117           msvalog('verbose', "Allowing access from user ID %d\n", $uid);
 118           $self->{allowed_uids}->{$uid} = $user;
 119         } else {
 120           msvalog('error', "Could not find user '%d'; not allowing\n", $user);
 121         }
 122       }
 123     } else {
 124       # default is to allow access only to the current user
 125       $self->{allowed_uids}->{POSIX::getuid()} = 'self';
 126     }
 127
 128     bless ($self, $class);
 129     return $self;
 130   }
 131
 132   sub noop {
 133     my $self = shift;
 134     my $cgi = shift;
 135     return '200 OK', { available => JSON::true,
 136                        protoversion => 1,
 137                      };
 138   }
 139
 140   # return an arrayref of processes which we can detect that have the
 141   # given socket open (the socket is specified with its inode)
 142   sub getpidswithsocketinode {
 143     my $sockid = shift;
 144
 145     if (! defined ($sockid)) {
 146       msvalog('verbose', "No client socket ID to check.  The MSVA is probably not running as a service.\n");
 147       return [];
 148     }
 149     # this appears to be how Linux symlinks open sockets in /proc/*/fd,
 150     # as of at least 2.6.26:
 151     my $socktarget = sprintf('socket:[%d]', $sockid);
 152     my @pids;
 153
 154     my $procfs;
 155     if (opendir($procfs, '/proc')) {
 156       foreach my $pid (grep { /^\d+$/ } readdir($procfs)) {
 157         my $procdir = sprintf('/proc/%d', $pid);
 158         if (-d $procdir) {
 159           my $procfds;
 160           if (opendir($procfds, sprintf('/proc/%d/fd', $pid))) {
 161             foreach my $procfd (grep { /^\d+$/ } readdir($procfds)) {
 162               my $fd = sprintf('/proc/%d/fd/%d', $pid, $procfd);
 163               if (-l $fd) {
 164                 #my ($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($fd);
 165                 my $targ = readlink($fd);
 166                 push @pids, $pid
 167                   if ($targ eq $socktarget);
 168               }
 169             }
 170             closedir($procfds);
 171           }
 172         }
 173       }
 174       closedir($procfs);
 175     }
 176
 177     # FIXME: this whole business is very linux-specific, i think.  i
 178     # wonder how to get this info in other OSes?
 179
 180     return \@pids;
 181   }
 182
 183   # return {uid => X, inode => Y}, meaning the numeric ID of the peer
 184   # on the other end of $socket, "socket inode" identifying the peer's
 185   # open network socket.  each value could be undef if unknown.
 186   sub get_client_info {
 187     my $socket = shift;
 188
 189     my $sock = IO::Socket::->new_from_fd($socket, 'r');
 190     # check SO_PEERCRED -- if this was a TCP socket, Linux
 191     # might not be able to support SO_PEERCRED (even on the loopback),
 192     # though apparently some kernels (Solaris?) are able to.
 193
 194     my $clientid;
 195     my $remotesocketinode;
 196     my $socktype = $sock->sockopt(SO_TYPE) or die "could not get SO_TYPE info";
 197     if (defined $socktype) {
 198       msvalog('debug', "sockopt(SO_TYPE) = %d\n", $socktype);
 199     } else {
 200       msvalog('verbose', "sockopt(SO_TYPE) returned undefined.\n");
 201     }
 202
 203     my $peercred = $sock->sockopt(SO_PEERCRED) or die "could not get SO_PEERCRED info";
 204     my $client = $sock->peername();
 205     my $family = sockaddr_family($client); # should be AF_UNIX (a.k.a. AF_LOCAL) or AF_INET
 206
 207     msvalog('verbose', "socket family: %d\nsocket type: %d\n", $family, $socktype);
 208
 209     if ($peercred) {
 210       # FIXME: on i386 linux, this appears to be three ints, according to
 211       # /usr/include/linux/socket.h.  What about other platforms?
 212       my ($pid, $uid, $gid) = unpack('iii', $peercred);
 213
 214       msvalog('verbose', "SO_PEERCRED: pid: %u, uid: %u, gid: %u\n",
 215               $pid, $uid, $gid,
 216              );
 217       if ($pid != 0 && $uid != 0) { # then we can accept it:
 218         $clientid = $uid;
 219       }
 220       # FIXME: can we get the socket inode as well this way?
 221     }
 222
 223     # another option in Linux would be to parse the contents of
 224     # /proc/net/tcp to find the uid of the peer process based on that
 225     # information.
 226     if (! defined $clientid) {
 227       msvalog('verbose', "SO_PEERCRED failed, digging around in /proc/net/tcp\n");
 228       my $proto;
 229       if ($family == AF_INET) {
 230         $proto = '';
 231       } elsif ($family == AF_INET6) {
 232         $proto = '6';
 233       }
 234       if (defined $proto) {
 235         if ($socktype == &SOCK_STREAM) {
 236           $proto = 'tcp'.$proto;
 237         } elsif ($socktype == &SOCK_DGRAM) {
 238           $proto = 'udp'.$proto;
 239         } else {
 240           undef $proto;
 241         }
 242         if (defined $proto) {
 243           my ($port, $iaddr) = unpack_sockaddr_in($client);
 244           my $iaddrstring = unpack("H*", reverse($iaddr));
 245           msvalog('verbose', "Port: %04x\nAddr: %s\n", $port, $iaddrstring);
 246           my $remmatch = lc(sprintf("%s:%04x", $iaddrstring, $port));
 247           my $infofile = '/proc/net/'.$proto;
 248           my $f = IO::File::->new();
 249           if ( $f->open('< '.$infofile)) {
 250             my @header = split(/ +/, <$f>);
 251             my ($localaddrix, $uidix, $inodeix);
 252             my $ix = 0;
 253             my $skipcount = 0;
 254             while ($ix <= $#header) {
 255               $localaddrix = $ix - $skipcount if (lc($header[$ix]) eq 'local_address');
 256               $uidix = $ix - $skipcount if (lc($header[$ix]) eq 'uid');
 257               $inodeix = $ix - $skipcount if (lc($header[$ix]) eq 'inode');
 258               $skipcount++ if (lc($header[$ix]) eq 'tx_queue') or (lc($header[$ix]) eq 'tr'); # these headers don't actually result in a new column during the data rows
 259               $ix++;
 260             }
 261             if (!defined $localaddrix) {
 262               msvalog('info', "Could not find local_address field in %s; unable to determine peer UID\n",
 263                       $infofile);
 264             } elsif (!defined $uidix) {
 265               msvalog('info', "Could not find uid field in %s; unable to determine peer UID\n",
 266                       $infofile);
 267             } elsif (!defined $inodeix) {
 268               msvalog('info', "Could not find inode field in %s; unable to determine peer network socket inode\n",
 269                       $infofile);
 270             } else {
 271               msvalog('debug', "local_address: %d; uid: %d\n", $localaddrix,$uidix);
 272               while (my @line = split(/ +/,<$f>)) {
 273                 if (lc($line[$localaddrix]) eq $remmatch) {
 274                   if (defined $clientid) {
 275                     msvalog('error', "Warning! found more than one remote uid! (%s and %s\n", $clientid, $line[$uidix]);
 276                   } else {
 277                     $clientid = $line[$uidix];
 278                     $remotesocketinode = $line[$inodeix];
 279                     msvalog('info', "remote peer is uid %d (inode %d)\n",
 280                             $clientid, $remotesocketinode);
 281                   }
 282                 }
 283               }
 284             msvalog('error', "Warning! could not find peer information in %s.  Not verifying.\n", $infofile) unless defined $clientid;
 285             }
 286           } else { # FIXME: we couldn't read the file.  what should we
 287                    # do besides warning?
 288             msvalog('info', "Could not read %s; unable to determine peer UID\n",
 289                     $infofile);
 290           }
 291         }
 292       }
 293     }
 294     return { 'uid' => $clientid,
 295              'inode' => $remotesocketinode };
 296   }
 297
 298   sub handle_request {
 299     my $self = shift;
 300     my $cgi  = shift;
 301
 302     # This is part of a spawned child process.  We don't want the
 303     # child process to destroy the update monitor when it terminates.
 304     $self->{updatemonitor}->forget();
 305     my $clientinfo = get_client_info(select);
 306     my $clientuid = $clientinfo->{uid};
 307
 308     if (defined $clientuid) {
 309       # test that this is an allowed user:
 310       if (exists $self->{allowed_uids}->{$clientuid}) {
 311         msvalog('verbose', "Allowing access from uid %d (%s)\n", $clientuid, $self->{allowed_uids}->{$clientuid});
 312       } else {
 313         msvalog('error', "MSVA client connection from uid %d, forbidden.\n", $clientuid);
 314         printf("HTTP/1.0 403 Forbidden -- peer does not match local user ID\r\nContent-Type: text/plain\r\nDate: %s\r\n\r\nHTTP/1.1 403 Not Found -- peer does not match the local user ID.  Are you sure the agent is running as the same user?\r\n",
 315                strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())),);
 316         return;
 317       }
 318     }
 319
 320     my $path = $cgi->path_info();
 321     my $handler = $dispatch{$path};
 322
 323     if (ref($handler) eq "HASH") {
 324       if (! exists $handler->{methods}->{$cgi->request_method()}) {
 325         printf("HTTP/1.0 405 Method not allowed\r\nAllow: %s\r\nDate: %s\r\n",
 326                join(', ', keys(%{$handler->{methods}})),
 327                strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())));
 328       } elsif (ref($handler->{handler}) ne "CODE") {
 329         printf("HTTP/1.0 500 Server Error\r\nDate: %s\r\n",
 330                strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())));
 331       } else {
 332         my $data = {};
 333         my $ctype = $cgi->content_type();
 334         msvalog('verbose', "Got %s %s (Content-Type: %s)\n", $cgi->request_method(), $path, defined $ctype ? $ctype : '**none supplied**');
 335         if (defined $ctype) {
 336           my @ctypes = split(/; */, $ctype);
 337           $ctype = shift @ctypes;
 338           if ($ctype eq 'application/json') {
 339             $data = from_json($cgi->param('POSTDATA'));
 340           }
 341         };
 342
 343         my ($status, $object) = $handler->{handler}($data, $clientinfo);
 344         if (ref($object) eq 'HASH' &&
 345             ! defined $object->{server}) {
 346           $object->{server} = sprintf("MSVA-Perl %s", $VERSION);
 347         }
 348
 349         my $ret = to_json($object);
 350         msvalog('info', "returning: %s\n", $ret);
 351         printf("HTTP/1.0 %s\r\nDate: %s\r\nContent-Type: application/json\r\n\r\n%s",
 352                $status,
 353                strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())),
 354                $ret);
 355       }
 356     } else {
 357       printf("HTTP/1.0 404 Not Found -- not handled by Monkeysphere validation agent\r\nContent-Type: text/plain\r\nDate: %s\r\n\r\nHTTP/1.0 404 Not Found -- the path:\r\n   %s\r\nis not handled by the MonkeySphere validation agent.\r\nPlease try one of the following paths instead:\r\n\r\n%s\r\n",
 358              strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())),
 359              $path, ' * '.join("\r\n * ", keys %dispatch) );
 360     }
 361   }
 362
 363   sub keycomp {
 364     my $rsakey = shift;
 365     my $gpgkey = shift;
 366
 367     if ($gpgkey->algo_num != 1) {
 368       msvalog('verbose', "Monkeysphere only does RSA keys.  This key is algorithm #%d\n", $gpgkey->algo_num);
 369     } else {
 370       if ($rsakey->{exponent}->bcmp($gpgkey->pubkey_data->[1]) == 0 &&
 371           $rsakey->{modulus}->bcmp($gpgkey->pubkey_data->[0]) == 0) {
 372         return 1;
 373       }
 374     }
 375     return 0;
 376   }
 377
 378   sub get_keyserver_policy {
 379     if (exists $ENV{MSVA_KEYSERVER_POLICY} and $ENV{MSVA_KEYSERVER_POLICY} ne '') {
 380       if ($ENV{MSVA_KEYSERVER_POLICY} =~ /^(always|never|unlessvalid)$/) {
 381         return $1;
 382       }
 383       msvalog('error', "Not a valid MSVA_KEYSERVER_POLICY):\n  %s\n", $ENV{MSVA_KEYSERVER_POLICY});
 384     }
 385     return $default_keyserver_policy;
 386   }
 387
 388   sub get_keyserver {
 389     # We should read from (first hit wins):
 390     # the environment
 391     if (exists $ENV{MSVA_KEYSERVER} and $ENV{MSVA_KEYSERVER} ne '') {
 392       if ($ENV{MSVA_KEYSERVER} =~ /^(((hkps?|hkpms|finger|ldap):\/\/)?$RE{net}{domain})$/) {
 393         return $1;
 394       }
 395       msvalog('error', "Not a valid keyserver (from MSVA_KEYSERVER):\n  %s\n", $ENV{MSVA_KEYSERVER});
 396     }
 397
 398     # FIXME: some msva.conf or monkeysphere.conf file (system and user?)
 399
 400     # or else read from the relevant gnupg.conf:
 401     my $gpghome;
 402     if (exists $ENV{GNUPGHOME} and $ENV{GNUPGHOME} ne '') {
 403       $gpghome = untaint($ENV{GNUPGHOME});
 404     } else {
 405       $gpghome = File::Spec->catfile(File::HomeDir->my_home, '.gnupg');
 406     }
 407     my $gpgconf = File::Spec->catfile($gpghome, 'gpg.conf');
 408     if (-f $gpgconf) {
 409       if (-r $gpgconf) {
 410         my %gpgconfig = Config::General::ParseConfig($gpgconf);
 411         if ($gpgconfig{keyserver} =~ /^(((hkps?|hkpms|finger|ldap):\/\/)?$RE{net}{domain})$/) {
 412           msvalog('debug', "Using keyserver %s from the GnuPG configuration file (%s)\n", $1, $gpgconf);
 413           return $1;
 414         } else {
 415           msvalog('error', "Not a valid keyserver (from gpg config %s):\n  %s\n", $gpgconf, $gpgconfig{keyserver});
 416         }
 417       } else {
 418         msvalog('error', "The GnuPG configuration file (%s) is not readable\n", $gpgconf);
 419       }
 420     } else {
 421       msvalog('info', "Did not find GnuPG configuration file while looking for keyserver '%s'\n", $gpgconf);
 422     }
 423
 424     # the default_keyserver
 425     return $default_keyserver;
 426   }
 427
 428   sub fetch_fpr_from_keyserver {
 429     my $fpr = shift;
 430
 431     my $cmd = IO::Handle::->new();
 432     my $nul = IO::File::->new("< /dev/null");
 433
 434     my $ks = get_keyserver();
 435     msvalog('debug', "start ks query to %s for fingerprint: %s\n", $ks, $fpr);
 436     my $pid = $gnupg->wrap_call
 437       ( handles => GnuPG::Handles::->new( command => $cmd, stdout => $nul, stderr => $nul ),
 438         command_args => [ '0x'.$fpr ],
 439         commands => [ '--keyserver',
 440                       $ks,
 441                       qw( --no-tty --recv-keys ) ]
 442                                         );
 443     # FIXME: can we do something to avoid hanging forever?
 444     waitpid($pid, 0);
 445     msvalog('debug', "ks query returns %d\n", POSIX::WEXITSTATUS($?));
 446   }
 447
 448   sub fetch_uid_from_keyserver {
 449     my $uid = shift;
 450
 451     my $cmd = IO::Handle::->new();
 452     my $out = IO::Handle::->new();
 453     my $nul = IO::File::->new("< /dev/null");
 454
 455     my $ks = get_keyserver();
 456     msvalog('debug', "start ks query to %s for UserID: %s\n", $ks, $uid);
 457     my $pid = $gnupg->wrap_call
 458       ( handles => GnuPG::Handles::->new( command => $cmd, stdout => $out, stderr => $nul ),
 459         command_args => [ '='.$uid ],
 460         commands => [ '--keyserver',
 461                       $ks,
 462                       qw( --no-tty --with-colons --search ) ]
 463       );
 464     while (my $line = $out->getline()) {
 465       msvalog('debug', "from ks query: (%d) %s", $cmd->fileno, $line);
 466       if ($line =~ /^info:(\d+):(\d+)/ ) {
 467         $cmd->print(join(' ', ($1..$2))."\n");
 468         msvalog('debug', 'to ks query: '.join(' ', ($1..$2))."\n");
 469         last;
 470       }
 471     }
 472     # FIXME: can we do something to avoid hanging forever?
 473     waitpid($pid, 0);
 474     msvalog('debug', "ks query returns %d\n", POSIX::WEXITSTATUS($?));
 475   }
 476
 477 ##################################################
 478 ## PKC KEY EXTRACTION ############################
 479
 480   sub pkcextractkey {
 481     my $data = shift;
 482     my $key;
 483
 484     if (lc($data->{pkc}->{type}) eq 'x509der') {
 485       $key = der2key(join('', map(chr, @{$data->{pkc}->{data}})));
 486     } elsif (lc($data->{pkc}->{type}) eq 'x509pem') {
 487       $key = der2key(pem2der($data->{pkc}->{data}));
 488     } elsif (lc($data->{pkc}->{type}) eq 'opensshpubkey') {
 489       $key = opensshpubkey2key($data->{pkc}->{data});
 490     } elsif (lc($data->{pkc}->{type}) eq 'rfc4716') {
 491       $key = rfc47162key($data->{pkc}->{data});
 492     } else {
 493       $key->{error} = sprintf("Don't know this public key carrier type: %s", $data->{pkc}->{type});
 494     }
 495
 496     if (exists $key->{error}) {
 497       return $key;
 498     }
 499
 500     # make sure that the returned integers are Math::BigInts:
 501     $key->{exponent} = Math::BigInt::->new($key->{exponent}) unless (ref($key->{exponent}));
 502     $key->{modulus} = Math::BigInt::->new($key->{modulus}) unless (ref($key->{modulus}));
 503     msvalog('debug', "pubkey info:\nmodulus: %s\nexponent: %s\n",
 504             $key->{modulus}->as_hex(),
 505             $key->{exponent}->as_hex(),
 506            );
 507
 508     if ($key->{modulus}->copy()->blog(2) < 1000) {
 509       $key->{error} = sprintf('Public key size is less than 1000 bits (was: %d bits)', $key->{modulus}->copy()->blog(2));
 510     }
 511
 512     return $key;
 513   }
 514
 515   sub der2key {
 516     my $rawdata = shift;
 517
 518     my $cert = Crypt::X509::->new(cert => $rawdata);
 519
 520     my $key = {error => 'I do not know what happened here'};
 521
 522     if ($cert->error) {
 523       $key->{error} = sprintf("Error decoding X.509 certificate: %s", $cert->error);
 524     } else {
 525       msvalog('verbose', "cert subject: %s\n", $cert->subject_cn());
 526       msvalog('verbose', "cert issuer: %s\n", $cert->issuer_cn());
 527       msvalog('verbose', "cert pubkey algo: %s\n", $cert->PubKeyAlg());
 528       msvalog('verbose', "cert pubkey: %s\n", unpack('H*', $cert->pubkey()));
 529
 530       if ($cert->PubKeyAlg() ne 'RSA') {
 531         $key->{error} = sprintf('public key was algo "%s" (OID %s).  MSVA.pl only supports RSA',
 532                                 $cert->PubKeyAlg(), $cert->pubkey_algorithm);
 533       } else {
 534         msvalog('debug', "decoding ASN.1 pubkey\n");
 535         $key = $rsa_decoder->decode($cert->pubkey());
 536         if (! defined $key) {
 537           msvalog('verbose', "failed to decode %s\n", unpack('H*', $cert->pubkey()));
 538           $key = {error => 'failed to decode the public key'};
 539         }
 540       }
 541     }
 542     return $key;
 543   }
 544
 545   sub pem2der {
 546     my $pem = shift;
 547     my @lines = split(/\n/, $pem);
 548     my @goodlines = ();
 549     my $ready = 0;
 550     foreach my $line (@lines) {
 551       if ($line eq '-----END CERTIFICATE-----') {
 552         last;
 553       } elsif ($ready) {
 554         push @goodlines, $line;
 555       } elsif ($line eq '-----BEGIN CERTIFICATE-----') {
 556         $ready = 1;
 557       }
 558     }
 559     msvalog('debug', "%d lines of base64:\n%s\n", $#goodlines + 1, join("\n", @goodlines));
 560     return decode_base64(join('', @goodlines));
 561   }
 562
 563   sub opensshpubkey2key {
 564     my $data = shift;
 565     # FIXME: do we care that the label matches the type of key?
 566     my ($label, $prop) = split(/ +/, $data);
 567
 568     my $out = parse_rfc4716body($prop);
 569
 570     return $out;
 571   }
 572
 573   sub rfc47162key {
 574     my $data = shift;
 575
 576     my @goodlines;
 577     my $continuation = '';
 578     my $state = 'outside';
 579     foreach my $line (split(/\n/, $data)) {
 580       last if ($state eq 'body' && $line eq '---- END SSH2 PUBLIC KEY ----');
 581       if ($state eq 'outside' && $line eq '---- BEGIN SSH2 PUBLIC KEY ----') {
 582         $state = 'header';
 583         next;
 584       }
 585       if ($state eq 'header') {
 586         $line = $continuation.$line;
 587         $continuation = '';
 588         if ($line =~ /^(.*)\\$/) {
 589           $continuation = $1;
 590           next;
 591         }
 592         if (! ($line =~ /:/)) {
 593           $state = 'body';
 594         }
 595       }
 596       push(@goodlines, $line) if ($state eq 'body');
 597     }
 598
 599     msvalog('debug', "Found %d lines of RFC4716 body:\n%s\n",
 600             scalar(@goodlines),
 601             join("\n", @goodlines));
 602     my $out = parse_rfc4716body(join('', @goodlines));
 603
 604     return $out;
 605   }
 606
 607   sub parse_rfc4716body {
 608     my $data = shift;
 609
 610     return undef
 611       unless defined($data);
 612     $data = decode_base64($data) or return undef;
 613
 614     msvalog('debug', "key properties: %s\n", unpack('H*', $data));
 615     my $out = [ ];
 616     while (length($data) > 4) {
 617       my $size = unpack('N', substr($data, 0, 4));
 618       msvalog('debug', "size: 0x%08x\n", $size);
 619       return undef if (length($data) < $size + 4);
 620       push(@{$out}, substr($data, 4, $size));
 621       $data = substr($data, 4 + $size);
 622     }
 623
 624     if ($out->[0] ne "ssh-rsa") {
 625       return {error => 'Not an RSA key'};
 626     }
 627
 628     if (scalar(@{$out}) != 3) {
 629       return {error => 'Does not contain the right number of bigints for RSA'};
 630     }
 631
 632     return { exponent => Math::BigInt->from_hex('0x'.unpack('H*', $out->[1])),
 633              modulus => Math::BigInt->from_hex('0x'.unpack('H*', $out->[2])),
 634            } ;
 635   }
 636
 637 ## PKC KEY EXTRACTION ############################
 638 ##################################################
 639
 640   sub reviewcert {
 641     my $data  = shift;
 642     my $clientinfo  = shift;
 643     return if !ref $data;
 644
 645     msvalog('verbose', "reviewing data...\n");
 646
 647     my $status = '200 OK';
 648     my $ret =  { valid => JSON::false,
 649                  message => 'Unknown failure',
 650                };
 651
 652     # check context string
 653     if ($data->{context} =~ /^(https|ssh|smtp|ike|postgresql|imaps|imap|submission|email)$/) {
 654         $data->{context} = $1;
 655     } else {
 656         msvalog('error', "invalid context: %s\n", $data->{context});
 657         $ret->{message} = sprintf("Invalid/unknown context: %s", $data->{context});
 658         return $status,$ret;
 659     }
 660     msvalog('verbose', "context: %s\n", $data->{context});
 661
 662     # checkout peer string
 663     # old-style just passed a string as a peer, rather than
 664     # peer: { name: 'whatever', 'type': 'client' }
 665     $data->{peer} = { name => $data->{peer} }
 666       if (ref($data->{peer}) ne 'HASH');
 667
 668     if (defined($data->{peer}->{type})) {
 669       if ($data->{peer}->{type} =~ /^(client|server|peer)$/) {
 670         $data->{peer}->{type} = $1;
 671       } else {
 672         msvalog('error', "invalid peer type string: %s\n", $data->{peer}->{type});
 673         $ret->{message} = sprintf("Invalid peer type string: %s", $data->{peer}->{type});
 674         return $status,$ret;
 675       }
 676     }
 677
 678     my $prefix = $data->{context}.'://';
 679     if ($data->{context} eq 'email' ||
 680        (defined $data->{peer}->{type} &&
 681         $data->{peer}->{type} eq 'client' &&
 682         # ike and smtp clients are effectively other servers, so we'll
 683         # exclude them:
 684         $data->{context} !~ /^(ike|smtp)$/)) {
 685       $prefix = '';
 686       # clients can have any one-line User ID without NULL characters
 687       # and leading or trailing whitespace
 688       if ($data->{peer}->{name} =~ /^([^[:space:]][^\n\0]*[^[:space:]]|[^\0[:space:]])$/) {
 689         $data->{peer}->{name} = $1;
 690       } else {
 691         msvalog('error', "invalid client peer name string: %s\n", $data->{peer}->{name});
 692         $ret->{message} = sprintf("Invalid client peer name string: %s", $data->{peer}->{name});
 693         return $status,$ret;
 694       }
 695     } elsif ($data->{peer}->{name} =~ /^($RE{net}{domain}(:[[:digit:]]+)?)$/) {
 696       $data->{peer}->{name} = $1;
 697     } else {
 698       msvalog('error', "invalid peer name string: %s\n", $data->{peer}->{name});
 699       $ret->{message} = sprintf("Invalid peer name string: %s", $data->{peer}->{name});
 700       return $status,$ret;
 701     }
 702
 703     msvalog('verbose', "peer: %s\n", $data->{peer}->{name});
 704
 705     # generate uid string
 706     my $uid = $prefix.$data->{peer}->{name};
 707     msvalog('verbose', "user ID: %s\n", $uid);
 708
 709     # extract key or openpgp fingerprint from PKC
 710     my $fpr;
 711     my $key;
 712     my $gpgquery;
 713     if (lc($data->{pkc}->{type}) eq 'openpgp4fpr') {
 714       if ($data->{pkc}->{data} =~ /^([[:xdigit:]]+)$/) {
 715         $data->{pkc}->{data} = $1;
 716         $fpr = $data->{pkc}->{data};
 717         msvalog('verbose', "OpenPGP v4 fingerprint: %s\n",$fpr);
 718       } else {
 719         msvalog('error', "invalid OpenPGP v4 fingerprint: %s\n",$data->{pkc}->{data});
 720         $ret->{message} = sprintf("Invalid OpenPGP v4 fingerprint.");
 721         return $status,$ret;
 722       }
 723       $gpgquery = '0x'.$fpr;
 724     } else {
 725       # extract key from PKC
 726       $key = pkcextractkey($data);
 727       if (exists $key->{error}) {
 728         $ret->{message} = $key->{error};
 729         return $status,$ret;
 730       }
 731       $gpgquery = '='.$uid;
 732     }
 733
 734     # setup variables
 735     $ret->{message} = sprintf('Failed to validate "%s" through the OpenPGP Web of Trust.', $uid);
 736     my $lastloop = 0;
 737     my $foundvalid = 0;
 738
 739     # determine keyserver policy
 740     my $kspolicy;
 741     if (defined $data->{keyserverpolicy} &&
 742         $data->{keyserverpolicy} =~ /^(always|never|unlessvalid)$/) {
 743       $kspolicy = $1;
 744       msvalog("verbose", "using requested keyserver policy: %s\n", $1);
 745     } else {
 746       $kspolicy = get_keyserver_policy();
 747     }
 748     msvalog('debug', "keyserver policy: %s\n", $kspolicy);
 749     # needed because $gnupg spawns child processes
 750     $ENV{PATH} = '/usr/local/bin:/usr/bin:/bin';
 751     if ($kspolicy eq 'always') {
 752       if (defined $fpr) {
 753         fetch_fpr_from_keyserver($fpr);
 754       } else {
 755         fetch_uid_from_keyserver($uid);
 756       }
 757       $lastloop = 1;
 758     } elsif ($kspolicy eq 'never') {
 759       $lastloop = 1;
 760     }
 761
 762     # fingerprints of keys that are not fully-valid for this User ID, but match
 763     # the key from the queried certificate:
 764     my @subvalid_key_fprs;
 765
 766     while (1) {
 767       foreach my $gpgkey ($gnupg->get_public_keys($gpgquery)) {
 768         my $validity = '-';
 769         foreach my $tryuid ($gpgkey->user_ids) {
 770           if ($tryuid->as_string eq $uid) {
 771             $validity = $tryuid->validity;
 772           }
 773         }
 774         # treat primary keys just like subkeys:
 775         foreach my $subkey ($gpgkey, @{$gpgkey->subkeys}) {
 776           my $primarymatch;
 777           if (defined $key) {
 778             $primarymatch = keycomp($key, $subkey);
 779           } else {
 780             $primarymatch = 1;
 781           }
 782           if ($primarymatch) {
 783             my $iscapable = 0;
 784             msvalog('verbose', "key 0x%s matches...\n",$subkey->hex_id);
 785             if ($data->{context} eq 'email') {
 786               if ($subkey->usage_flags =~ /s/) {
 787                 $iscapable = 1;
 788                 msvalog('verbose', "...and is signing-capable...\n");
 789               } else {
 790                 msvalog('verbose', "...but is not signing-capable (%s).\n",$subkey->usage_flags);
 791               }
 792             } else {
 793               if ($subkey->usage_flags =~ /a/) {
 794                 $iscapable = 1;
 795                 msvalog('verbose', "...and is authentication-capable...\n");
 796               } else {
 797                 msvalog('verbose', "...but is not authentication-capable (%s).\n",$subkey->usage_flags);
 798               }
 799             }
 800             if ($iscapable) {
 801               if ($validity =~ /^[fu]$/) {
 802                 $foundvalid = 1;
 803                 msvalog('verbose', "...and is fully valid!\n");
 804                 $ret->{valid} = JSON::true;
 805                 $ret->{message} = sprintf('Successfully validated "%s" through the OpenPGP Web of Trust.', $uid);
 806                 last;
 807               } else {
 808                 msvalog('verbose', "...but is not fully valid (%s).\n",$validity);
 809                 push(@subvalid_key_fprs, { fpr => $subkey->fingerprint, val => $validity }) if $lastloop;
 810               }
 811             }
 812           }
 813         }
 814         last if ($foundvalid);
 815       }
 816       if ($lastloop || $foundvalid) {
 817         last;
 818       } else {
 819         if (!$foundvalid) {
 820           if (defined $fpr) {
 821             fetch_fpr_from_keyserver($fpr);
 822           } else {
 823             fetch_uid_from_keyserver($uid);
 824           }
 825         }
 826         $lastloop = 1;
 827       }
 828     }
 829
 830     # only show the marginal UI if the UID of the corresponding
 831     # key is not fully valid.
 832     if (!$foundvalid) {
 833       my $resp = Crypt::Monkeysphere::MSVA::MarginalUI->ask_the_user($gnupg,
 834                                                                      $uid,
 835                                                                      \@subvalid_key_fprs,
 836                                                                      getpidswithsocketinode($clientinfo->{inode}),
 837                                                                      $logger);
 838       msvalog('info', "response: %s\n", $resp);
 839       if ($resp) {
 840         $ret->{valid} = JSON::true;
 841         $ret->{message} = sprintf('Manually validated "%s" through the OpenPGP Web of Trust.', $uid);
 842       }
 843     }
 844
 845     return $status,$ret;
 846   }
 847
 848   sub pre_loop_hook {
 849     my $self = shift;
 850     my $server = shift;
 851
 852     $self->spawn_master_subproc($server);
 853   }
 854
 855   sub master_subprocess_died {
 856     my $self = shift;
 857     my $server = shift;
 858     my $subproc_return = shift;
 859
 860     my $exitstatus = POSIX::WEXITSTATUS($subproc_return);
 861     msvalog('verbose', "Subprocess %d terminated; exiting %d.\n", $self->{child_pid}, $exitstatus);
 862     $server->set_exit_status($exitstatus);
 863     $server->server_close();
 864   }
 865
 866   sub child_dies {
 867     my $self = shift;
 868     my $pid = shift;
 869     my $server = shift;
 870
 871     msvalog('debug', "Subprocess %d terminated.\n", $pid);
 872
 873     if (exists $self->{updatemonitor} &&
 874         defined $self->{updatemonitor}->getchildpid() &&
 875         $self->{updatemonitor}->getchildpid() == $pid) {
 876       my $exitstatus = POSIX::WEXITSTATUS($?);
 877       msvalog('verbose', "Update monitoring process (%d) terminated with code %d.\n", $pid, $exitstatus);
 878       if (0 == $exitstatus) {
 879         msvalog('info', "Reloading MSVA due to update request.\n");
 880         # sending self a SIGHUP:
 881         kill(1, $$);
 882       } else {
 883         msvalog('error', "Update monitoring process (%d) died unexpectedly with code %d.\nNo longer monitoring for updates; please send HUP manually.\n", $pid, $exitstatus);
 884         # it died for some other weird reason; should we respawn it?
 885
 886         # FIXME: i'm worried that re-spawning would create a
 887         # potentially abusive loop, if there are legit, repeatable
 888         # reasons for the failure.
 889
 890 #        $self->{updatemonitor}->spawn();
 891
 892         # instead, we'll just avoid trying to kill the next process with this PID:
 893         $self->{updatemonitor}->forget();
 894       }
 895     } elsif (exists $self->{child_pid} &&
 896              ($self->{child_pid} == 0 ||
 897               $self->{child_pid} == $pid)) {
 898       $self->master_subprocess_died($server, $?);
 899     }
 900   }
 901
 902   # use sparingly!  We want to keep taint mode around for the data we
 903   # get over the network.  this is only here because we want to treat
 904   # the command line arguments differently for the subprocess.
 905   sub untaint {
 906     my $x = shift;
 907     $x =~ /^(.*)$/ ;
 908     return $1;
 909   }
 910
 911   sub post_bind_hook {
 912     my $self = shift;
 913     my $server = shift;
 914
 915     $server->{server}->{leave_children_open_on_hup} = 1;
 916
 917     my $socketcount = @{ $server->{server}->{sock} };
 918     if ( $socketcount != 1 ) {
 919       msvalog('error', "%d sockets open; should have been 1.\n", $socketcount);
 920       $server->set_exit_status(10);
 921       $server->server_close();
 922     }
 923     my $port = @{ $server->{server}->{sock} }[0]->sockport();
 924     if ((! defined $port) || ($port < 1) || ($port >= 65536)) {
 925       msvalog('error', "got nonsense port: %d.\n", $port);
 926       $server->set_exit_status(11);
 927       $server->server_close();
 928     }
 929     if ((exists $ENV{MSVA_PORT}) && (($ENV{MSVA_PORT} + 0) != $port)) {
 930       msvalog('error', "Explicitly requested port %d, but got port: %d.", ($ENV{MSVA_PORT}+0), $port);
 931       $server->set_exit_status(13);
 932       $server->server_close();
 933     }
 934     $self->port($port);
 935     $self->{updatemonitor} = Crypt::Monkeysphere::MSVA::Monitor::->new($logger);
 936   }
 937
 938   sub spawn_master_subproc {
 939     my $self = shift;
 940     my $server = shift;
 941
 942     if ((exists $ENV{MSVA_CHILD_PID}) && ($ENV{MSVA_CHILD_PID} ne '')) {
 943       # this is most likely a re-exec.
 944       msvalog('info', "This appears to be a re-exec, continuing with child pid %d\n", $ENV{MSVA_CHILD_PID});
 945       $self->{child_pid} = $ENV{MSVA_CHILD_PID} + 0;
 946     } elsif ($#ARGV >= 0) {
 947       $self->{child_pid} = 0; # indicate that we are planning to fork.
 948       # avoid ignoring SIGCHLD right before we fork.
 949       $SIG{CHLD} = sub {
 950         my $val;
 951         while (defined($val = POSIX::waitpid(-1, POSIX::WNOHANG)) && $val > 0) {
 952           $self->child_dies($val, $server);
 953         }
 954       };
 955       my $fork = fork();
 956       if (! defined $fork) {
 957         msvalog('error', "could not fork\n");
 958       } else {
 959         if ($fork) {
 960           msvalog('debug', "Child process has PID %d\n", $fork);
 961           $self->{child_pid} = $fork;
 962           $ENV{MSVA_CHILD_PID} = $fork;
 963         } else {
 964           msvalog('verbose', "PID %d executing: \n", $$);
 965           for my $arg (@ARGV) {
 966             msvalog('verbose', " %s\n", $arg);
 967           }
 968           # untaint the environment for the subprocess
 969           # see: https://labs.riseup.net/code/issues/2461
 970           foreach my $e (keys %ENV) {
 971             $ENV{$e} = untaint($ENV{$e});
 972           }
 973           my @args;
 974           foreach (@ARGV) {
 975             push @args, untaint($_);
 976           }
 977           # restore default SIGCHLD handling:
 978           $SIG{CHLD} = 'DEFAULT';
 979           $ENV{MONKEYSPHERE_VALIDATION_AGENT_SOCKET} = sprintf('http://localhost:%d', $self->port);
 980           exec(@args) or exit 111;
 981         }
 982       }
 983     } else {
 984       printf("MONKEYSPHERE_VALIDATION_AGENT_SOCKET=http://localhost:%d;\nexport MONKEYSPHERE_VALIDATION_AGENT_SOCKET;\n", $self->port);
 985       # FIXME: consider daemonizing here to behave more like
 986       # ssh-agent.  maybe avoid backgrounding by setting
 987       # MSVA_NO_BACKGROUND.
 988     };
 989   }
 990
 991   sub extracerts {
 992     my $data = shift;
 993
 994     return '500 not yet implemented', { };
 995   }
 996
 997   1;
 998 }