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( &reviewcert );
  27   }
  28   our @EXPORT_OK;
  29
  30   use Crypt::Monkeysphere::MSVA::MarginalUI;
  31   use Crypt::Monkeysphere::MSVA::Logger;
  32   use parent qw(HTTP::Server::Simple::CGI);
  33   require Crypt::X509;
  34   use Regexp::Common qw /net/;
  35   use Convert::ASN1;
  36   use MIME::Base64;
  37   use IO::Socket;
  38   use IO::File;
  39   use Socket;
  40   use File::Spec;
  41   use File::HomeDir;
  42   use Config::General;
  43
  44   use JSON;
  45   use POSIX qw(strftime);
  46   # we need the version of GnuPG::Interface that knows about pubkey_data, etc:
  47   use GnuPG::Interface 0.42.02;
  48
  49   my $version = '0.1';
  50
  51   my $gnupg = GnuPG::Interface->new();
  52   $gnupg->options->quiet(1);
  53   $gnupg->options->batch(1);
  54
  55   my %dispatch = (
  56                   '/' => { handler => \&noop,
  57                            methods => { 'GET' => 1 },
  58                          },
  59                   '/reviewcert' => { handler => \&reviewcert,
  60                                      methods => { 'POST' => 1 },
  61                                    },
  62                   '/extracerts' => { handler => \&extracerts,
  63                                      methods => { 'POST' => 1 },
  64                                    },
  65                  );
  66
  67   my $default_keyserver = 'hkp://pool.sks-keyservers.net';
  68   my $default_keyserver_policy = 'unlessvalid';
  69
  70   my $logger = Crypt::Monkeysphere::MSVA::Logger->new($ENV{MSVA_LOG_LEVEL});
  71   sub logger {
  72     return $logger;
  73   }
  74
  75   my $rsa_decoder = Convert::ASN1->new;
  76   $rsa_decoder->prepare(q<
  77
  78    SEQUENCE {
  79         modulus INTEGER,
  80         exponent INTEGER
  81    }
  82           >);
  83
  84   sub net_server {
  85     return 'Net::Server::MSVA';
  86   };
  87
  88   sub msvalog {
  89     return $logger->log(@_);
  90   };
  91
  92   sub new {
  93     my $class = shift;
  94
  95     my $port = 0;
  96     if (exists $ENV{MSVA_PORT} and $ENV{MSVA_PORT} ne '') {
  97       msvalog('debug', "MSVA_PORT set to %s\n", $ENV{MSVA_PORT});
  98       $port = $ENV{MSVA_PORT} + 0;
  99       die sprintf("not a reasonable port %d", $port) if (($port >= 65536) || $port <= 0);
 100     }
 101     # start the server on requested port
 102     my $self = $class->SUPER::new($port);
 103     if (! exists $ENV{MSVA_PORT}) {
 104       # we can't pass port 0 to the constructor because it evaluates
 105       # to false, so HTTP::Server::Simple just uses its internal
 106       # default of 8080.  But if we want to select an arbitrary open
 107       # port, we *can* set it here.
 108       $self->port(0);
 109     }
 110
 111     $self->{allowed_uids} = {};
 112     if (exists $ENV{MSVA_ALLOWED_USERS} and $ENV{MSVA_ALLOWED_USERS} ne '') {
 113       msvalog('verbose', "MSVA_ALLOWED_USERS environment variable is set.\nLimiting access to specified users.\n");
 114       foreach my $user (split(/ +/, $ENV{MSVA_ALLOWED_USERS})) {
 115         my ($name, $passwd, $uid);
 116         if ($user =~ /^[0-9]+$/) {
 117           $uid = $user + 0; # force to integer
 118         } else {
 119           ($name,$passwd,$uid) = getpwnam($user);
 120         }
 121         if (defined $uid) {
 122           msvalog('verbose', "Allowing access from user ID %d\n", $uid);
 123           $self->{allowed_uids}->{$uid} = $user;
 124         } else {
 125           msvalog('error', "Could not find user '%d'; not allowing\n", $user);
 126         }
 127       }
 128     } else {
 129       # default is to allow access only to the current user
 130       $self->{allowed_uids}->{POSIX::getuid()} = 'self';
 131     }
 132
 133     bless ($self, $class);
 134     return $self;
 135   }
 136
 137   sub noop {
 138     my $self = shift;
 139     my $cgi = shift;
 140     return '200 OK', { available => JSON::true,
 141                        protoversion => 1,
 142                        server => "MSVA-Perl ".$version };
 143   }
 144
 145   # returns an empty list if bad key found.
 146   sub parse_openssh_pubkey {
 147     my $data = shift;
 148     my ($label, $prop) = split(/ +/, $data);
 149     $prop = decode_base64($prop) or return ();
 150
 151     msvalog('debug', "key properties: %s\n", unpack('H*', $prop));
 152     my @out;
 153     while (length($prop) > 4) {
 154       my $size = unpack('N', substr($prop, 0, 4));
 155       msvalog('debug', "size: 0x%08x\n", $size);
 156       return () if (length($prop) < $size + 4);
 157       push(@out, substr($prop, 4, $size));
 158       $prop = substr($prop, 4 + $size);
 159     }
 160     return () if ($label ne $out[0]);
 161     return @out;
 162   }
 163
 164
 165   # return an arrayref of processes which we can detect that have the
 166   # given socket open (the socket is specified with its inode)
 167   sub getpidswithsocketinode {
 168     my $sockid = shift;
 169
 170     # this appears to be how Linux symlinks open sockets in /proc/*/fd,
 171     # as of at least 2.6.26:
 172     my $socktarget = sprintf('socket:[%d]', $sockid);
 173     my @pids;
 174
 175     my $procfs;
 176     if (opendir($procfs, '/proc')) {
 177       foreach my $pid (grep { /^\d+$/ } readdir($procfs)) {
 178         my $procdir = sprintf('/proc/%d', $pid);
 179         if (-d $procdir) {
 180           my $procfds;
 181           if (opendir($procfds, sprintf('/proc/%d/fd', $pid))) {
 182             foreach my $procfd (grep { /^\d+$/ } readdir($procfds)) {
 183               my $fd = sprintf('/proc/%d/fd/%d', $pid, $procfd);
 184               if (-l $fd) {
 185                 #my ($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($fd);
 186                 my $targ = readlink($fd);
 187                 push @pids, $pid
 188                   if ($targ eq $socktarget);
 189               }
 190             }
 191             closedir($procfds);
 192           }
 193         }
 194       }
 195       closedir($procfs);
 196     }
 197
 198     # FIXME: this whole business is very linux-specific, i think.  i
 199     # wonder how to get this info in other OSes?
 200
 201     return \@pids;
 202   }
 203
 204   # return {uid => X, inode => Y}, meaning the numeric ID of the peer
 205   # on the other end of $socket, "socket inode" identifying the peer's
 206   # open network socket.  each value could be undef if unknown.
 207   sub get_client_info {
 208     my $socket = shift;
 209
 210     my $sock = IO::Socket->new_from_fd($socket, 'r');
 211     # check SO_PEERCRED -- if this was a TCP socket, Linux
 212     # might not be able to support SO_PEERCRED (even on the loopback),
 213     # though apparently some kernels (Solaris?) are able to.
 214
 215     my $clientid;
 216     my $remotesocketinode;
 217     my $socktype = $sock->sockopt(SO_TYPE) or die "could not get SO_TYPE info";
 218     if (defined $socktype) {
 219       msvalog('debug', "sockopt(SO_TYPE) = %d\n", $socktype);
 220     } else {
 221       msvalog('verbose', "sockopt(SO_TYPE) returned undefined.\n");
 222     }
 223
 224     my $peercred = $sock->sockopt(SO_PEERCRED) or die "could not get SO_PEERCRED info";
 225     my $client = $sock->peername();
 226     my $family = sockaddr_family($client); # should be AF_UNIX (a.k.a. AF_LOCAL) or AF_INET
 227
 228     msvalog('verbose', "socket family: %d\nsocket type: %d\n", $family, $socktype);
 229
 230     if ($peercred) {
 231       # FIXME: on i386 linux, this appears to be three ints, according to
 232       # /usr/include/linux/socket.h.  What about other platforms?
 233       my ($pid, $uid, $gid) = unpack('iii', $peercred);
 234
 235       msvalog('verbose', "SO_PEERCRED: pid: %u, uid: %u, gid: %u\n",
 236               $pid, $uid, $gid,
 237              );
 238       if ($pid != 0 && $uid != 0) { # then we can accept it:
 239         $clientid = $uid;
 240       }
 241       # FIXME: can we get the socket inode as well this way?
 242     }
 243
 244     # another option in Linux would be to parse the contents of
 245     # /proc/net/tcp to find the uid of the peer process based on that
 246     # information.
 247     if (! defined $clientid) {
 248       msvalog('verbose', "SO_PEERCRED failed, digging around in /proc/net/tcp\n");
 249       my $proto;
 250       if ($family == AF_INET) {
 251         $proto = '';
 252       } elsif ($family == AF_INET6) {
 253         $proto = '6';
 254       }
 255       if (defined $proto) {
 256         if ($socktype == &SOCK_STREAM) {
 257           $proto = 'tcp'.$proto;
 258         } elsif ($socktype == &SOCK_DGRAM) {
 259           $proto = 'udp'.$proto;
 260         } else {
 261           undef $proto;
 262         }
 263         if (defined $proto) {
 264           my ($port, $iaddr) = unpack_sockaddr_in($client);
 265           my $iaddrstring = unpack("H*", reverse($iaddr));
 266           msvalog('verbose', "Port: %04x\nAddr: %s\n", $port, $iaddrstring);
 267           my $remmatch = lc(sprintf("%s:%04x", $iaddrstring, $port));
 268           my $infofile = '/proc/net/'.$proto;
 269           my $f = new IO::File;
 270           if ( $f->open('< '.$infofile)) {
 271             my @header = split(/ +/, <$f>);
 272             my ($localaddrix, $uidix, $inodeix);
 273             my $ix = 0;
 274             my $skipcount = 0;
 275             while ($ix <= $#header) {
 276               $localaddrix = $ix - $skipcount if (lc($header[$ix]) eq 'local_address');
 277               $uidix = $ix - $skipcount if (lc($header[$ix]) eq 'uid');
 278               $inodeix = $ix - $skipcount if (lc($header[$ix]) eq 'inode');
 279               $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
 280               $ix++;
 281             }
 282             if (!defined $localaddrix) {
 283               msvalog('info', "Could not find local_address field in %s; unable to determine peer UID\n",
 284                       $infofile);
 285             } elsif (!defined $uidix) {
 286               msvalog('info', "Could not find uid field in %s; unable to determine peer UID\n",
 287                       $infofile);
 288             } elsif (!defined $inodeix) {
 289               msvalog('info', "Could not find inode field in %s; unable to determine peer network socket inode\n",
 290                       $infofile);
 291             } else {
 292               msvalog('debug', "local_address: %d; uid: %d\n", $localaddrix,$uidix);
 293               while (my @line = split(/ +/,<$f>)) {
 294                 if (lc($line[$localaddrix]) eq $remmatch) {
 295                   if (defined $clientid) {
 296                     msvalog('error', "Warning! found more than one remote uid! (%s and %s\n", $clientid, $line[$uidix]);
 297                   } else {
 298                     $clientid = $line[$uidix];
 299                     $remotesocketinode = $line[$inodeix];
 300                     msvalog('info', "remote peer is uid %d (inode %d)\n",
 301                             $clientid, $remotesocketinode);
 302                   }
 303                 }
 304               }
 305             msvalog('error', "Warning! could not find peer information in %s.  Not verifying.\n", $infofile) unless defined $clientid;
 306             }
 307           } else { # FIXME: we couldn't read the file.  what should we
 308                    # do besides warning?
 309             msvalog('info', "Could not read %s; unable to determine peer UID\n",
 310                     $infofile);
 311           }
 312         }
 313       }
 314     }
 315     return { 'uid' => $clientid,
 316              'inode' => $remotesocketinode };
 317   }
 318
 319   sub handle_request {
 320     my $self = shift;
 321     my $cgi  = shift;
 322
 323     my $clientinfo = get_client_info(select);
 324     my $clientuid = $clientinfo->{uid};
 325
 326     if (defined $clientuid) {
 327       # test that this is an allowed user:
 328       if (exists $self->{allowed_uids}->{$clientuid}) {
 329         msvalog('verbose', "Allowing access from uid %d (%s)\n", $clientuid, $self->{allowed_uids}->{$clientuid});
 330       } else {
 331         msvalog('error', "MSVA client connection from uid %d, forbidden.\n", $clientuid);
 332         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",
 333                strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())),);
 334         return;
 335       }
 336     }
 337
 338     my $path = $cgi->path_info();
 339     my $handler = $dispatch{$path};
 340
 341     if (ref($handler) eq "HASH") {
 342       if (! exists $handler->{methods}->{$cgi->request_method()}) {
 343         printf("HTTP/1.0 405 Method not allowed\r\nAllow: %s\r\nDate: %s\r\n",
 344                join(', ', keys(%{$handler->{methods}})),
 345                strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())));
 346       } elsif (ref($handler->{handler}) ne "CODE") {
 347         printf("HTTP/1.0 500 Server Error\r\nDate: %s\r\n",
 348                strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())));
 349       } else {
 350         my $data = {};
 351         my $ctype = $cgi->content_type();
 352         msvalog('verbose', "Got %s %s (Content-Type: %s)\n", $cgi->request_method(), $path, defined $ctype ? $ctype : '**none supplied**');
 353         if (defined $ctype) {
 354           my @ctypes = split(/; */, $ctype);
 355           $ctype = shift @ctypes;
 356           if ($ctype eq 'application/json') {
 357             $data = from_json($cgi->param('POSTDATA'));
 358           }
 359         };
 360
 361         my ($status, $object) = $handler->{handler}($data, $clientinfo);
 362         my $ret = to_json($object);
 363         msvalog('info', "returning: %s\n", $ret);
 364         printf("HTTP/1.0 %s\r\nDate: %s\r\nContent-Type: application/json\r\n\r\n%s",
 365                $status,
 366                strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())),
 367                $ret);
 368       }
 369     } else {
 370       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",
 371              strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())),
 372              $path, ' * '.join("\r\n * ", keys %dispatch) );
 373     }
 374   }
 375
 376   sub keycomp {
 377     my $rsakey = shift;
 378     my $gpgkey = shift;
 379
 380     if ($gpgkey->algo_num != 1) {
 381       msvalog('verbose', "Monkeysphere only does RSA keys.  This key is algorithm #%d\n", $gpgkey->algo_num);
 382     } else {
 383       if ($rsakey->{exponent}->bcmp($gpgkey->pubkey_data->[1]) == 0 &&
 384           $rsakey->{modulus}->bcmp($gpgkey->pubkey_data->[0]) == 0) {
 385         return 1;
 386       }
 387     }
 388     return 0;
 389   }
 390
 391   sub getuid {
 392     my $data = shift;
 393     if ($data->{context} =~ /^(https|ssh)$/) {
 394       $data->{context} = $1;
 395       if ($data->{peer} =~ /^($RE{net}{domain})$/) {
 396         $data->{peer} = $1;
 397         return $data->{context}.'://'.$data->{peer};
 398       }
 399     }
 400   }
 401
 402   sub get_keyserver_policy {
 403     if (exists $ENV{MSVA_KEYSERVER_POLICY} and $ENV{MSVA_KEYSERVER_POLICY} ne '') {
 404       if ($ENV{MSVA_KEYSERVER_POLICY} =~ /^(always|never|unlessvalid)$/) {
 405         return $1;
 406       }
 407       msvalog('error', "Not a valid MSVA_KEYSERVER_POLICY):\n  %s\n", $ENV{MSVA_KEYSERVER_POLICY});
 408     }
 409     return $default_keyserver_policy;
 410   }
 411
 412   sub get_keyserver {
 413     # We should read from (first hit wins):
 414     # the environment
 415     if (exists $ENV{MSVA_KEYSERVER} and $ENV{MSVA_KEYSERVER} ne '') {
 416       if ($ENV{MSVA_KEYSERVER} =~ /^(((hkps?|finger|ldap):\/\/)?$RE{net}{domain})$/) {
 417         return $1;
 418       }
 419       msvalog('error', "Not a valid keyserver (from MSVA_KEYSERVER):\n  %s\n", $ENV{MSVA_KEYSERVER});
 420     }
 421
 422     # FIXME: some msva.conf or monkeysphere.conf file (system and user?)
 423
 424     # or else read from the relevant gnupg.conf:
 425     my $gpghome;
 426     if (exists $ENV{GNUPGHOME} and $ENV{GNUPGHOME} ne '') {
 427       $gpghome = untaint($ENV{GNUPGHOME});
 428     } else {
 429       $gpghome = File::Spec->catfile(File::HomeDir->my_home, '.gnupg');
 430     }
 431     my $gpgconf = File::Spec->catfile($gpghome, 'gpg.conf');
 432     if (-f $gpgconf) {
 433       if (-r $gpgconf) {
 434         my %gpgconfig = Config::General::ParseConfig($gpgconf);
 435         if ($gpgconfig{keyserver} =~ /^(((hkps?|finger|ldap):\/\/)?$RE{net}{domain})$/) {
 436           msvalog('debug', "Using keyserver %s from the GnuPG configuration file (%s)\n", $1, $gpgconf);
 437           return $1;
 438         } else {
 439           msvalog('error', "Not a valid keyserver (from gpg config %s):\n  %s\n", $gpgconf, $gpgconfig{keyserver});
 440         }
 441       } else {
 442         msvalog('error', "The GnuPG configuration file (%s) is not readable\n", $gpgconf);
 443       }
 444     } else {
 445       msvalog('info', "Did not find GnuPG configuration file while looking for keyserver '%s'\n", $gpgconf);
 446     }
 447
 448     # the default_keyserver
 449     return $default_keyserver;
 450   }
 451
 452   sub fetch_uid_from_keyserver {
 453     my $uid = shift;
 454
 455     my $cmd = IO::Handle->new();
 456     my $out = IO::Handle->new();
 457     my $nul = IO::File->new("< /dev/null");
 458
 459     my $ks = get_keyserver();
 460     msvalog('debug', "start ks query to %s for UserID: %s\n", $ks, $uid);
 461     my $pid = $gnupg->wrap_call
 462       ( handles => GnuPG::Handles->new( command => $cmd, stdout => $out, stderr => $nul ),
 463         command_args => [ '='.$uid ],
 464         commands => [ '--keyserver',
 465                       $ks,
 466                       qw( --no-tty --with-colons --search ) ]
 467       );
 468     while (my $line = $out->getline()) {
 469       msvalog('debug', "from ks query: (%d) %s", $cmd->fileno, $line);
 470       if ($line =~ /^info:(\d+):(\d+)/ ) {
 471         $cmd->print(join(' ', ($1..$2))."\n");
 472         msvalog('debug', 'to ks query: '.join(' ', ($1..$2))."\n");
 473         last;
 474       }
 475     }
 476     # FIXME: can we do something to avoid hanging forever?
 477     waitpid($pid, 0);
 478     msvalog('debug', "ks query returns %d\n", POSIX::WEXITSTATUS($?));
 479   }
 480
 481   sub reviewcert {
 482     my $data  = shift;
 483     my $clientinfo  = shift;
 484     return if !ref $data;
 485
 486     msvalog('verbose', "reviewing data...\n");
 487
 488     my $status = '200 OK';
 489     my $ret =  { valid => JSON::false,
 490                  message => 'Unknown failure',
 491                };
 492
 493     my $uid = getuid($data);
 494     if ($uid eq []) {
 495         msvalog('error', "invalid peer/context: %s/%s\n", $data->{context}, $data->{peer});
 496         $ret->{message} = sprintf('invalid peer/context');
 497         return $status, $ret;
 498     }
 499     msvalog('verbose', "context: %s\n", $data->{context});
 500     msvalog('verbose', "peer: %s\n", $data->{peer});
 501
 502     my $rawdata = join('', map(chr, @{$data->{pkc}->{data}}));
 503     my $cert = Crypt::X509->new(cert => $rawdata);
 504
 505     msvalog('verbose', "cert subject: %s\n", $cert->subject_cn());
 506     msvalog('verbose', "cert issuer: %s\n", $cert->issuer_cn());
 507     msvalog('verbose', "cert pubkey algo: %s\n", $cert->PubKeyAlg());
 508     msvalog('verbose', "cert pubkey: %s\n", unpack('H*', $cert->pubkey()));
 509
 510     if ($cert->PubKeyAlg() ne 'RSA') {
 511       $ret->{message} = sprintf('public key was algo "%s" (OID %s).  MSVA.pl only supports RSA',
 512                                 $cert->PubKeyAlg(), $cert->pubkey_algorithm);
 513     } else {
 514       my $key = $rsa_decoder->decode($cert->pubkey());
 515       if ($key) {
 516         # make sure that the returned integers are Math::BigInts:
 517         $key->{exponent} = Math::BigInt->new($key->{exponent}) unless (ref($key->{exponent}));
 518         $key->{modulus} = Math::BigInt->new($key->{modulus}) unless (ref($key->{modulus}));
 519         msvalog('debug', "cert info:\nmodulus: %s\nexponent: %s\n",
 520                 $key->{modulus}->as_hex(),
 521                 $key->{exponent}->as_hex(),
 522                );
 523
 524         if ($key->{modulus}->copy()->blog(2) < 1000) { # FIXME: this appears to be the full pubkey, including DER overhead
 525           $ret->{message} = sprintf('public key size is less than 1000 bits (was: %d bits)', $cert->pubkey_size());
 526         } else {
 527           $ret->{message} = sprintf('Failed to validate "%s" through the OpenPGP Web of Trust.', $uid);
 528           my $lastloop = 0;
 529           my $kspolicy;
 530           if (defined $data->{keyserverpolicy} &&
 531               $data->{keyserverpolicy} =~ /^(always|never|unlessvalid)$/) {
 532             $kspolicy = $1;
 533             msvalog("verbose", "using requested keyserver policy: %s\n", $1);
 534           } else {
 535             $kspolicy = get_keyserver_policy();
 536           }
 537           msvalog('debug', "keyserver policy: %s\n", $kspolicy);
 538           # needed because $gnupg spawns child processes
 539           $ENV{PATH} = '/usr/local/bin:/usr/bin:/bin';
 540           if ($kspolicy eq 'always') {
 541             fetch_uid_from_keyserver($uid);
 542             $lastloop = 1;
 543           } elsif ($kspolicy eq 'never') {
 544             $lastloop = 1;
 545           }
 546           my $foundvalid = 0;
 547
 548           # fingerprints of keys that are not fully-valid for this User ID, but match
 549           # the key from the queried certificate:
 550           my @subvalid_key_fprs;
 551
 552           while (1) {
 553             foreach my $gpgkey ($gnupg->get_public_keys('='.$uid)) {
 554               my $validity = '-';
 555               foreach my $tryuid ($gpgkey->user_ids) {
 556                 if ($tryuid->as_string eq $uid) {
 557                   $validity = $tryuid->validity;
 558                 }
 559               }
 560               # treat primary keys just like subkeys:
 561               foreach my $subkey ($gpgkey, @{$gpgkey->subkeys}) {
 562                 my $primarymatch = keycomp($key, $subkey);
 563                 if ($primarymatch) {
 564                   if ($subkey->usage_flags =~ /a/) {
 565                     msvalog('verbose', "key matches, and 0x%s is authentication-capable\n", $subkey->hex_id);
 566                     if ($validity =~ /^[fu]$/) {
 567                       $foundvalid = 1;
 568                       msvalog('verbose', "...and it matches!\n");
 569                       $ret->{valid} = JSON::true;
 570                       $ret->{message} = sprintf('Successfully validated "%s" through the OpenPGP Web of Trust.', $uid);
 571                     } else {
 572                       push(@subvalid_key_fprs, { fpr => $subkey->fingerprint, val => $validity }) if $lastloop;
 573                     }
 574                   } else {
 575                     msvalog('verbose', "key matches, but 0x%s is not authentication-capable\n", $subkey->hex_id);
 576                   }
 577                 }
 578               }
 579             }
 580             if ($lastloop) {
 581               last;
 582             } else {
 583               fetch_uid_from_keyserver($uid) if (!$foundvalid);
 584               $lastloop = 1;
 585             }
 586           }
 587
 588           # only show the marginal UI if the UID of the corresponding
 589           # key is not fully valid.
 590           if (!$foundvalid) {
 591             my $resp = Crypt::Monkeysphere::MSVA::MarginalUI->ask_the_user($gnupg,
 592                                                                            $uid,
 593                                                                            \@subvalid_key_fprs,
 594                                                                            getpidswithsocketinode($clientinfo->{inode}),
 595                                                                            $logger);
 596             msvalog('info', "response: %s\n", $resp);
 597             if ($resp) {
 598               $ret->{valid} = JSON::true;
 599               $ret->{message} = sprintf('Manually validated "%s" through the OpenPGP Web of Trust.', $uid);
 600             }
 601           }
 602         }
 603       } else {
 604         msvalog('error', "failed to decode %s\n", unpack('H*', $cert->pubkey()));
 605         $ret->{message} = sprintf('failed to decode the public key', $uid);
 606       }
 607     }
 608
 609     return $status, $ret;
 610   }
 611
 612   sub child_dies {
 613     my $self = shift;
 614     my $pid = shift;
 615     my $server = shift;
 616
 617     msvalog('debug', "Subprocess %d terminated.\n", $pid);
 618
 619     if (exists $self->{child_pid} &&
 620         ($self->{child_pid} == 0 ||
 621          $self->{child_pid} == $pid)) {
 622       my $exitstatus = POSIX::WEXITSTATUS($?);
 623       msvalog('verbose', "Subprocess %d terminated; exiting %d.\n", $pid, $exitstatus);
 624       $server->set_exit_status($exitstatus);
 625       $server->server_close();
 626     }
 627   }
 628
 629   # use sparingly!  We want to keep taint mode around for the data we
 630   # get over the network.  this is only here because we want to treat
 631   # the command line arguments differently for the subprocess.
 632   sub untaint {
 633     my $x = shift;
 634     $x =~ /^(.*)$/ ;
 635     return $1;
 636   }
 637
 638   sub post_bind_hook {
 639     my $self = shift;
 640     my $server = shift;
 641
 642     $server->{server}->{leave_children_open_on_hup} = 1;
 643
 644     my $socketcount = @{ $server->{server}->{sock} };
 645     if ( $socketcount != 1 ) {
 646       msvalog('error', "%d sockets open; should have been 1.\n", $socketcount);
 647       $server->set_exit_status(10);
 648       $server->server_close();
 649     }
 650     my $port = @{ $server->{server}->{sock} }[0]->sockport();
 651     if ((! defined $port) || ($port < 1) || ($port >= 65536)) {
 652       msvalog('error', "got nonsense port: %d.\n", $port);
 653       $server->set_exit_status(11);
 654       $server->server_close();
 655     }
 656     if ((exists $ENV{MSVA_PORT}) && (($ENV{MSVA_PORT} + 0) != $port)) {
 657       msvalog('error', "Explicitly requested port %d, but got port: %d.", ($ENV{MSVA_PORT}+0), $port);
 658       $server->set_exit_status(13);
 659       $server->server_close();
 660     }
 661     $self->port($port);
 662
 663     if ((exists $ENV{MSVA_CHILD_PID}) && ($ENV{MSVA_CHILD_PID} ne '')) {
 664       # this is most likely a re-exec.
 665       msvalog('info', "This appears to be a re-exec, monitoring child pid %d\n", $ENV{MSVA_CHILD_PID});
 666       $self->{child_pid} = $ENV{MSVA_CHILD_PID} + 0;
 667     } elsif ($#ARGV >= 0) {
 668       $self->{child_pid} = 0; # indicate that we are planning to fork.
 669       my $fork = fork();
 670       if (! defined $fork) {
 671         msvalog('error', "could not fork\n");
 672       } else {
 673         if ($fork) {
 674           msvalog('debug', "Child process has PID %d\n", $fork);
 675           $self->{child_pid} = $fork;
 676           $ENV{MSVA_CHILD_PID} = $fork;
 677         } else {
 678           msvalog('verbose', "PID %d executing: \n", $$);
 679           for my $arg (@ARGV) {
 680             msvalog('verbose', " %s\n", $arg);
 681           }
 682           # untaint the environment for the subprocess
 683           # see: https://labs.riseup.net/code/issues/2461
 684           foreach my $e (keys %ENV) {
 685             $ENV{$e} = untaint($ENV{$e});
 686           }
 687           my @args;
 688           foreach (@ARGV) {
 689             push @args, untaint($_);
 690           }
 691           # restore default SIGCHLD handling:
 692           $SIG{CHLD} = 'DEFAULT';
 693           $ENV{MONKEYSPHERE_VALIDATION_AGENT_SOCKET} = sprintf('http://localhost:%d', $self->port);
 694           exec(@args) or exit 111;
 695         }
 696       }
 697     } else {
 698       printf("MONKEYSPHERE_VALIDATION_AGENT_SOCKET=http://localhost:%d;\nexport MONKEYSPHERE_VALIDATION_AGENT_SOCKET;\n", $self->port);
 699       # FIXME: consider daemonizing here to behave more like
 700       # ssh-agent.  maybe avoid backgrounding by setting
 701       # MSVA_NO_BACKGROUND.
 702     };
 703   }
 704
 705   sub extracerts {
 706     my $data = shift;
 707
 708     return '500 not yet implemented', { };
 709   }
 710
 711   1;
 712 }