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