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