Crypt/Monkeysphere/MSVA.pm

   1 # Monkeysphere Validation Agent, Perl version
   2 # Copyright © 2010 Daniel Kahn Gillmor <dkg@fifthhorseman.net>
   3 #
   4 # This program is free software: you can redistribute it and/or modify
   5 # it under the terms of the GNU General Public License as published by
   6 # the Free Software Foundation, either version 3 of the License, or
   7 # (at your option) any later version.
   8 #
   9 # This program is distributed in the hope that it will be useful,
  10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 # GNU General Public License for more details.
  13 #
  14 # You should have received a copy of the GNU General Public License
  15 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  16
  17 { package Crypt::Monkeysphere::MSVA;
  18
  19   use strict;
  20   use warnings;
  21
  22   BEGIN {
  23     use Exporter   ();
  24     our (@EXPORT_OK,@ISA);
  25     @ISA = qw(Exporter);
  26     @EXPORT_OK = qw( &msvalog );
  27   }
  28   our @EXPORT_OK;
  29
  30   use Crypt::Monkeysphere::MSVA::MarginalUI;
  31   use parent qw(HTTP::Server::Simple::CGI);
  32   require Crypt::X509;
  33   use Regexp::Common qw /net/;
  34   use Convert::ASN1;
  35   use MIME::Base64;
  36   use IO::Socket;
  37   use IO::File;
  38   use Socket;
  39   use File::Spec;
  40   use File::HomeDir;
  41   use Config::General;
  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.42.02;
  47
  48   my $version = '0.1';
  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 = 'hkp://pool.sks-keyservers.net';
  67   my $default_keyserver_policy = 'unlessvalid';
  68
  69 # Net::Server log_level goes from 0 to 4
  70 # this is scaled to match.
  71   my %loglevels = (
  72                    'silent' => 0,
  73                    'quiet' => 0.25,
  74                    'fatal' => 0.5,
  75                    'error' => 1,
  76                    'info' => 2,
  77                    'verbose' => 3,
  78                    'debug' => 4,
  79                    'debug1' => 4,
  80                    'debug2' => 5,
  81                    'debug3' => 6,
  82                   );
  83
  84   my $rsa_decoder = Convert::ASN1->new;
  85   $rsa_decoder->prepare(q<
  86
  87    SEQUENCE {
  88         modulus INTEGER,
  89         exponent INTEGER
  90    }
  91           >);
  92
  93   sub msvalog {
  94     my $msglevel = shift;
  95
  96     my $level = $loglevels{lc($ENV{MSVA_LOG_LEVEL})};
  97     $level = $loglevels{error} if (! defined $level);
  98
  99     if ($loglevels{lc($msglevel)} <= $level) {
 100       printf STDERR @_;
 101     }
 102   };
 103
 104   sub get_log_level {
 105     my $level = $loglevels{lc($ENV{MSVA_LOG_LEVEL})};
 106     $level = $loglevels{error} if (! defined $level);
 107     return $level;
 108   }
 109
 110   sub net_server {
 111     return 'Net::Server::MSVA';
 112   };
 113
 114   sub new {
 115     my $class = shift;
 116
 117     my $port = 0;
 118     if (exists $ENV{MSVA_PORT}) {
 119       $port = $ENV{MSVA_PORT} + 0;
 120       die sprintf("not a reasonable port %d", $port) if (($port >= 65536) || $port <= 0);
 121     }
 122     # start the server on requested port
 123     my $self = $class->SUPER::new($port);
 124     if (! exists $ENV{MSVA_PORT}) {
 125       # we can't pass port 0 to the constructor because it evaluates
 126       # to false, so HTTP::Server::Simple just uses its internal
 127       # default of 8080.  But if we want to select an arbitrary open
 128       # port, we *can* set it here.
 129       $self->port(0);
 130     }
 131
 132     $self->{allowed_uids} = {};
 133     if (exists $ENV{MSVA_ALLOWED_USERS}) {
 134       msvalog('verbose', "MSVA_ALLOWED_USERS environment variable is set.\nLimiting access to specified users.\n");
 135       foreach my $user (split(/ +/, $ENV{MSVA_ALLOWED_USERS})) {
 136         my ($name, $passwd, $uid);
 137         if ($user =~ /^[0-9]+$/) {
 138           $uid = $user + 0; # force to integer
 139         } else {
 140           ($name,$passwd,$uid) = getpwnam($user);
 141         }
 142         if (defined $uid) {
 143           msvalog('verbose', "Allowing access from user ID %d\n", $uid);
 144           $self->{allowed_uids}->{$uid} = $user;
 145         } else {
 146           msvalog('error', "Could not find user '%d'; not allowing\n", $user);
 147         }
 148       }
 149     } else {
 150       # default is to allow access only to the current user
 151       $self->{allowed_uids}->{POSIX::getuid()} = 'self';
 152     }
 153
 154     bless ($self, $class);
 155     return $self;
 156   }
 157
 158   sub noop {
 159     my $self = shift;
 160     my $cgi = shift;
 161     return '200 OK', { available => JSON::true,
 162                        protoversion => 1,
 163                        server => "MSVA-Perl ".$version };
 164   }
 165
 166   # returns an empty list if bad key found.
 167   sub parse_openssh_pubkey {
 168     my $data = shift;
 169     my ($label, $prop) = split(/ +/, $data);
 170     $prop = decode_base64($prop) or return ();
 171
 172     msvalog('debug', "key properties: %s\n", unpack('H*', $prop));
 173     my @out;
 174     while (length($prop) > 4) {
 175       my $size = unpack('N', substr($prop, 0, 4));
 176       msvalog('debug', "size: 0x%08x\n", $size);
 177       return () if (length($prop) < $size + 4);
 178       push(@out, substr($prop, 4, $size));
 179       $prop = substr($prop, 4 + $size);
 180     }
 181     return () if ($label ne $out[0]);
 182     return @out;
 183   }
 184
 185   # return the numeric ID of the peer on the other end of $socket,
 186   # returning undef if unknown.
 187   sub get_remote_peer_id {
 188     my $socket = shift;
 189
 190     my $sock = IO::Socket->new_from_fd($socket, 'r');
 191     # check SO_PEERCRED -- if this was a TCP socket, Linux
 192     # might not be able to support SO_PEERCRED (even on the loopback),
 193     # though apparently some kernels (Solaris?) are able to.
 194
 195     my $remotepeerid;
 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 $remotepeer = $sock->peername();
 205     my $family = sockaddr_family($remotepeer); # 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         $remotepeerid = $uid;
 219       }
 220     }
 221
 222     # another option in Linux would be to parse the contents of
 223     # /proc/net/tcp to find the uid of the peer process based on that
 224     # information.
 225     if (! defined $remotepeerid) {
 226       my $proto;
 227       if ($family == AF_INET) {
 228         $proto = '';
 229       } elsif ($family == AF_INET6) {
 230         $proto = '6';
 231       }
 232       if (defined $proto) {
 233         if ($socktype == &SOCK_STREAM) {
 234           $proto = 'tcp'.$proto;
 235         } elsif ($socktype == &SOCK_DGRAM) {
 236           $proto = 'udp'.$proto;
 237         } else {
 238           undef $proto;
 239         }
 240         if (defined $proto) {
 241           my ($port, $iaddr) = unpack_sockaddr_in($remotepeer);
 242           my $iaddrstring = unpack("H*", reverse($iaddr));
 243           msvalog('verbose', "Port: %04x\nAddr: %s\n", $port, $iaddrstring);
 244           my $remmatch = lc(sprintf("%s:%04x", $iaddrstring, $port));
 245           my $infofile = '/proc/net/'.$proto;
 246           my $f = new IO::File;
 247           if ( $f->open('< '.$infofile)) {
 248             my @header = split(/ +/, <$f>);
 249             my ($localaddrix, $uidix);
 250             my $ix = 0;
 251             my $skipcount = 0;
 252             while ($ix <= $#header) {
 253               $localaddrix = $ix - $skipcount if (lc($header[$ix]) eq 'local_address');
 254               $uidix = $ix - $skipcount if (lc($header[$ix]) eq 'uid');
 255               $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
 256               $ix++;
 257             }
 258             if (!defined $localaddrix) {
 259               msvalog('info', "Could not find local_address field in %s; unable to determine peer UID\n",
 260                       $infofile);
 261             } elsif (!defined $uidix) {
 262               msvalog('info', "Could not find uid field in %s; unable to determine peer UID\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 $remotepeerid) {
 269                     msvalog('error', "Warning! found more than one remote uid! (%s and %s\n", $remotepeerid, $line[$uidix]);
 270                   } else {
 271                     $remotepeerid = $line[$uidix];
 272                     msvalog('info', "remote peer is uid %d\n",
 273                             $remotepeerid);
 274                   }
 275                 }
 276               }
 277             msvalog('error', "Warning! could not find peer information in %s.  Not verifying.\n", $infofile) unless defined $remotepeerid;
 278             }
 279           } else { # FIXME: we couldn't read the file.  what should we
 280                    # do besides warning?
 281             msvalog('info', "Could not read %s; unable to determine peer UID\n",
 282                     $infofile);
 283           }
 284         }
 285       }
 286     }
 287     return $remotepeerid;
 288   }
 289
 290   sub handle_request {
 291     my $self = shift;
 292     my $cgi  = shift;
 293
 294     my $remotepeerid =  get_remote_peer_id(select);
 295
 296     if (defined $remotepeerid) {
 297       # test that this is an allowed user:
 298       if (exists $self->{allowed_uids}->{$remotepeerid}) {
 299         msvalog('verbose', "Allowing access from uid %d (%s)\n", $remotepeerid, $self->{allowed_uids}->{$remotepeerid});
 300       } else {
 301         msvalog('error', "MSVA client connection from uid %d, forbidden.\n", $remotepeerid);
 302         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",
 303                strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())),);
 304         return;
 305       }
 306     }
 307
 308     my $path = $cgi->path_info();
 309     my $handler = $dispatch{$path};
 310
 311     if (ref($handler) eq "HASH") {
 312       if (! exists $handler->{methods}->{$cgi->request_method()}) {
 313         printf("HTTP/1.0 405 Method not allowed\r\nAllow: %s\r\nDate: %s\r\n",
 314                join(', ', keys(%{$handler->{methods}})),
 315                strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())));
 316       } elsif (ref($handler->{handler}) ne "CODE") {
 317         printf("HTTP/1.0 500 Server Error\r\nDate: %s\r\n",
 318                strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())));
 319       } else {
 320         my $data = {};
 321         my $ctype = $cgi->content_type();
 322         msvalog('verbose', "Got %s %s (Content-Type: %s)\n", $cgi->request_method(), $path, defined $ctype ? $ctype : '**none supplied**');
 323         if (defined $ctype) {
 324           my @ctypes = split(/; */, $ctype);
 325           $ctype = shift @ctypes;
 326           if ($ctype eq 'application/json') {
 327             $data = from_json($cgi->param('POSTDATA'));
 328           }
 329         };
 330
 331         my ($status, $object) = $handler->{handler}($data);
 332         my $ret = to_json($object);
 333         msvalog('info', "returning: %s\n", $ret);
 334         printf("HTTP/1.0 %s\r\nDate: %s\r\nContent-Type: application/json\r\n\r\n%s",
 335                $status,
 336                strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())),
 337                $ret);
 338       }
 339     } else {
 340       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",
 341              strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())),
 342              $path, ' * '.join("\r\n * ", keys %dispatch) );
 343     }
 344   }
 345
 346   sub keycomp {
 347     my $rsakey = shift;
 348     my $gpgkey = shift;
 349
 350     if ($gpgkey->algo_num != 1) {
 351       msvalog('verbose', "Monkeysphere only does RSA keys.  This key is algorithm #%d\n", $gpgkey->algo_num);
 352     } else {
 353       if ($rsakey->{exponent}->bcmp($gpgkey->pubkey_data->[1]) == 0 &&
 354           $rsakey->{modulus}->bcmp($gpgkey->pubkey_data->[0]) == 0) {
 355         return 1;
 356       }
 357     }
 358     return 0;
 359   }
 360
 361   sub getuid {
 362     my $data = shift;
 363     if ($data->{context} =~ /^(https|ssh)$/) {
 364       $data->{context} = $1;
 365       if ($data->{peer} =~ /^($RE{net}{domain})$/) {
 366         $data->{peer} = $1;
 367         return $data->{context}.'://'.$data->{peer};
 368       }
 369     }
 370   }
 371
 372   sub get_keyserver_policy {
 373     if (exists $ENV{MSVA_KEYSERVER_POLICY} and $ENV{MSVA_KEYSERVER_POLICY} ne '') {
 374       if ($ENV{MSVA_KEYSERVER_POLICY} =~ /^(always|never|unlessvalid)$/) {
 375         return $1;
 376       }
 377       msvalog('error', "Not a valid MSVA_KEYSERVER_POLICY):\n  %s\n", $ENV{MSVA_KEYSERVER_POLICY});
 378     }
 379     return $default_keyserver_policy;
 380   }
 381
 382   sub get_keyserver {
 383     # We should read from (first hit wins):
 384     # the environment
 385     if (exists $ENV{MSVA_KEYSERVER} and $ENV{MSVA_KEYSERVER} ne '') {
 386       if ($ENV{MSVA_KEYSERVER} =~ /^(((hkps?|finger|ldap):\/\/)?$RE{net}{domain})$/) {
 387         return $1;
 388       }
 389       msvalog('error', "Not a valid keyserver (from MSVA_KEYSERVER):\n  %s\n", $ENV{MSVA_KEYSERVER});
 390     }
 391
 392     # FIXME: some msva.conf file (system and user?)
 393
 394     # or else read from the relevant gnupg.conf:
 395     my $gpghome;
 396     if (exists $ENV{GNUPGHOME} and $ENV{GNUPGHOME} ne '') {
 397       $gpghome = untaint($ENV{GNUPGHOME});
 398     } else {
 399       $gpghome = File::Spec->catfile(File::HomeDir->my_home, '.gnupg');
 400     }
 401     my $gpgconf = File::Spec->catfile($gpghome, 'gpg.conf');
 402     if (-f $gpgconf) {
 403       if (-r $gpgconf) {
 404         my %gpgconfig = Config::General::ParseConfig($gpgconf);
 405         if ($gpgconfig{keyserver} =~ /^(((hkps?|finger|ldap):\/\/)?$RE{net}{domain})$/) {
 406           msvalog('debug', "Using keyserver %s from the GnuPG configuration file (%s)\n", $1, $gpgconf);
 407           return $1;
 408         } else {
 409           msvalog('error', "Not a valid keyserver (from gpg config %s):\n  %s\n", $gpgconf, $gpgconfig{keyserver});
 410         }
 411       } else {
 412         msvalog('error', "The GnuPG configuration file (%s) is not readable\n", $gpgconf);
 413       }
 414     } else {
 415       msvalog('info', "Did not find GnuPG configuration file while looking for keyserver '%s'\n", $gpgconf);
 416     }
 417
 418     # the default_keyserver
 419     return $default_keyserver;
 420   }
 421
 422   sub fetch_uid_from_keyserver {
 423     my $uid = shift;
 424
 425     my $cmd = IO::Handle->new();
 426     my $out = IO::Handle->new();
 427     my $nul = IO::File->new("< /dev/null");
 428
 429     my $ks = get_keyserver();
 430     msvalog('debug', "start ks query to %s for UserID: %s\n", $ks, $uid);
 431     my $pid = $gnupg->wrap_call
 432       ( handles => GnuPG::Handles->new( command => $cmd, stdout => $out, stderr => $nul ),
 433         command_args => [ '='.$uid ],
 434         commands => [ '--keyserver',
 435                       $ks,
 436                       qw( --no-tty --with-colons --search ) ]
 437       );
 438     while (my $line = $out->getline()) {
 439       msvalog('debug', "from ks query: (%d) %s", $cmd->fileno, $line);
 440       if ($line =~ /^info:(\d+):(\d+)/ ) {
 441         $cmd->print(join(' ', ($1..$2))."\n");
 442         msvalog('debug', 'to ks query: '.join(' ', ($1..$2))."\n");
 443         last;
 444       }
 445     }
 446     # FIXME: can we do something to avoid hanging forever?
 447     waitpid($pid, 0);
 448     msvalog('debug', "ks query returns %d\n", POSIX::WEXITSTATUS($?));
 449   }
 450
 451   sub reviewcert {
 452     my $data  = shift;
 453     return if !ref $data;
 454
 455     my $status = '200 OK';
 456     my $ret =  { valid => JSON::false,
 457                  message => 'Unknown failure',
 458                };
 459
 460     my $uid = getuid($data);
 461     if ($uid eq []) {
 462         msvalog('error', "invalid peer/context: %s/%s\n", $data->{context}, $data->{peer});
 463         $ret->{message} = sprintf('invalid peer/context');
 464         return $status, $ret;
 465     }
 466
 467     my $rawdata = join('', map(chr, @{$data->{pkc}->{data}}));
 468     my $cert = Crypt::X509->new(cert => $rawdata);
 469     msvalog('verbose', "cert subject: %s\n", $cert->subject_cn());
 470     msvalog('verbose', "cert issuer: %s\n", $cert->issuer_cn());
 471     msvalog('verbose', "cert pubkey algo: %s\n", $cert->PubKeyAlg());
 472     msvalog('verbose', "cert pubkey: %s\n", unpack('H*', $cert->pubkey()));
 473
 474     if ($cert->PubKeyAlg() ne 'RSA') {
 475       $ret->{message} = sprintf('public key was algo "%s" (OID %s).  MSVA.pl only supports RSA',
 476                                 $cert->PubKeyAlg(), $cert->pubkey_algorithm);
 477     } else {
 478       my $key = $rsa_decoder->decode($cert->pubkey());
 479       if ($key) {
 480         # make sure that the returned integers are Math::BigInts:
 481         $key->{exponent} = Math::BigInt->new($key->{exponent}) unless (ref($key->{exponent}));
 482         $key->{modulus} = Math::BigInt->new($key->{modulus}) unless (ref($key->{modulus}));
 483         msvalog('debug', "cert info:\nmodulus: %s\nexponent: %s\n",
 484                 $key->{modulus}->as_hex(),
 485                 $key->{exponent}->as_hex(),
 486                );
 487
 488         if ($key->{modulus}->copy()->blog(2) < 1000) { # FIXME: this appears to be the full pubkey, including DER overhead
 489           $ret->{message} = sprintf('public key size is less than 1000 bits (was: %d bits)', $cert->pubkey_size());
 490         } else {
 491           $ret->{message} = sprintf('Failed to validate "%s" through the OpenPGP Web of Trust.', $uid);
 492           my $lastloop = 0;
 493           msvalog('debug', "keyserver policy: %s\n", get_keyserver_policy);
 494           # needed because $gnupg spawns child processes
 495           $ENV{PATH} = '/usr/local/bin:/usr/bin:/bin';
 496           if (get_keyserver_policy() eq 'always') {
 497             fetch_uid_from_keyserver($uid);
 498             $lastloop = 1;
 499           } elsif (get_keyserver_policy() eq 'never') {
 500             $lastloop = 1;
 501           }
 502           my $foundvalid = 0;
 503
 504           # fingerprints of keys that are not fully-valid for this User ID, but match
 505           # the key from the queried certificate:
 506           my @subvalid_key_fprs;
 507
 508           while (1) {
 509             foreach my $gpgkey ($gnupg->get_public_keys('='.$uid)) {
 510               my $validity = '-';
 511               foreach my $tryuid ($gpgkey->user_ids) {
 512                 if ($tryuid->as_string eq $uid) {
 513                   $validity = $tryuid->validity;
 514                 }
 515               }
 516               # treat primary keys just like subkeys:
 517               foreach my $subkey ($gpgkey, @{$gpgkey->subkeys}) {
 518                 my $primarymatch = keycomp($key, $subkey);
 519                 if ($primarymatch) {
 520                   if ($subkey->usage_flags =~ /a/) {
 521                     msvalog('verbose', "key matches, and 0x%s is authentication-capable\n", $subkey->hex_id);
 522                     if ($validity =~ /^[fu]$/) {
 523                       $foundvalid = 1;
 524                       msvalog('verbose', "...and it matches!\n");
 525                       $ret->{valid} = JSON::true;
 526                       $ret->{message} = sprintf('Successfully validated "%s" through the OpenPGP Web of Trust.', $uid);
 527                     } else {
 528                       push(@subvalid_key_fprs, { fpr => $subkey->fingerprint, val => $validity }) if $lastloop;
 529                     }
 530                   } else {
 531                     msvalog('verbose', "key matches, but 0x%s is not authentication-capable\n", $subkey->hex_id);
 532                   }
 533                 }
 534               }
 535             }
 536             if ($lastloop) {
 537               last;
 538             } else {
 539               fetch_uid_from_keyserver($uid) if (!$foundvalid);
 540               $lastloop = 1;
 541             }
 542           }
 543
 544           my $resp = Crypt::Monkeysphere::MSVA::MarginalUI->ask_the_user($gnupg,
 545                                                                          $uid,
 546                                                                          \@subvalid_key_fprs);
 547           msvalog('info', "response: %s\n", $resp);
 548           if ($resp) {
 549             $ret->{valid} = JSON::true;
 550             $ret->{message} = sprintf('Manually validated "%s" through the OpenPGP Web of Trust.', $uid);
 551           }
 552         }
 553       } else {
 554         msvalog('error', "failed to decode %s\n", unpack('H*', $cert->pubkey()));
 555         $ret->{message} = sprintf('failed to decode the public key', $uid);
 556       }
 557     }
 558
 559     return $status, $ret;
 560   }
 561
 562   sub child_dies {
 563     my $self = shift;
 564     my $pid = shift;
 565     my $server = shift;
 566
 567     msvalog('debug', "Subprocess %d terminated.\n", $pid);
 568
 569     if (exists $self->{child_pid} &&
 570         ($self->{child_pid} == 0 ||
 571          $self->{child_pid} == $pid)) {
 572       my $exitstatus = POSIX::WEXITSTATUS($?);
 573       msvalog('verbose', "Subprocess %d terminated; exiting %d.\n", $pid, $exitstatus);
 574       $server->set_exit_status($exitstatus);
 575       $server->server_close();
 576     }
 577   }
 578
 579   # use sparingly!  We want to keep taint mode around for the data we
 580   # get over the network.  this is only here because we want to treat
 581   # the command line arguments differently for the subprocess.
 582   sub untaint {
 583     my $x = shift;
 584     $x =~ /^(.*)$/ ;
 585     return $1;
 586   }
 587
 588   sub post_bind_hook {
 589     my $self = shift;
 590     my $server = shift;
 591
 592     my $socketcount = @{ $server->{server}->{sock} };
 593     if ( $socketcount != 1 ) {
 594       msvalog('error', "%d sockets open; should have been 1.", $socketcount);
 595       $server->set_exit_status(10);
 596       $server->server_close();
 597     }
 598     my $port = @{ $server->{server}->{sock} }[0]->sockport();
 599     if ((! defined $port) || ($port < 1) || ($port >= 65536)) {
 600       msvalog('error', "got nonsense port: %d.", $port);
 601       $server->set_exit_status(11);
 602       $server->server_close();
 603     }
 604     if ((exists $ENV{MSVA_PORT}) && (($ENV{MSVA_PORT} + 0) != $port)) {
 605       msvalog('error', "Explicitly requested port %d, but got port: %d.", ($ENV{MSVA_PORT}+0), $port);
 606       $server->set_exit_status(13);
 607       $server->server_close();
 608     }
 609     $self->port($port);
 610
 611     my $argcount = @ARGV;
 612     if ($argcount) {
 613       $self->{child_pid} = 0; # indicate that we are planning to fork.
 614       my $fork = fork();
 615       if (! defined $fork) {
 616         msvalog('error', "could not fork\n");
 617       } else {
 618         if ($fork) {
 619           msvalog('debug', "Child process has PID %d\n", $fork);
 620           $self->{child_pid} = $fork;
 621         } else {
 622           msvalog('verbose', "PID %d executing: \n", $$);
 623           for my $arg (@ARGV) {
 624             msvalog('verbose', " %s\n", $arg);
 625           }
 626           # untaint the environment for the subprocess
 627           # see: https://labs.riseup.net/code/issues/2461
 628           foreach my $e (keys %ENV) {
 629             $ENV{$e} = untaint($ENV{$e});
 630           }
 631           my @args;
 632           foreach (@ARGV) {
 633             push @args, untaint($_);
 634           }
 635           # restore default SIGCHLD handling:
 636           $SIG{CHLD} = 'DEFAULT';
 637           $ENV{MONKEYSPHERE_VALIDATION_AGENT_SOCKET} = sprintf('http://localhost:%d', $self->port);
 638           exec(@args) or exit 111;
 639         }
 640       }
 641     } else {
 642       printf("MONKEYSPHERE_VALIDATION_AGENT_SOCKET=http://localhost:%d;\nexport MONKEYSPHERE_VALIDATION_AGENT_SOCKET;\n", $self->port);
 643       # FIXME: consider daemonizing here to behave more like
 644       # ssh-agent.  maybe avoid backgrounding by setting
 645       # MSVA_NO_BACKGROUND.
 646     };
 647   }
 648
 649   sub extracerts {
 650     my $data = shift;
 651
 652     return '500 not yet implemented', { };
 653   }
 654
 655   1;
 656 }