-{
- package MSVA;
-
- use parent qw(HTTP::Server::Simple::CGI);
- require Crypt::X509;
- use Convert::ASN1;
- use MIME::Base64;
- use IO::Socket;
- use IO::File;
- use Socket;
- use Net::Server::Fork;
-
- use JSON;
- use POSIX qw(strftime);
-
- my %dispatch = (
- '/' => { handler => \&noop,
- methods => { 'GET' => 1 },
- },
- '/reviewcert' => { handler => \&reviewcert,
- methods => { 'POST' => 1 },
- },
- '/extracerts' => { handler => \&extracerts,
- methods => { 'POST' => 1 },
- },
- );
-
- my %loglevels = (
- 'silent' => 1,
- 'quiet' => 2,
- 'fatal' => 3,
- 'error' => 4,
- 'info' => 5,
- 'verbose' => 6,
- 'debug' => 7,
- 'debug1' => 7,
- 'debug2' => 8,
- 'debug3' => 9,
- );
-
- my $rsa_decoder = Convert::ASN1->new;
- $rsa_decoder->prepare(q<
-
- SEQUENCE {
- modulus INTEGER,
- exponent INTEGER
- }
- >);
-
- sub msvalog {
- my $msglevel = shift;
-
- my $level = $loglevels{lc($ENV{MSVA_LOG_LEVEL})};
- $level = $loglevels{info} if (! defined $level);
-
- if ($loglevels{lc($msglevel)} <= $level) {
- printf STDERR @_;
- }
- };
-
- sub net_server {
- return 'Net::Server::Fork';
- };
-
- sub new {
- my $class = shift;
-
- my $port = 8901;
- if (exists $ENV{MSVA_PORT}) {
- $port = $ENV{MSVA_PORT} + 0;
- die sprintf("not a reasonable port %d", $port) if (($port >= 65536) || $port <= 0);
- }
- # start the server on port 8901
- my $self = $class->SUPER::new($port);
-
- $self->{allowed_uids} = {};
- if (exists $ENV{MSVA_ALLOWED_USERS}) {
- msvalog('verbose', "MSVA_ALLOWED_USERS environment variable is set.\nLimiting access to specified users.\n");
- foreach my $user (split(/ +/, $ENV{MSVA_ALLOWED_USERS})) {
- my ($name, $passwd, $uid);
- if ($user =~ /^[0-9]+$/) {
- $uid = $user + 0; # force to integer
- } else {
- ($name,$passwd,$uid) = getpwnam($user);
- }
- if (defined $uid) {
- msvalog('verbose', "Allowing access from user ID %d\n", $uid);
- $self->{allowed_uids}->{$uid} = $user;
- } else {
- msvalog('error', "Could not find user '%d'; not allowing\n", $user);
- }
- }
- } else {
- # default is to allow access only to the current user
- $self->{allowed_uids}->{POSIX::getuid()} = 'self';
- }
-
- bless ($self, $class);
- return $self;
- }
-
- sub noop {
- my $self = shift;
- my $cgi = shift;
- return '200 OK', { available => JSON::true,
- protoversion => 1,
- server => "MSVA-Perl 0.1" };
- }
-
- # returns an empty list if bad key found.
- sub parse_openssh_pubkey {
- my $data = shift;
- my ($label, $prop) = split(/ +/, $data);
- $prop = decode_base64($prop) or return ();
-
- msvalog('debug', "key properties: %s\n", unpack('H*', $prop));
- my @out;
- while (length($prop) > 4) {
- my $size = unpack('N', substr($prop, 0, 4));
- msvalog('debug', "size: 0x%08x\n", $size);
- return () if (length($prop) < $size + 4);
- push(@out, substr($prop, 4, $size));
- $prop = substr($prop, 4 + $size);
- }
- return () if ($label ne $out[0]);
- return @out;
- }
-
- # return the numeric ID of the peer on the other end of $socket,
- # returning undef if unknown.
- sub get_remote_peer_id {
- my $socket = shift;
-
- my $sock = IO::Socket->new_from_fd($socket, 'r');
- # check SO_PEERCRED -- if this was a TCP socket, Linux
- # might not be able to support SO_PEERCRED (even on the loopback),
- # though apparently some kernels (Solaris?) are able to.
-
- my $remotepeerid;
- my $socktype = $sock->sockopt(SO_TYPE) or die "could not get SO_TYPE info";
- if (defined $socktype) {
- msvalog('debug', "sockopt(SO_TYPE) = %d\n", $socktype);
- } else {
- msvalog('verbose', "sockopt(SO_TYPE) returned undefined.\n");
- }
-
- my $peercred = $sock->sockopt(SO_PEERCRED) or die "could not get SO_PEERCRED info";
- my $remotepeer = $sock->peername();
- my $family = sockaddr_family($remotepeer); # should be AF_UNIX (a.k.a. AF_LOCAL) or AF_INET
-
- msvalog('verbose', "socket family: %d\nsocket type: %d\n", $family, $socktype);
-
- if ($peercred) {
- # FIXME: on i386 linux, this appears to be three ints, according to
- # /usr/include/linux/socket.h. What about other platforms?
- my ($pid, $uid, $gid) = unpack('iii', $peercred);
-
- msvalog('verbose', "SO_PEERCRED: pid: %u, uid: %u, gid: %u\n",
- $pid, $uid, $gid,
- );
- if ($pid != 0 && $uid != 0) { # then we can accept it:
- $remotepeerid = $uid;
- }
- }
-
- # another option in Linux would be to parse the contents of
- # /proc/net/tcp to find the uid of the peer process based on that
- # information.
- if (! defined $remotepeerid) {
- my $proto;
- if ($family == AF_INET) {
- $proto = '';
- } elsif ($family == AF_INET6) {
- $proto = '6';
- }
- if (defined $proto) {
- if ($socktype == &SOCK_STREAM) {
- $proto = 'tcp'.$proto;
- } elsif ($socktype == &SOCK_DGRAM) {
- $proto = 'udp'.$proto;
- } else {
- undef $proto;
- }
- if (defined $proto) {
- my ($port, $iaddr) = unpack_sockaddr_in($remotepeer);
- my $iaddrstring = unpack("H*", reverse($iaddr));
- msvalog('verbose', "Port: %04x\nAddr: %s\n", $port, $iaddrstring);
- my $remmatch = lc(sprintf("%s:%04x", $iaddrstring, $port));
- my $infofile = '/proc/net/'.$proto;
- my $f = new IO::File;
- if ( $f->open('< '.$infofile)) {
- my @header = split(/ +/, <$f>);
- my ($localaddrix, $uidix);
- my $ix = 0;
- my $skipcount = 0;
- while ($ix <= $#header) {
- $localaddrix = $ix - $skipcount if (lc($header[$ix]) eq 'local_address');
- $uidix = $ix - $skipcount if (lc($header[$ix]) eq 'uid');
- $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
- $ix++;
- }
- if (!defined $localaddrix) {
- msvalog('info', "Could not find local_address field in %s; unable to determine peer UID\n",
- $infofile);
- } elsif (!defined $uidix) {
- msvalog('info', "Could not find uid field in %s; unable to determine peer UID\n",
- $infofile);
- } else {
- msvalog('debug', "local_address: %d; uid: %d\n", $localaddrix,$uidix);
- while (my @line = split(/ +/,<$f>)) {
- if (lc($line[$localaddrix]) eq $remmatch) {
- if (defined $remotepeerid) {
- msvalog('error', "Warning! found more than one remote uid! (%s and %s\n", $remotepeerid, $line[$uidix]);
- } else {
- $remotepeerid = $line[$uidix];
- msvalog('info', "remote peer is uid %d\n",
- $remotepeerid);
- }
- }
- }
- msvalog('error', "Warning! could not find peer information in %s. Not verifying.\n", $infofile) unless defined $remotepeerid;
- }
- } else { # FIXME: we couldn't read the file. what should we
- # do besides warning?
- msvalog('info', "Could not read %s; unable to determine peer UID\n",
- $infofile);
- }
- }
- }
- }
- return $remotepeerid;
- }
-
- sub handle_request {
- my $self = shift;
- my $cgi = shift;
-
- my $remotepeerid = get_remote_peer_id(select);
-
- if (defined $remotepeerid) {
- # test that this is an allowed user:
- if (exists $self->{allowed_uids}->{$remotepeerid}) {
- msvalog('verbose', "Allowing access from uid %d (%s)\n", $remotepeerid, $self->{allowed_uids}->{$remotepeerid});
- } else {
- msvalog('error', "MSVA client connection from uid %d, forbidden.\n", $remotepeerid);
- 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",
- strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())),);
- return;
- }
- }
-
- my $path = $cgi->path_info();
- my $handler = $dispatch{$path};
-
- if (ref($handler) eq "HASH") {
- if (! exists $handler->{methods}->{$cgi->request_method()}) {
- printf("HTTP/1.0 405 Method not allowed\r\nAllow: %s\r\nDate: %s\r\n",
- join(', ', keys(%{$handler->{methods}})),
- strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())));
- } elsif (ref($handler->{handler}) ne "CODE") {
- printf("HTTP/1.0 500 Server Error\r\nDate: %s\r\n",
- strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())));
- } else {
- my $data = {};
- my $ctype = $cgi->content_type();
- msvalog('verbose', "Got %s %s (Content-Type: %s)\n", $cgi->request_method(), $path, defined $ctype ? $ctype : '**none supplied**');
- if (defined $ctype) {
- my @ctypes = split(/; */, $ctype);
- $ctype = shift @ctypes;
- if ($ctype eq 'application/json') {
- $data = from_json($cgi->param('POSTDATA'));
- }
- };
-
- my ($status, $object) = $handler->{handler}($data);
- my $ret = to_json($object);
- msvalog('info', "returning: %s\n", $ret);
- printf("HTTP/1.0 %s\r\nDate: %s\r\nContent-Type: application/json\r\n\r\n%s",
- $status,
- strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())),
- $ret);
- }
- } else {
- 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",
- strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())),
- $path, ' * '.join("\r\n * ", keys %dispatch) );
- }
- }
-
-
-
- sub reviewcert {
- my $data = shift;
- return if !ref $data;
-
- my $uid = $data->{context}.'://'.$data->{peer};
-
- my $rawdata = join('', map(chr, @{$data->{pkc}->{data}}));
- my $cert = Crypt::X509->new(cert => $rawdata);
- msvalog('verbose', "cert subject: %s\n", $cert->subject_cn());
- msvalog('verbose', "cert issuer: %s\n", $cert->issuer_cn());
- msvalog('verbose', "cert pubkey algo: %s\n", $cert->PubKeyAlg());
- msvalog('verbose', "cert pubkey: %s\n", unpack('H*', $cert->pubkey()));
-
- my $status = '200 OK';
- my $ret = { valid => JSON::false,
- message => 'Unknown failure',
- };
- if ($cert->PubKeyAlg() ne 'RSA') {
- $ret->{message} = sprintf('public key was algo "%s" (OID %s). MSVA.pl only supports RSA',
- $cert->PubKeyAlg(), $cert->pubkey_algorithm);
- } else {
- my $key = $rsa_decoder->decode($cert->pubkey());
- if ($key) {
- # make sure that the returned integers are Math::BigInts:
- $key->{exponent} = Math::BigInt->new($key->{exponent}) unless (ref($key->{exponent}));
- $key->{modulus} = Math::BigInt->new($key->{modulus}) unless (ref($key->{modulus}));
- msvalog('debug', "cert info:\nmodulus: %s\nexponent: %s\n",
- $key->{modulus}->as_hex(),
- $key->{exponent}->as_hex(),
- );
-
- if ($key->{modulus}->copy()->blog(2) < 1000) { # FIXME: this appears to be the full pubkey, including DER overhead
- $ret->{message} = sprintf('public key size is less than 1000 bits (was: %d bits)', $cert->pubkey_size());
- } else {
- $ret->{message} = sprintf('Failed to validate "%s" through the OpenPGP Web of Trust.', $uid);
-
- my $fh;
- # clean up the path for taint-check mode:
- $ENV{PATH} = '/usr/local/bin:/usr/bin:/bin';
-
- open($fh, '-|', 'monkeysphere', 'keys-for-userid', $uid);
- while(<$fh>) {
- my @keyinfo = parse_openssh_pubkey($_);
- if (scalar(@keyinfo) != 3 || $keyinfo[0] ne "ssh-rsa") {
- msvalog('info', "got unknown or non-RSA key from monkeysphere\n");
- next;
- }
- msvalog('verbose', "got good RSA key from monkeysphere: \nExponent: 0x%s\nModulus: 0x%s\n", unpack('H*', $keyinfo[1]), unpack('H*', $keyinfo[2]));
- if ($key->{exponent}->bcmp(Math::BigInt->new('0x'.unpack('H*', $keyinfo[1]))) == 0 &&
- $key->{modulus}->bcmp(Math::BigInt->new('0x'.unpack('H*', $keyinfo[2]))) == 0) {
- msvalog('verbose', "...and it matches!\n");
- $ret->{valid} = JSON::true;
- $ret->{message} = sprintf('Successfully validated "%s" through the OpenPGP Web of Trust.', $uid);
- }
- }
- }
- } else {
- msvalog('error', "failed to decode %s\n", unpack('H*', $cert->pubkey()));
- $ret->{message} = sprintf('failed to decode the public key', $uid);
- }
- }
-
- return $status, $ret;
- }
-
- sub extracerts {
- my $data = shift;
-
- return '500 not yet implemented', { };
- }
-
- 1;
-}
-
-my $server = MSVA->new();
-$server->run(host=>'localhost');
projects / monkeysphere-validation-agent.git / blobdiff