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