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