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