msva-perl

   1 #!/usr/bin/perl -wT
   2
   3 # Monkeysphere Validation Agent, Perl version
   4 # Copyright © 2010 Daniel Kahn Gillmor <dkg@fifthhorseman.net>
   5 #
   6 # This program is free software: you can redistribute it and/or modify
   7 # it under the terms of the GNU General Public License as published by
   8 # the Free Software Foundation, either version 3 of the License, or
   9 # (at your option) any later version.
  10 #
  11 # This program is distributed in the hope that it will be useful,
  12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 # GNU General Public License for more details.
  15 #
  16 # You should have received a copy of the GNU General Public License
  17 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 use warnings;
  20 use strict;
  21
  22 { package MSVA;
  23
  24   use parent qw(HTTP::Server::Simple::CGI);
  25   require Crypt::X509;
  26   use Regexp::Common qw /net/;
  27   use Convert::ASN1;
  28   use MIME::Base64;
  29   use IO::Socket;
  30   use IO::File;
  31   use Socket;
  32
  33   use JSON;
  34   use POSIX qw(strftime);
  35   # we need the version of GnuPG::Interface that knows about pubkey_data, etc:
  36   use GnuPG::Interface 0.42.02;
  37
  38   my $version = '0.1';
  39
  40   my $gnupg = GnuPG::Interface->new();
  41   $gnupg->options->quiet(1);
  42   $gnupg->options->batch(1);
  43
  44   my %dispatch = (
  45                   '/' => { handler => \&noop,
  46                            methods => { 'GET' => 1 },
  47                          },
  48                   '/reviewcert' => { handler => \&reviewcert,
  49                                      methods => { 'POST' => 1 },
  50                                    },
  51                   '/extracerts' => { handler => \&extracerts,
  52                                      methods => { 'POST' => 1 },
  53                                    },
  54                  );
  55
  56   my $default_keyserver = 'hkp://pool.sks-keyservers.net';
  57   my $default_keyserver_policy = 'unlessvalid';
  58
  59 # Net::Server log_level goes from 0 to 4
  60 # this is scaled to match.
  61   my %loglevels = (
  62                    'silent' => 0,
  63                    'quiet' => 0.25,
  64                    'fatal' => 0.5,
  65                    'error' => 1,
  66                    'info' => 2,
  67                    'verbose' => 3,
  68                    'debug' => 4,
  69                    'debug1' => 4,
  70                    'debug2' => 5,
  71                    'debug3' => 6,
  72                   );
  73
  74   my $rsa_decoder = Convert::ASN1->new;
  75   $rsa_decoder->prepare(q<
  76
  77    SEQUENCE {
  78         modulus INTEGER,
  79         exponent INTEGER
  80    }
  81           >);
  82
  83   sub msvalog {
  84     my $msglevel = shift;
  85
  86     my $level = $loglevels{lc($ENV{MSVA_LOG_LEVEL})};
  87     $level = $loglevels{error} if (! defined $level);
  88
  89     if ($loglevels{lc($msglevel)} <= $level) {
  90       printf STDERR @_;
  91     }
  92   };
  93
  94   sub get_log_level {
  95     my $level = $loglevels{lc($ENV{MSVA_LOG_LEVEL})};
  96     $level = $loglevels{error} if (! defined $level);
  97     return $level;
  98   }
  99
 100   sub net_server {
 101     return 'Net::Server::MSVA';
 102   };
 103
 104   sub new {
 105     my $class = shift;
 106
 107     my $port = 0;
 108     if (exists $ENV{MSVA_PORT}) {
 109       $port = $ENV{MSVA_PORT} + 0;
 110       die sprintf("not a reasonable port %d", $port) if (($port >= 65536) || $port <= 0);
 111     }
 112     # start the server on requested port
 113     my $self = $class->SUPER::new($port);
 114     if (! exists $ENV{MSVA_PORT}) {
 115       # we can't pass port 0 to the constructor because it evaluates
 116       # to false, so HTTP::Server::Simple just uses its internal
 117       # default of 8080.  But if we want to select an arbitrary open
 118       # port, we *can* set it here.
 119       $self->port(0);
 120     }
 121
 122     $self->{allowed_uids} = {};
 123     if (exists $ENV{MSVA_ALLOWED_USERS}) {
 124       msvalog('verbose', "MSVA_ALLOWED_USERS environment variable is set.\nLimiting access to specified users.\n");
 125       foreach my $user (split(/ +/, $ENV{MSVA_ALLOWED_USERS})) {
 126         my ($name, $passwd, $uid);
 127         if ($user =~ /^[0-9]+$/) {
 128           $uid = $user + 0; # force to integer
 129         } else {
 130           ($name,$passwd,$uid) = getpwnam($user);
 131         }
 132         if (defined $uid) {
 133           msvalog('verbose', "Allowing access from user ID %d\n", $uid);
 134           $self->{allowed_uids}->{$uid} = $user;
 135         } else {
 136           msvalog('error', "Could not find user '%d'; not allowing\n", $user);
 137         }
 138       }
 139     } else {
 140       # default is to allow access only to the current user
 141       $self->{allowed_uids}->{POSIX::getuid()} = 'self';
 142     }
 143
 144     bless ($self, $class);
 145     return $self;
 146   }
 147
 148   sub noop {
 149     my $self = shift;
 150     my $cgi = shift;
 151     return '200 OK', { available => JSON::true,
 152                        protoversion => 1,
 153                        server => "MSVA-Perl ".$version };
 154   }
 155
 156   # returns an empty list if bad key found.
 157   sub parse_openssh_pubkey {
 158     my $data = shift;
 159     my ($label, $prop) = split(/ +/, $data);
 160     $prop = decode_base64($prop) or return ();
 161
 162     msvalog('debug', "key properties: %s\n", unpack('H*', $prop));
 163     my @out;
 164     while (length($prop) > 4) {
 165       my $size = unpack('N', substr($prop, 0, 4));
 166       msvalog('debug', "size: 0x%08x\n", $size);
 167       return () if (length($prop) < $size + 4);
 168       push(@out, substr($prop, 4, $size));
 169       $prop = substr($prop, 4 + $size);
 170     }
 171     return () if ($label ne $out[0]);
 172     return @out;
 173   }
 174
 175   # return the numeric ID of the peer on the other end of $socket,
 176   # returning undef if unknown.
 177   sub get_remote_peer_id {
 178     my $socket = shift;
 179
 180     my $sock = IO::Socket->new_from_fd($socket, 'r');
 181     # check SO_PEERCRED -- if this was a TCP socket, Linux
 182     # might not be able to support SO_PEERCRED (even on the loopback),
 183     # though apparently some kernels (Solaris?) are able to.
 184
 185     my $remotepeerid;
 186     my $socktype = $sock->sockopt(SO_TYPE) or die "could not get SO_TYPE info";
 187     if (defined $socktype) {
 188       msvalog('debug', "sockopt(SO_TYPE) = %d\n", $socktype);
 189     } else {
 190       msvalog('verbose', "sockopt(SO_TYPE) returned undefined.\n");
 191     }
 192
 193     my $peercred = $sock->sockopt(SO_PEERCRED) or die "could not get SO_PEERCRED info";
 194     my $remotepeer = $sock->peername();
 195     my $family = sockaddr_family($remotepeer); # should be AF_UNIX (a.k.a. AF_LOCAL) or AF_INET
 196
 197     msvalog('verbose', "socket family: %d\nsocket type: %d\n", $family, $socktype);
 198
 199     if ($peercred) {
 200       # FIXME: on i386 linux, this appears to be three ints, according to
 201       # /usr/include/linux/socket.h.  What about other platforms?
 202       my ($pid, $uid, $gid) = unpack('iii', $peercred);
 203
 204       msvalog('verbose', "SO_PEERCRED: pid: %u, uid: %u, gid: %u\n",
 205               $pid, $uid, $gid,
 206              );
 207       if ($pid != 0 && $uid != 0) { # then we can accept it:
 208         $remotepeerid = $uid;
 209       }
 210     }
 211
 212     # another option in Linux would be to parse the contents of
 213     # /proc/net/tcp to find the uid of the peer process based on that
 214     # information.
 215     if (! defined $remotepeerid) {
 216       my $proto;
 217       if ($family == AF_INET) {
 218         $proto = '';
 219       } elsif ($family == AF_INET6) {
 220         $proto = '6';
 221       }
 222       if (defined $proto) {
 223         if ($socktype == &SOCK_STREAM) {
 224           $proto = 'tcp'.$proto;
 225         } elsif ($socktype == &SOCK_DGRAM) {
 226           $proto = 'udp'.$proto;
 227         } else {
 228           undef $proto;
 229         }
 230         if (defined $proto) {
 231           my ($port, $iaddr) = unpack_sockaddr_in($remotepeer);
 232           my $iaddrstring = unpack("H*", reverse($iaddr));
 233           msvalog('verbose', "Port: %04x\nAddr: %s\n", $port, $iaddrstring);
 234           my $remmatch = lc(sprintf("%s:%04x", $iaddrstring, $port));
 235           my $infofile = '/proc/net/'.$proto;
 236           my $f = new IO::File;
 237           if ( $f->open('< '.$infofile)) {
 238             my @header = split(/ +/, <$f>);
 239             my ($localaddrix, $uidix);
 240             my $ix = 0;
 241             my $skipcount = 0;
 242             while ($ix <= $#header) {
 243               $localaddrix = $ix - $skipcount if (lc($header[$ix]) eq 'local_address');
 244               $uidix = $ix - $skipcount if (lc($header[$ix]) eq 'uid');
 245               $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
 246               $ix++;
 247             }
 248             if (!defined $localaddrix) {
 249               msvalog('info', "Could not find local_address field in %s; unable to determine peer UID\n",
 250                       $infofile);
 251             } elsif (!defined $uidix) {
 252               msvalog('info', "Could not find uid field in %s; unable to determine peer UID\n",
 253                       $infofile);
 254             } else {
 255               msvalog('debug', "local_address: %d; uid: %d\n", $localaddrix,$uidix);
 256               while (my @line = split(/ +/,<$f>)) {
 257                 if (lc($line[$localaddrix]) eq $remmatch) {
 258                   if (defined $remotepeerid) {
 259                     msvalog('error', "Warning! found more than one remote uid! (%s and %s\n", $remotepeerid, $line[$uidix]);
 260                   } else {
 261                     $remotepeerid = $line[$uidix];
 262                     msvalog('info', "remote peer is uid %d\n",
 263                             $remotepeerid);
 264                   }
 265                 }
 266               }
 267             msvalog('error', "Warning! could not find peer information in %s.  Not verifying.\n", $infofile) unless defined $remotepeerid;
 268             }
 269           } else { # FIXME: we couldn't read the file.  what should we
 270                    # do besides warning?
 271             msvalog('info', "Could not read %s; unable to determine peer UID\n",
 272                     $infofile);
 273           }
 274         }
 275       }
 276     }
 277     return $remotepeerid;
 278   }
 279
 280   sub handle_request {
 281     my $self = shift;
 282     my $cgi  = shift;
 283
 284     my $remotepeerid =  get_remote_peer_id(select);
 285
 286     if (defined $remotepeerid) {
 287       # test that this is an allowed user:
 288       if (exists $self->{allowed_uids}->{$remotepeerid}) {
 289         msvalog('verbose', "Allowing access from uid %d (%s)\n", $remotepeerid, $self->{allowed_uids}->{$remotepeerid});
 290       } else {
 291         msvalog('error', "MSVA client connection from uid %d, forbidden.\n", $remotepeerid);
 292         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",
 293                strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())),);
 294         return;
 295       }
 296     }
 297
 298     my $path = $cgi->path_info();
 299     my $handler = $dispatch{$path};
 300
 301     if (ref($handler) eq "HASH") {
 302       if (! exists $handler->{methods}->{$cgi->request_method()}) {
 303         printf("HTTP/1.0 405 Method not allowed\r\nAllow: %s\r\nDate: %s\r\n",
 304                join(', ', keys(%{$handler->{methods}})),
 305                strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())));
 306       } elsif (ref($handler->{handler}) ne "CODE") {
 307         printf("HTTP/1.0 500 Server Error\r\nDate: %s\r\n",
 308                strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())));
 309       } else {
 310         my $data = {};
 311         my $ctype = $cgi->content_type();
 312         msvalog('verbose', "Got %s %s (Content-Type: %s)\n", $cgi->request_method(), $path, defined $ctype ? $ctype : '**none supplied**');
 313         if (defined $ctype) {
 314           my @ctypes = split(/; */, $ctype);
 315           $ctype = shift @ctypes;
 316           if ($ctype eq 'application/json') {
 317             $data = from_json($cgi->param('POSTDATA'));
 318           }
 319         };
 320
 321         my ($status, $object) = $handler->{handler}($data);
 322         my $ret = to_json($object);
 323         msvalog('info', "returning: %s\n", $ret);
 324         printf("HTTP/1.0 %s\r\nDate: %s\r\nContent-Type: application/json\r\n\r\n%s",
 325                $status,
 326                strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())),
 327                $ret);
 328       }
 329     } else {
 330       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",
 331              strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())),
 332              $path, ' * '.join("\r\n * ", keys %dispatch) );
 333     }
 334   }
 335
 336   sub keycomp {
 337     my $rsakey = shift;
 338     my $gpgkey = shift;
 339
 340     if ($gpgkey->algo_num != 1) {
 341       msvalog('verbose', "Monkeysphere only does RSA keys.  This key is algorithm #%d\n", $gpgkey->algo_num);
 342     } else {
 343       if ($rsakey->{exponent}->bcmp($gpgkey->pubkey_data->[1]) == 0 &&
 344           $rsakey->{modulus}->bcmp($gpgkey->pubkey_data->[0]) == 0) {
 345         return 1;
 346       }
 347     }
 348     return 0;
 349   }
 350
 351   sub getuid {
 352     my $data = shift;
 353     if ($data->{context} =~ /^(https|ssh)$/) {
 354       $data->{context} = $1;
 355       if ($data->{peer} =~ /^($RE{net}{domain})$/) {
 356         $data->{peer} = $1;
 357         return $data->{context}.'://'.$data->{peer};
 358       }
 359     }
 360   }
 361
 362   sub get_keyserver_policy {
 363     if (exists $ENV{MSVA_KEYSERVER_POLICY}) {
 364       if ($ENV{MSVA_KEYSERVER_POLICY} =~ /^(always|never)$/) {
 365         return $1;
 366       }
 367       msvalog('error', "Not a valid MSVA_KEYSERVER_POLICY):\n  %s\n", $ENV{MSVA_KEYSERVER_POLICY});
 368     }
 369     return $default_keyserver_policy;
 370   }
 371
 372   sub get_keyserver {
 373     # We should read from (first hit wins):
 374     # the environment
 375     if (exists $ENV{MSVA_KEYSERVER}) {
 376       if ($ENV{MSVA_KEYSERVER} =~ /^((hkps?|finger|ldap):\/\/)?$RE{net}{domain}$/) {
 377         return $1;
 378       }
 379       msvalog('error', "Not a valid keyserver (from MSVA_KEYSERVER):\n  %s\n", $ENV{MSVA_KEYSERVER});
 380     }
 381
 382     # FIXME: some msva.conf file (system and user?)
 383     # FIXME: the relevant gnupg.conf instead?
 384
 385     # the default_keyserver
 386     return $default_keyserver;
 387   }
 388
 389   sub fetch_uid_from_keyserver {
 390     my $uid = shift;
 391
 392     my $cmd = IO::Handle->new();
 393     my $out = IO::Handle->new();
 394     my $nul = IO::File->new("< /dev/null");
 395
 396     msvalog('debug', "start ks query for UserID: %s", $uid);
 397     my $pid = $gnupg->wrap_call
 398       ( handles => GnuPG::Handles->new( command => $cmd, stdout => $out, stderr => $nul ),
 399         command_args => [ '='.$uid ],
 400         commands => [ '--keyserver',
 401                       get_keyserver(),
 402                       qw( --no-tty --with-colons --search ) ]
 403       );
 404     while (my $line = $out->getline()) {
 405       msvalog('debug', "from ks query: (%d) %s", $cmd->fileno, $line);
 406       if ($line =~ /^info:(\d+):(\d+)/ ) {
 407         $cmd->print(join(' ', ($1..$2))."\n");
 408         msvalog('debug', 'to ks query: '.join(' ', ($1..$2))."\n");
 409       }
 410     }
 411     # FIXME: can we do something to avoid hanging forever?
 412     waitpid($pid, 0);
 413     msvalog('debug', "ks query returns %d\n", POSIX::WEXITSTATUS($?));
 414   }
 415
 416   sub reviewcert {
 417     my $data  = shift;
 418     return if !ref $data;
 419
 420     my $status = '200 OK';
 421     my $ret =  { valid => JSON::false,
 422                  message => 'Unknown failure',
 423                };
 424
 425     my $uid = getuid($data);
 426     if ($uid eq []) {
 427         msvalog('error', "invalid peer/context: %s/%s\n", $data->{context}, $data->{peer});
 428         $ret->{message} = sprintf('invalid peer/context');
 429         return $status, $ret;
 430     }
 431
 432     my $rawdata = join('', map(chr, @{$data->{pkc}->{data}}));
 433     my $cert = Crypt::X509->new(cert => $rawdata);
 434     msvalog('verbose', "cert subject: %s\n", $cert->subject_cn());
 435     msvalog('verbose', "cert issuer: %s\n", $cert->issuer_cn());
 436     msvalog('verbose', "cert pubkey algo: %s\n", $cert->PubKeyAlg());
 437     msvalog('verbose', "cert pubkey: %s\n", unpack('H*', $cert->pubkey()));
 438
 439     if ($cert->PubKeyAlg() ne 'RSA') {
 440       $ret->{message} = sprintf('public key was algo "%s" (OID %s).  MSVA.pl only supports RSA',
 441                                 $cert->PubKeyAlg(), $cert->pubkey_algorithm);
 442     } else {
 443       my $key = $rsa_decoder->decode($cert->pubkey());
 444       if ($key) {
 445         # make sure that the returned integers are Math::BigInts:
 446         $key->{exponent} = Math::BigInt->new($key->{exponent}) unless (ref($key->{exponent}));
 447         $key->{modulus} = Math::BigInt->new($key->{modulus}) unless (ref($key->{modulus}));
 448         msvalog('debug', "cert info:\nmodulus: %s\nexponent: %s\n",
 449                 $key->{modulus}->as_hex(),
 450                 $key->{exponent}->as_hex(),
 451                );
 452
 453         if ($key->{modulus}->copy()->blog(2) < 1000) { # FIXME: this appears to be the full pubkey, including DER overhead
 454           $ret->{message} = sprintf('public key size is less than 1000 bits (was: %d bits)', $cert->pubkey_size());
 455         } else {
 456           $ret->{message} = sprintf('Failed to validate "%s" through the OpenPGP Web of Trust.', $uid);
 457           my $ks_checked = 0;
 458           if (get_keyserver_policy() eq 'always') {
 459             fetch_uid_from_keyserver($uid);
 460             $ks_checked = 1;
 461           }
 462           my $afterlocalpass = 0;
 463           my $foundvalid = 0;
 464           # needed because $gnupg spawns child processes
 465           $ENV{PATH} = '/usr/local/bin:/usr/bin:/bin';
 466
 467           while (1) {
 468
 469             if ($afterlocalpass) {
 470               # while loop termination condition:
 471               last if ($foundvalid || $ks_checked || get_keyserver_policy() eq 'never');
 472               fetch_uid_from_keyserver($uid);
 473               $ks_checked = 1;
 474             }
 475             foreach my $gpgkey ($gnupg->get_public_keys('='.$uid)) {
 476               my $notvalid = 1;
 477               foreach my $tryuid ($gpgkey->user_ids) {
 478                 if ($tryuid->as_string eq $uid) {
 479                   $notvalid = 0
 480                     if ($tryuid->validity eq 'f' ||
 481                         $tryuid->validity eq 'u');
 482                 }
 483               }
 484               if ($notvalid) {
 485                 msvalog('verbose', "got a key that was not fully-valid for UID %s\n", $uid);
 486               } else {
 487                 $foundvalid = 1;
 488                 if ($gpgkey->usage_flags =~ /a/) {
 489                   msvalog('verbose', "primary key 0x%s is authentication-capable\n", $gpgkey->hex_id);
 490                   if (keycomp($key, $gpgkey)) {
 491                     msvalog('verbose', "...and it matches!\n");
 492                     $ret->{valid} = JSON::true;
 493                     $ret->{message} = sprintf('Successfully validated "%s" through the OpenPGP Web of Trust.', $uid);
 494                   }
 495                 }
 496                 foreach my $subkey ($gpgkey->subkeys) {
 497                   msvalog('verbose', "subkey 0x%s is authentication-capable\n", $subkey->hex_id);
 498                   if (keycomp($key, $subkey)) {
 499                     msvalog('verbose', "...and it matches!\n");
 500                     $ret->{valid} = JSON::true;
 501                     $ret->{message} = sprintf('Successfully validated "%s" through the OpenPGP Web of Trust.', $uid);
 502                   }
 503                 }
 504               }
 505             }
 506             $afterlocalpass = 1;
 507           }
 508         }
 509       } else {
 510         msvalog('error', "failed to decode %s\n", unpack('H*', $cert->pubkey()));
 511         $ret->{message} = sprintf('failed to decode the public key', $uid);
 512       }
 513     }
 514
 515     return $status, $ret;
 516   }
 517
 518   sub child_dies {
 519     my $self = shift;
 520     my $pid = shift;
 521     my $server = shift;
 522
 523     msvalog('debug', "Subprocess %d terminated.\n", $pid);
 524
 525     if (exists $self->{child_pid} &&
 526         ($self->{child_pid} == 0 ||
 527          $self->{child_pid} == $pid)) {
 528       my $exitstatus = POSIX::WEXITSTATUS($?);
 529       msvalog('verbose', "Subprocess %d terminated; exiting %d.\n", $pid, $exitstatus);
 530       $server->set_exit_status($exitstatus);
 531       $server->server_close();
 532     }
 533   }
 534
 535   # use sparingly!  We want to keep taint mode around for the data we
 536   # get over the network.  this is only here because we want to treat
 537   # the command line arguments differently for the subprocess.
 538   sub untaint {
 539     my $x = shift;
 540     $x =~ /^(.*)$/ ;
 541     return $1;
 542   }
 543
 544   sub post_bind_hook {
 545     my $self = shift;
 546     my $server = shift;
 547
 548     my $socketcount = @{ $server->{server}->{sock} };
 549     if ( $socketcount != 1 ) {
 550       msvalog('error', "%d sockets open; should have been 1.", $socketcount);
 551       $server->set_exit_status(10);
 552       $server->server_close();
 553     }
 554     my $port = @{ $server->{server}->{sock} }[0]->sockport();
 555     if ((! defined $port) || ($port < 1) || ($port >= 65536)) {
 556       msvalog('error', "got nonsense port: %d.", $port);
 557       $server->set_exit_status(11);
 558       $server->server_close();
 559     }
 560     if ((exists $ENV{MSVA_PORT}) && (($ENV{MSVA_PORT} + 0) != $port)) {
 561       msvalog('error', "Explicitly requested port %d, but got port: %d.", ($ENV{MSVA_PORT}+0), $port);
 562       $server->set_exit_status(13);
 563       $server->server_close();
 564     }
 565     $self->port($port);
 566
 567     my $argcount = @ARGV;
 568     if ($argcount) {
 569       $self->{child_pid} = 0; # indicate that we are planning to fork.
 570       my $fork = fork();
 571       if (! defined $fork) {
 572         msvalog('error', "could not fork\n");
 573       } else {
 574         if ($fork) {
 575           msvalog('debug', "Child process has PID %d\n", $fork);
 576           $self->{child_pid} = $fork;
 577         } else {
 578           msvalog('verbose', "PID %d executing: \n", $$);
 579           for my $arg (@ARGV) {
 580             msvalog('verbose', " %s\n", $arg);
 581           }
 582           $ENV{PATH} = untaint($ENV{PATH});
 583           my @args;
 584           foreach (@ARGV) {
 585             push @args, untaint($_);
 586           }
 587           # restore default SIGCHLD handling:
 588           $SIG{CHLD} = 'DEFAULT';
 589           $ENV{MONKEYSPHERE_VALIDATION_AGENT_SOCKET} = sprintf('http://localhost:%d', $self->port);
 590           exec(@args) or exit 111;
 591         }
 592       }
 593     } else {
 594       printf("MONKEYSPHERE_VALIDATION_AGENT_SOCKET=http://localhost:%d;\nexport MONKEYSPHERE_VALIDATION_AGENT_SOCKET;\n", $self->port);
 595       # FIXME: consider daemonizing here to behave more like
 596       # ssh-agent.  maybe avoid backgrounding by setting
 597       # MSVA_NO_BACKGROUND.
 598     };
 599   }
 600
 601   sub extracerts {
 602     my $data = shift;
 603
 604     return '500 not yet implemented', { };
 605   }
 606
 607   1;
 608 }
 609
 610 my $server = MSVA->new();
 611 $server->run(host=>'localhost',
 612              log_level=>MSVA::get_log_level(),
 613              user => POSIX::geteuid(),  # explicitly choose regular user and group (avoids spew)
 614              group => POSIX::getegid(),
 615              msva=>$server);
 616 __END__
 617
 618 =head1 NAME
 619
 620 msva-perl - Perl implementation of a Monkeysphere Validation Agent
 621
 622 =head1 SYNOPSIS
 623
 624   msva-perl [ COMMAND [ ARGS ... ] ]
 625
 626 =head1 ABSTRACT
 627
 628 msva-perl provides a Perl implementation of the Monkeysphere
 629 Validation Agent, a certificate validation service.
 630
 631 =head1 INTRODUCTION
 632
 633 The Monkeysphere Validation Agent offers a local service for tools to
 634 validate certificates (both X.509 and OpenPGP) and other public keys.
 635
 636 Clients of the validation agent query it with a public key carrier (a
 637 raw public key, or some flavor of certificate), the supposed name of
 638 the remote peer offering the pubkey, and the context in which the
 639 validation check is relevant (e.g. ssh, https, etc).
 640
 641 The validation agent then tells the client whether it was able to
 642 successfully validate the peer's use of the public key in the given
 643 context.
 644
 645 msva-perl relies on monkeysphere(1), which uses the user's OpenPGP web
 646 of trust to validate the peer's use of public keys.
 647
 648 =head1 USAGE
 649
 650 Launched with no arguments, msva-perl simply runs and listens forever.
 651
 652 Launched with arguments, it sets up a listener, spawns a subprocess
 653 using the supplied command and arguments, but with the
 654 MONKEYSPHERE_VALIDATION_AGENT_SOCKET environment variable set to refer
 655 to its listener.  When the subprocess terminates, msva-perl tears down
 656 the listener and exits as well, returning the same value as the
 657 subprocess.
 658
 659 This is a similar invocation pattern to that of ssh-agent(1).
 660
 661 =head1 ENVIRONMENT VARIABLES
 662
 663 msva-perl is configured by means of environment variables.
 664
 665 =over 4
 666
 667 =item MSVA_LOG_LEVEL
 668
 669 msva-perl logs messages about its operation to stderr.  MSVA_LOG_LEVEL
 670 controls its verbosity, and should be one of (in increasing
 671 verbosity): silent, quiet, fatal, error, info, verbose, debug, debug1,
 672 debug2, debug3.  Default is 'error'.
 673
 674 =item MSVA_ALLOWED_USERS
 675
 676 If your system is capable of it, msva-perl tries to figure out the
 677 owner of the connecting client.  If MSVA_ALLOWED_USERS is unset,
 678 msva-perl will only permit connections from the user msva is running
 679 as.  If you set MSVA_ALLOWED_USERS, msva-perl will treat it as a list
 680 of local users (by name or user ID) who are allowed to connect.
 681
 682 =item MSVA_PORT
 683
 684 msva-perl listens on a local TCP socket to facilitate access.  You can
 685 choose what port to bind to by setting MSVA_PORT.  Default is to bind
 686 on an arbitrary open port.
 687
 688 =item MSVA_KEYSERVER
 689
 690 msva-perl will request information from OpenPGP keyservers.  Set
 691 MSVA_KEYSERVER to declare the keyserver you want it to check with.
 692 Default is 'hkp://pool.sks-keyservers.net'.
 693
 694 =item MSVA_KEYSERVER_POLICY
 695
 696 msva-perl must decide when to check with keyservers (for new keys,
 697 revocation certificates, new certifications, etc).  There are three
 698 possible options: 'always' means to check with the keyserver on every
 699 query it receives.  'never' means to never check with a
 700 keyserver. 'unlessvalid' will only check with the keyserver on a
 701 specific query if no keys are already locally known to be valid for
 702 the requested peer.  Default is 'unlessvalid'.
 703
 704 =back
 705
 706 =head1 COMMUNICATION PROTOCOL DETAILS
 707
 708 Communications with the Monkeysphere Validation Agent are in the form
 709 of JSON requests over plain HTTP.  Responses from the agent are also
 710 JSON objects.  For details on the structure of the requests and
 711 responses, please see
 712 http://web.monkeysphere.info/validation-agent/protocol
 713
 714 =head1 SECURITY CONSIDERATIONS
 715
 716 msva-perl deliberately binds to the loopback adapter (via named lookup
 717 of "localhost") so that remote users do not get access to the daemon.
 718 On systems (like Linux) which report ownership of TCP sockets in
 719 /proc/net/tcp, msva-perl will refuse access from random users (see
 720 MSVA_ALLOWED_USERS above).
 721
 722 =head1 SEE ALSO
 723
 724 monkeysphere(1), monkeysphere(7), ssh-agent(1)
 725
 726 =head1 BUGS AND FEEDBACK
 727
 728 Bugs or feature requests for msva-perl should be filed with the
 729 Monkeysphere project's bug tracker at
 730 https://labs.riseup.net/code/projects/monkeysphere/issues/
 731
 732 =head1 AUTHORS AND CONTRIBUTORS
 733
 734 Daniel Kahn Gillmor E<lt>dkg@fifthhorseman.net<gt>
 735
 736 The Monkeysphere Team http://web.monkeysphere.info/
 737
 738 =head1 COPYRIGHT AND LICENSE
 739
 740 Copyright © Daniel Kahn Gillmor and others from the Monkeysphere team.
 741 msva-perl is free software, distributed under the GNU Public License,
 742 version 3 or later.
 743