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 Convert::ASN1;
  27   use MIME::Base64;
  28   use IO::Socket;
  29   use IO::File;
  30   use Socket;
  31
  32   use JSON;
  33   use POSIX qw(strftime);
  34
  35   my $version = '0.1';
  36
  37   my %dispatch = (
  38                   '/' => { handler => \&noop,
  39                            methods => { 'GET' => 1 },
  40                          },
  41                   '/reviewcert' => { handler => \&reviewcert,
  42                                      methods => { 'POST' => 1 },
  43                                    },
  44                   '/extracerts' => { handler => \&extracerts,
  45                                      methods => { 'POST' => 1 },
  46                                    },
  47                  );
  48
  49 # Net::Server log_level goes from 0 to 4
  50 # this is scaled to match.
  51   my %loglevels = (
  52                    'silent' => 0,
  53                    'quiet' => 0.25,
  54                    'fatal' => 0.5,
  55                    'error' => 1,
  56                    'info' => 2,
  57                    'verbose' => 3,
  58                    'debug' => 4,
  59                    'debug1' => 4,
  60                    'debug2' => 5,
  61                    'debug3' => 6,
  62                   );
  63
  64   my $rsa_decoder = Convert::ASN1->new;
  65   $rsa_decoder->prepare(q<
  66
  67    SEQUENCE {
  68         modulus INTEGER,
  69         exponent INTEGER
  70    }
  71           >);
  72
  73   sub msvalog {
  74     my $msglevel = shift;
  75
  76     my $level = $loglevels{lc($ENV{MSVA_LOG_LEVEL})};
  77     $level = $loglevels{info} if (! defined $level);
  78
  79     if ($loglevels{lc($msglevel)} <= $level) {
  80       printf STDERR @_;
  81     }
  82   };
  83
  84   sub get_log_level {
  85     my $level = $loglevels{lc($ENV{MSVA_LOG_LEVEL})};
  86     $level = $loglevels{info} if (! defined $level);
  87     return $level;
  88   }
  89
  90   sub net_server {
  91     return 'Net::Server::MSVA';
  92   };
  93
  94   sub new {
  95     my $class = shift;
  96
  97     my $port = 8901;
  98     if (exists $ENV{MSVA_PORT}) {
  99       $port = $ENV{MSVA_PORT} + 0;
 100       die sprintf("not a reasonable port %d", $port) if (($port >= 65536) || $port <= 0);
 101     }
 102     # start the server on port 8901
 103     my $self = $class->SUPER::new($port);
 104
 105     $self->{allowed_uids} = {};
 106     if (exists $ENV{MSVA_ALLOWED_USERS}) {
 107       msvalog('verbose', "MSVA_ALLOWED_USERS environment variable is set.\nLimiting access to specified users.\n");
 108       foreach my $user (split(/ +/, $ENV{MSVA_ALLOWED_USERS})) {
 109         my ($name, $passwd, $uid);
 110         if ($user =~ /^[0-9]+$/) {
 111           $uid = $user + 0; # force to integer
 112         } else {
 113           ($name,$passwd,$uid) = getpwnam($user);
 114         }
 115         if (defined $uid) {
 116           msvalog('verbose', "Allowing access from user ID %d\n", $uid);
 117           $self->{allowed_uids}->{$uid} = $user;
 118         } else {
 119           msvalog('error', "Could not find user '%d'; not allowing\n", $user);
 120         }
 121       }
 122     } else {
 123       # default is to allow access only to the current user
 124       $self->{allowed_uids}->{POSIX::getuid()} = 'self';
 125     }
 126
 127     bless ($self, $class);
 128     return $self;
 129   }
 130
 131   sub noop {
 132     my $self = shift;
 133     my $cgi = shift;
 134     return '200 OK', { available => JSON::true,
 135                        protoversion => 1,
 136                        server => "MSVA-Perl ".$version };
 137   }
 138
 139   # returns an empty list if bad key found.
 140   sub parse_openssh_pubkey {
 141     my $data = shift;
 142     my ($label, $prop) = split(/ +/, $data);
 143     $prop = decode_base64($prop) or return ();
 144
 145     msvalog('debug', "key properties: %s\n", unpack('H*', $prop));
 146     my @out;
 147     while (length($prop) > 4) {
 148       my $size = unpack('N', substr($prop, 0, 4));
 149       msvalog('debug', "size: 0x%08x\n", $size);
 150       return () if (length($prop) < $size + 4);
 151       push(@out, substr($prop, 4, $size));
 152       $prop = substr($prop, 4 + $size);
 153     }
 154     return () if ($label ne $out[0]);
 155     return @out;
 156   }
 157
 158   # return the numeric ID of the peer on the other end of $socket,
 159   # returning undef if unknown.
 160   sub get_remote_peer_id {
 161     my $socket = shift;
 162
 163     my $sock = IO::Socket->new_from_fd($socket, 'r');
 164     # check SO_PEERCRED -- if this was a TCP socket, Linux
 165     # might not be able to support SO_PEERCRED (even on the loopback),
 166     # though apparently some kernels (Solaris?) are able to.
 167
 168     my $remotepeerid;
 169     my $socktype = $sock->sockopt(SO_TYPE) or die "could not get SO_TYPE info";
 170     if (defined $socktype) {
 171       msvalog('debug', "sockopt(SO_TYPE) = %d\n", $socktype);
 172     } else {
 173       msvalog('verbose', "sockopt(SO_TYPE) returned undefined.\n");
 174     }
 175
 176     my $peercred = $sock->sockopt(SO_PEERCRED) or die "could not get SO_PEERCRED info";
 177     my $remotepeer = $sock->peername();
 178     my $family = sockaddr_family($remotepeer); # should be AF_UNIX (a.k.a. AF_LOCAL) or AF_INET
 179
 180     msvalog('verbose', "socket family: %d\nsocket type: %d\n", $family, $socktype);
 181
 182     if ($peercred) {
 183       # FIXME: on i386 linux, this appears to be three ints, according to
 184       # /usr/include/linux/socket.h.  What about other platforms?
 185       my ($pid, $uid, $gid) = unpack('iii', $peercred);
 186
 187       msvalog('verbose', "SO_PEERCRED: pid: %u, uid: %u, gid: %u\n",
 188               $pid, $uid, $gid,
 189              );
 190       if ($pid != 0 && $uid != 0) { # then we can accept it:
 191         $remotepeerid = $uid;
 192       }
 193     }
 194
 195     # another option in Linux would be to parse the contents of
 196     # /proc/net/tcp to find the uid of the peer process based on that
 197     # information.
 198     if (! defined $remotepeerid) {
 199       my $proto;
 200       if ($family == AF_INET) {
 201         $proto = '';
 202       } elsif ($family == AF_INET6) {
 203         $proto = '6';
 204       }
 205       if (defined $proto) {
 206         if ($socktype == &SOCK_STREAM) {
 207           $proto = 'tcp'.$proto;
 208         } elsif ($socktype == &SOCK_DGRAM) {
 209           $proto = 'udp'.$proto;
 210         } else {
 211           undef $proto;
 212         }
 213         if (defined $proto) {
 214           my ($port, $iaddr) = unpack_sockaddr_in($remotepeer);
 215           my $iaddrstring = unpack("H*", reverse($iaddr));
 216           msvalog('verbose', "Port: %04x\nAddr: %s\n", $port, $iaddrstring);
 217           my $remmatch = lc(sprintf("%s:%04x", $iaddrstring, $port));
 218           my $infofile = '/proc/net/'.$proto;
 219           my $f = new IO::File;
 220           if ( $f->open('< '.$infofile)) {
 221             my @header = split(/ +/, <$f>);
 222             my ($localaddrix, $uidix);
 223             my $ix = 0;
 224             my $skipcount = 0;
 225             while ($ix <= $#header) {
 226               $localaddrix = $ix - $skipcount if (lc($header[$ix]) eq 'local_address');
 227               $uidix = $ix - $skipcount if (lc($header[$ix]) eq 'uid');
 228               $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
 229               $ix++;
 230             }
 231             if (!defined $localaddrix) {
 232               msvalog('info', "Could not find local_address field in %s; unable to determine peer UID\n",
 233                       $infofile);
 234             } elsif (!defined $uidix) {
 235               msvalog('info', "Could not find uid field in %s; unable to determine peer UID\n",
 236                       $infofile);
 237             } else {
 238               msvalog('debug', "local_address: %d; uid: %d\n", $localaddrix,$uidix);
 239               while (my @line = split(/ +/,<$f>)) {
 240                 if (lc($line[$localaddrix]) eq $remmatch) {
 241                   if (defined $remotepeerid) {
 242                     msvalog('error', "Warning! found more than one remote uid! (%s and %s\n", $remotepeerid, $line[$uidix]);
 243                   } else {
 244                     $remotepeerid = $line[$uidix];
 245                     msvalog('info', "remote peer is uid %d\n",
 246                             $remotepeerid);
 247                   }
 248                 }
 249               }
 250             msvalog('error', "Warning! could not find peer information in %s.  Not verifying.\n", $infofile) unless defined $remotepeerid;
 251             }
 252           } else { # FIXME: we couldn't read the file.  what should we
 253                    # do besides warning?
 254             msvalog('info', "Could not read %s; unable to determine peer UID\n",
 255                     $infofile);
 256           }
 257         }
 258       }
 259     }
 260     return $remotepeerid;
 261   }
 262
 263   sub handle_request {
 264     my $self = shift;
 265     my $cgi  = shift;
 266
 267     my $remotepeerid =  get_remote_peer_id(select);
 268
 269     if (defined $remotepeerid) {
 270       # test that this is an allowed user:
 271       if (exists $self->{allowed_uids}->{$remotepeerid}) {
 272         msvalog('verbose', "Allowing access from uid %d (%s)\n", $remotepeerid, $self->{allowed_uids}->{$remotepeerid});
 273       } else {
 274         msvalog('error', "MSVA client connection from uid %d, forbidden.\n", $remotepeerid);
 275         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",
 276                strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())),);
 277         return;
 278       }
 279     }
 280
 281     my $path = $cgi->path_info();
 282     my $handler = $dispatch{$path};
 283
 284     if (ref($handler) eq "HASH") {
 285       if (! exists $handler->{methods}->{$cgi->request_method()}) {
 286         printf("HTTP/1.0 405 Method not allowed\r\nAllow: %s\r\nDate: %s\r\n",
 287                join(', ', keys(%{$handler->{methods}})),
 288                strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())));
 289       } elsif (ref($handler->{handler}) ne "CODE") {
 290         printf("HTTP/1.0 500 Server Error\r\nDate: %s\r\n",
 291                strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())));
 292       } else {
 293         my $data = {};
 294         my $ctype = $cgi->content_type();
 295         msvalog('verbose', "Got %s %s (Content-Type: %s)\n", $cgi->request_method(), $path, defined $ctype ? $ctype : '**none supplied**');
 296         if (defined $ctype) {
 297           my @ctypes = split(/; */, $ctype);
 298           $ctype = shift @ctypes;
 299           if ($ctype eq 'application/json') {
 300             $data = from_json($cgi->param('POSTDATA'));
 301           }
 302         };
 303
 304         my ($status, $object) = $handler->{handler}($data);
 305         my $ret = to_json($object);
 306         msvalog('info', "returning: %s\n", $ret);
 307         printf("HTTP/1.0 %s\r\nDate: %s\r\nContent-Type: application/json\r\n\r\n%s",
 308                $status,
 309                strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())),
 310                $ret);
 311       }
 312     } else {
 313       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",
 314              strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())),
 315              $path, ' * '.join("\r\n * ", keys %dispatch) );
 316     }
 317   }
 318
 319
 320
 321   sub reviewcert {
 322     my $data  = shift;
 323     return if !ref $data;
 324
 325     my $uid = $data->{context}.'://'.$data->{peer};
 326
 327     my $rawdata = join('', map(chr, @{$data->{pkc}->{data}}));
 328     my $cert = Crypt::X509->new(cert => $rawdata);
 329     msvalog('verbose', "cert subject: %s\n", $cert->subject_cn());
 330     msvalog('verbose', "cert issuer: %s\n", $cert->issuer_cn());
 331     msvalog('verbose', "cert pubkey algo: %s\n", $cert->PubKeyAlg());
 332     msvalog('verbose', "cert pubkey: %s\n", unpack('H*', $cert->pubkey()));
 333
 334     my $status = '200 OK';
 335     my $ret =  { valid => JSON::false,
 336                  message => 'Unknown failure',
 337                };
 338     if ($cert->PubKeyAlg() ne 'RSA') {
 339       $ret->{message} = sprintf('public key was algo "%s" (OID %s).  MSVA.pl only supports RSA',
 340                                 $cert->PubKeyAlg(), $cert->pubkey_algorithm);
 341     } else {
 342       my $key = $rsa_decoder->decode($cert->pubkey());
 343       if ($key) {
 344         # make sure that the returned integers are Math::BigInts:
 345         $key->{exponent} = Math::BigInt->new($key->{exponent}) unless (ref($key->{exponent}));
 346         $key->{modulus} = Math::BigInt->new($key->{modulus}) unless (ref($key->{modulus}));
 347         msvalog('debug', "cert info:\nmodulus: %s\nexponent: %s\n",
 348                 $key->{modulus}->as_hex(),
 349                 $key->{exponent}->as_hex(),
 350                );
 351
 352         if ($key->{modulus}->copy()->blog(2) < 1000) { # FIXME: this appears to be the full pubkey, including DER overhead
 353           $ret->{message} = sprintf('public key size is less than 1000 bits (was: %d bits)', $cert->pubkey_size());
 354         } else {
 355           $ret->{message} = sprintf('Failed to validate "%s" through the OpenPGP Web of Trust.', $uid);
 356
 357           my $fh;
 358           # clean up the path for taint-check mode:
 359           $ENV{PATH} = '/usr/local/bin:/usr/bin:/bin';
 360
 361           open($fh, '-|', 'monkeysphere', 'keys-for-userid', $uid);
 362           while(<$fh>) {
 363             my @keyinfo = parse_openssh_pubkey($_);
 364             if (scalar(@keyinfo) != 3 || $keyinfo[0] ne "ssh-rsa") {
 365               msvalog('info', "got unknown or non-RSA key from monkeysphere\n");
 366               next;
 367             }
 368             msvalog('verbose', "got good RSA key from monkeysphere: \nExponent: 0x%s\nModulus: 0x%s\n", unpack('H*', $keyinfo[1]), unpack('H*', $keyinfo[2]));
 369             if ($key->{exponent}->bcmp(Math::BigInt->new('0x'.unpack('H*', $keyinfo[1]))) == 0 &&
 370                 $key->{modulus}->bcmp(Math::BigInt->new('0x'.unpack('H*', $keyinfo[2]))) == 0) {
 371               msvalog('verbose', "...and it matches!\n");
 372               $ret->{valid} = JSON::true;
 373               $ret->{message} = sprintf('Successfully validated "%s" through the OpenPGP Web of Trust.', $uid);
 374             }
 375           }
 376         }
 377       } else {
 378         msvalog('error', "failed to decode %s\n", unpack('H*', $cert->pubkey()));
 379         $ret->{message} = sprintf('failed to decode the public key', $uid);
 380       }
 381     }
 382
 383     return $status, $ret;
 384   }
 385
 386   sub child_dies {
 387     my $self = shift;
 388     my $pid = shift;
 389     my $server = shift;
 390
 391     msvalog('debug', "Subprocess %d terminated.\n", $pid);
 392
 393     if (exists $self->{child_pid} &&
 394         ($self->{child_pid} == 0 ||
 395          $self->{child_pid} == $pid)) {
 396       my $exitstatus = POSIX::WEXITSTATUS($?);
 397       msvalog('verbose', "Subprocess %d terminated; exiting %d.\n", $pid, $exitstatus);
 398       $server->set_exit_status($exitstatus);
 399       $server->server_close();
 400     }
 401   }
 402
 403   # use sparingly!  We want to keep taint mode around for the data we
 404   # get over the network.  this is only here because we want to treat
 405   # the command line arguments differently for the subprocess.
 406   sub untaint {
 407     my $x = shift;
 408     $x =~ /^(.*)$/ ;
 409     return $1;
 410   }
 411
 412   sub post_bind_hook {
 413     my $self = shift;
 414
 415     my $argcount = @ARGV;
 416     if ($argcount) {
 417       $self->{child_pid} = 0; # indicate that we are planning to fork.
 418       my $fork = fork();
 419       if (! defined $fork) {
 420         msvalog('error', "could not fork\n");
 421       } else {
 422         if ($fork) {
 423           msvalog('debug', "Child process has PID %d\n", $fork);
 424           $self->{child_pid} = $fork;
 425         } else {
 426           msvalog('verbose', "PID %d executing: \n", $$);
 427           for my $arg (@ARGV) {
 428             msvalog('verbose', " %s\n", $arg);
 429           }
 430           $ENV{PATH} = untaint($ENV{PATH});
 431           my @args;
 432           foreach (@ARGV) {
 433             push @args, untaint($_);
 434           }
 435           $ENV{MONKEYSPHERE_VALIDATION_AGENT_SOCKET} = sprintf('http://localhost:%d', $self->port);
 436           exec(@args) or exit 111;
 437         }
 438       }
 439     };
 440   }
 441
 442   sub extracerts {
 443     my $data = shift;
 444
 445     return '500 not yet implemented', { };
 446   }
 447
 448   1;
 449 }
 450
 451 my $server = MSVA->new();
 452 $server->run(host=>'localhost',
 453              log_level=>MSVA::get_log_level(),
 454              user => $>,  # explicitly choose regular user (avoids a warning)
 455              msva=>$server);
 456 __END__
 457
 458 =head1 NAME
 459
 460 msva-perl - Perl implementation of a Monkeysphere Validation Agent
 461
 462 =head1 SYNOPSIS
 463
 464   msva-perl [ COMMAND [ ARGS ... ] ]
 465
 466 =head1 ABSTRACT
 467
 468 msva-perl provides a Perl implementation of the Monkeysphere
 469 Validation Agent, a certificate validation service.
 470
 471 =head1 INTRODUCTION
 472
 473 The Monkeysphere Validation Agent offers a local service for tools to
 474 validate certificates (both X.509 and OpenPGP) and other public keys.
 475
 476 Clients of the validation agent query it with a public key carrier (a
 477 raw public key, or some flavor of certificate), the supposed name of
 478 the remote peer offering the pubkey, and the context in which the
 479 validation check is relevant (e.g. ssh, https, etc).
 480
 481 The validation agent then tells the client whether it was able to
 482 successfully validate the peer's use of the public key in the given
 483 context.
 484
 485 msva-perl relies on monkeysphere(1), which uses the user's OpenPGP web
 486 of trust to validate the peer's use of public keys.
 487
 488 =head1 USAGE
 489
 490 Launched with no arguments, msva-perl simply runs and listens forever.
 491
 492 Launched with arguments, it sets up a listener, spawns a subprocess
 493 using the supplied command and arguments, but with the
 494 MONKEYSPHERE_VALIDATION_AGENT_SOCKET environment variable set to refer
 495 to its listener.  When the subprocess terminates, msva-perl tears down
 496 the listener and exits as well, returning the same value as the
 497 subprocess.
 498
 499 This is a similar invocation pattern to that of ssh-agent(1).
 500
 501 =head1 ENVIRONMENT VARIABLES
 502
 503 msva-perl is configured by means of environment variables.
 504
 505 =over 4
 506
 507 =item MSVA_LOG_LEVEL
 508
 509 msva-perl logs messages about its operation to stderr.  MSVA_LOG_LEVEL
 510 controls its verbosity, and should be one of (in increasing
 511 verbosity): silent, quiet, fatal, error, info, verbose, debug, debug1,
 512 debug2, debug3.  Default is 'info'.
 513
 514 =item MSVA_ALLOWED_USERS
 515
 516 If your system is capable of it, msva-perl tries to figure out the
 517 owner of the connecting client.  If MSVA_ALLOWED_USERS is unset,
 518 msva-perl will only permit connections from the user msva is running
 519 as.  If you set MSVA_ALLOWED_USERS, msva-perl will treat it as a list
 520 of local users (by name or user ID) who are allowed to connect.
 521
 522 =item MSVA_PORT
 523
 524 msva-perl listens on a local TCP socket to facilitate access.  You can
 525 choose what port to bind to by setting MSVA_PORT.  Default is 8901.
 526
 527 =back
 528
 529 =head1 COMMUNICATION PROTOCOL DETAILS
 530
 531 Communications with the Monkeysphere Validation Agent are in the form
 532 of JSON requests over plain HTTP.  Responses from the agent are also
 533 JSON objects.  For details on the structure of the requests and
 534 responses, please see
 535 http://web.monkeysphere.info/validation-agent/protocol
 536
 537 =head1 SECURITY CONSIDERATIONS
 538
 539 msva-perl deliberately binds to the loopback adapter (via named lookup
 540 of "localhost") so that remote users do not get access to the daemon.
 541 On systems (like Linux) which report ownership of TCP sockets in
 542 /proc/net/tcp, msva-perl will refuse access from random users (see
 543 MSVA_ALLOWED_USERS above).
 544
 545 =head1 SEE ALSO
 546
 547 monkeysphere(1), monkeysphere(7), ssh-agent(1)
 548
 549 =head1 BUGS AND FEEDBACK
 550
 551 Bugs or feature requests for msva-perl should be filed with the
 552 Monkeysphere project's bug tracker at
 553 https://labs.riseup.net/code/projects/monkeysphere/issues/
 554
 555 =head1 AUTHORS AND CONTRIBUTORS
 556
 557 Daniel Kahn Gillmor E<lt>dkg@fifthhorseman.net<gt>
 558
 559 The Monkeysphere Team http://web.monkeysphere.info/
 560
 561 =head1 COPYRIGHT AND LICENSE
 562
 563 Copyright © Daniel Kahn Gillmor and others from the Monkeysphere team.
 564 msva-perl is free software, distributed under the GNU Public License,
 565 version 3 or later.
 566