#!/usr/bin/perl -wT
+# Monkeysphere Validation Agent, Perl version
+# Copyright © 2010 Daniel Kahn Gillmor <dkg@fifthhorseman.net>
+#
+# This program is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/>.
+
use warnings;
use strict;
{
package MSVA;
- use HTTP::Server::Simple::CGI;
- use base qw(HTTP::Server::Simple::CGI);
- use warnings;
- use strict;
+ 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 = (
- '/reviewcert' => \&reviewcert,
- '/extracerts' => \&extracerts,
+ '/' => { 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};
- # FIXME: ensure that this is a POST
- if (ref($handler) eq "CODE") {
- printf STDERR ("Got POST %s\n", $path);
- my ($status, $object) = $handler->($cgi);
- printf("HTTP/1.0 %s\r\nContent-Type: application/json\r\n\r\n%s", $status, to_json ($object));
+ 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 400 Bad Request -- not handled by Monkeysphere validation agent\r\nContent-Type: text/plain\r\n\r\nBad Request -- 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", $path, ' * '.join("\r\n * ", keys %dispatch) );
+ 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 $cgi = shift; # CGI.pm object
- return if !ref $cgi;
+ my $data = shift;
+ return if !ref $data;
- # FIXME: these should be opening up a json blob instead of using CGI params.
- my $uid = $cgi->param('uid');
- my $pkc = $cgi->param('pkc');
- my $context = $cgi->param('context');
+ my $uid = $data->{context}.'://'.$data->{peer};
- my $ret = { foo => 'bar' };
- # my $status = '404 no match found for the public key in this certificate';
- # or:
- my $status = '200 match found, authentication details to follow';
+ 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 $cgi = shift;
+ my $data = shift;
return '500 not yet implemented', { };
}
+
+ 1;
}
-# start the server on port 8080
-my $server = MSVA->new(8901);
-$server->run();
+my $server = MSVA->new();
+$server->run(host=>'localhost');
+__END__
+
+=head1 NAME
+
+msva-perl - Perl implementation of a Monkeysphere Validation Agent
+
+=head1 SYNOPSIS
+
+ msva-perl
+
+=head1 ABSTRACT
+
+msva-perl provides a Perl implementation of the Monkeysphere
+Validation Agent, a certificate validation service.
+
+=head1 INTRODUCTION
+
+The Monkeysphere Validation Agent offers a local service for tools to
+validate certificates (both X.509 and OpenPGP) and other public keys.
+
+Clients of the validation agent query it with a public key carrier (a
+raw public key, or some flavor of certificate), the supposed name of
+the remote peer offering the pubkey, and the context in which the
+validation check is relevant (e.g. ssh, https, etc).
+
+The validation agent then tells the client whether it was able to
+successfully validate the peer's use of the public key in the given
+context.
+
+msva-perl relies on monkeysphere(1), which uses the user's OpenPGP web
+of trust to validate the peer's use of public keys.
+
+=head1 ENVIRONMENT VARIABLES
+
+msva-perl is configured by means of environment variables.
+
+=over 4
+
+=item MSVA_LOG_LEVEL
+
+msva-perl logs messages about its operation to stderr. MSVA_LOG_LEVEL
+controls its verbosity, and should be one of (in increasing
+verbosity): silent, quiet, fatal, error, info, verbose, debug, debug1,
+debug2, debug3. Default is 'info'.
+
+=item MSVA_ALLOWED_USERS
+
+If your system is capable of it, msva-perl tries to figure out the
+owner of the connecting client. If MSVA_ALLOWED_USERS is unset,
+msva-perl will only permit connections from the user msva is running
+as. If you set MSVA_ALLOWED_USERS, msva-perl will treat it as a list
+of local users (by name or user ID) who are allowed to connect.
+
+=item MSVA_PORT
+
+msva-perl listens on a local TCP socket to facilitate access. You can
+choose what port to bind to by setting MSVA_PORT. Default is 8901.
+
+=head1 COMMUNICATION PROTOCOL DETAILS
+
+Communications with the Monkeysphere Validation Agent are in the form
+of JSON requests over plain HTTP. Responses from the agent are also
+JSON objects. For details on the structure of the requests and
+responses, please see
+http://web.monkeysphere.info/validation-agent/protocol
+
+=head1 SECURITY CONSIDERATIONS
+
+msva-perl deliberately binds to the loopback adapter (via named lookup
+of "localhost") so that remote users do not get access to the daemon.
+On systems (like Linux) which report ownership of TCP sockets in
+/proc/net/tcp, msva-perl will refuse access from random users (see
+MSVA_ALLOWED_USERS above).
+
+=head1 SEE ALSO
+
+monkeysphere(1), monkeysphere(7)
+
+=head1 BUGS AND FEEDBACK
+
+Bugs or feature requests for msva-perl should be filed with the
+Monkeysphere project's bug tracker at
+https://labs.riseup.net/code/projects/monkeysphere/issues/
+
+=head1 AUTHORS AND CONTRIBUTORS
+
+Daniel Kahn Gillmor E<lt>dkg@fifthhorseman.net<gt>
+
+The Monkeysphere Team http://web.monkeysphere.info/
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright © Daniel Kahn Gillmor and others from the Monkeysphere team.
+msva-perl is free software, distributed under the GNU Public License,
+version 3 or later.
+
projects / monkeysphere-validation-agent.git / blobdiff