msva

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