3 # Monkeysphere Validation Agent, Perl version
4 # Copyright © 2010 Daniel Kahn Gillmor <dkg@fifthhorseman.net>
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.
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.
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/>.
24 use parent qw(HTTP::Server::Simple::CGI);
26 use Regexp::Common qw /net/;
34 use POSIX qw(strftime);
35 # we need the version of GnuPG::Interface that knows about pubkey_data, etc:
36 use GnuPG::Interface 0.42.02;
40 my $gnupg = GnuPG::Interface->new();
41 $gnupg->options->quiet(1);
42 $gnupg->options->batch(1);
45 '/' => { handler => \&noop,
46 methods => { 'GET' => 1 },
48 '/reviewcert' => { handler => \&reviewcert,
49 methods => { 'POST' => 1 },
51 '/extracerts' => { handler => \&extracerts,
52 methods => { 'POST' => 1 },
56 my $default_keyserver = 'hkp://pool.sks-keyservers.net';
57 my $default_keyserver_policy = 'unlessvalid';
59 # Net::Server log_level goes from 0 to 4
60 # this is scaled to match.
74 my $rsa_decoder = Convert::ASN1->new;
75 $rsa_decoder->prepare(q<
86 my $level = $loglevels{lc($ENV{MSVA_LOG_LEVEL})};
87 $level = $loglevels{error} if (! defined $level);
89 if ($loglevels{lc($msglevel)} <= $level) {
95 my $level = $loglevels{lc($ENV{MSVA_LOG_LEVEL})};
96 $level = $loglevels{error} if (! defined $level);
101 return 'Net::Server::MSVA';
108 if (exists $ENV{MSVA_PORT}) {
109 $port = $ENV{MSVA_PORT} + 0;
110 die sprintf("not a reasonable port %d", $port) if (($port >= 65536) || $port <= 0);
112 # start the server on requested port
113 my $self = $class->SUPER::new($port);
114 if (! exists $ENV{MSVA_PORT}) {
115 # we can't pass port 0 to the constructor because it evaluates
116 # to false, so HTTP::Server::Simple just uses its internal
117 # default of 8080. But if we want to select an arbitrary open
118 # port, we *can* set it here.
122 $self->{allowed_uids} = {};
123 if (exists $ENV{MSVA_ALLOWED_USERS}) {
124 msvalog('verbose', "MSVA_ALLOWED_USERS environment variable is set.\nLimiting access to specified users.\n");
125 foreach my $user (split(/ +/, $ENV{MSVA_ALLOWED_USERS})) {
126 my ($name, $passwd, $uid);
127 if ($user =~ /^[0-9]+$/) {
128 $uid = $user + 0; # force to integer
130 ($name,$passwd,$uid) = getpwnam($user);
133 msvalog('verbose', "Allowing access from user ID %d\n", $uid);
134 $self->{allowed_uids}->{$uid} = $user;
136 msvalog('error', "Could not find user '%d'; not allowing\n", $user);
140 # default is to allow access only to the current user
141 $self->{allowed_uids}->{POSIX::getuid()} = 'self';
144 bless ($self, $class);
151 return '200 OK', { available => JSON::true,
153 server => "MSVA-Perl ".$version };
156 # returns an empty list if bad key found.
157 sub parse_openssh_pubkey {
159 my ($label, $prop) = split(/ +/, $data);
160 $prop = decode_base64($prop) or return ();
162 msvalog('debug', "key properties: %s\n", unpack('H*', $prop));
164 while (length($prop) > 4) {
165 my $size = unpack('N', substr($prop, 0, 4));
166 msvalog('debug', "size: 0x%08x\n", $size);
167 return () if (length($prop) < $size + 4);
168 push(@out, substr($prop, 4, $size));
169 $prop = substr($prop, 4 + $size);
171 return () if ($label ne $out[0]);
175 # return the numeric ID of the peer on the other end of $socket,
176 # returning undef if unknown.
177 sub get_remote_peer_id {
180 my $sock = IO::Socket->new_from_fd($socket, 'r');
181 # check SO_PEERCRED -- if this was a TCP socket, Linux
182 # might not be able to support SO_PEERCRED (even on the loopback),
183 # though apparently some kernels (Solaris?) are able to.
186 my $socktype = $sock->sockopt(SO_TYPE) or die "could not get SO_TYPE info";
187 if (defined $socktype) {
188 msvalog('debug', "sockopt(SO_TYPE) = %d\n", $socktype);
190 msvalog('verbose', "sockopt(SO_TYPE) returned undefined.\n");
193 my $peercred = $sock->sockopt(SO_PEERCRED) or die "could not get SO_PEERCRED info";
194 my $remotepeer = $sock->peername();
195 my $family = sockaddr_family($remotepeer); # should be AF_UNIX (a.k.a. AF_LOCAL) or AF_INET
197 msvalog('verbose', "socket family: %d\nsocket type: %d\n", $family, $socktype);
200 # FIXME: on i386 linux, this appears to be three ints, according to
201 # /usr/include/linux/socket.h. What about other platforms?
202 my ($pid, $uid, $gid) = unpack('iii', $peercred);
204 msvalog('verbose', "SO_PEERCRED: pid: %u, uid: %u, gid: %u\n",
207 if ($pid != 0 && $uid != 0) { # then we can accept it:
208 $remotepeerid = $uid;
212 # another option in Linux would be to parse the contents of
213 # /proc/net/tcp to find the uid of the peer process based on that
215 if (! defined $remotepeerid) {
217 if ($family == AF_INET) {
219 } elsif ($family == AF_INET6) {
222 if (defined $proto) {
223 if ($socktype == &SOCK_STREAM) {
224 $proto = 'tcp'.$proto;
225 } elsif ($socktype == &SOCK_DGRAM) {
226 $proto = 'udp'.$proto;
230 if (defined $proto) {
231 my ($port, $iaddr) = unpack_sockaddr_in($remotepeer);
232 my $iaddrstring = unpack("H*", reverse($iaddr));
233 msvalog('verbose', "Port: %04x\nAddr: %s\n", $port, $iaddrstring);
234 my $remmatch = lc(sprintf("%s:%04x", $iaddrstring, $port));
235 my $infofile = '/proc/net/'.$proto;
236 my $f = new IO::File;
237 if ( $f->open('< '.$infofile)) {
238 my @header = split(/ +/, <$f>);
239 my ($localaddrix, $uidix);
242 while ($ix <= $#header) {
243 $localaddrix = $ix - $skipcount if (lc($header[$ix]) eq 'local_address');
244 $uidix = $ix - $skipcount if (lc($header[$ix]) eq 'uid');
245 $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
248 if (!defined $localaddrix) {
249 msvalog('info', "Could not find local_address field in %s; unable to determine peer UID\n",
251 } elsif (!defined $uidix) {
252 msvalog('info', "Could not find uid field in %s; unable to determine peer UID\n",
255 msvalog('debug', "local_address: %d; uid: %d\n", $localaddrix,$uidix);
256 while (my @line = split(/ +/,<$f>)) {
257 if (lc($line[$localaddrix]) eq $remmatch) {
258 if (defined $remotepeerid) {
259 msvalog('error', "Warning! found more than one remote uid! (%s and %s\n", $remotepeerid, $line[$uidix]);
261 $remotepeerid = $line[$uidix];
262 msvalog('info', "remote peer is uid %d\n",
267 msvalog('error', "Warning! could not find peer information in %s. Not verifying.\n", $infofile) unless defined $remotepeerid;
269 } else { # FIXME: we couldn't read the file. what should we
270 # do besides warning?
271 msvalog('info', "Could not read %s; unable to determine peer UID\n",
277 return $remotepeerid;
284 my $remotepeerid = get_remote_peer_id(select);
286 if (defined $remotepeerid) {
287 # test that this is an allowed user:
288 if (exists $self->{allowed_uids}->{$remotepeerid}) {
289 msvalog('verbose', "Allowing access from uid %d (%s)\n", $remotepeerid, $self->{allowed_uids}->{$remotepeerid});
291 msvalog('error', "MSVA client connection from uid %d, forbidden.\n", $remotepeerid);
292 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",
293 strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())),);
298 my $path = $cgi->path_info();
299 my $handler = $dispatch{$path};
301 if (ref($handler) eq "HASH") {
302 if (! exists $handler->{methods}->{$cgi->request_method()}) {
303 printf("HTTP/1.0 405 Method not allowed\r\nAllow: %s\r\nDate: %s\r\n",
304 join(', ', keys(%{$handler->{methods}})),
305 strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())));
306 } elsif (ref($handler->{handler}) ne "CODE") {
307 printf("HTTP/1.0 500 Server Error\r\nDate: %s\r\n",
308 strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())));
311 my $ctype = $cgi->content_type();
312 msvalog('verbose', "Got %s %s (Content-Type: %s)\n", $cgi->request_method(), $path, defined $ctype ? $ctype : '**none supplied**');
313 if (defined $ctype) {
314 my @ctypes = split(/; */, $ctype);
315 $ctype = shift @ctypes;
316 if ($ctype eq 'application/json') {
317 $data = from_json($cgi->param('POSTDATA'));
321 my ($status, $object) = $handler->{handler}($data);
322 my $ret = to_json($object);
323 msvalog('info', "returning: %s\n", $ret);
324 printf("HTTP/1.0 %s\r\nDate: %s\r\nContent-Type: application/json\r\n\r\n%s",
326 strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())),
330 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",
331 strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())),
332 $path, ' * '.join("\r\n * ", keys %dispatch) );
340 if ($gpgkey->algo_num != 1) {
341 msvalog('verbose', "Monkeysphere only does RSA keys. This key is algorithm #%d\n", $gpgkey->algo_num);
343 if ($rsakey->{exponent}->bcmp($gpgkey->pubkey_data->[1]) == 0 &&
344 $rsakey->{modulus}->bcmp($gpgkey->pubkey_data->[0]) == 0) {
353 if ($data->{context} =~ /^(https|ssh)$/) {
354 $data->{context} = $1;
355 if ($data->{peer} =~ /^($RE{net}{domain})$/) {
357 return $data->{context}.'://'.$data->{peer};
362 sub get_keyserver_policy {
363 if (exists $ENV{MSVA_KEYSERVER_POLICY}) {
364 if ($ENV{MSVA_KEYSERVER_POLICY} =~ /^(always|never|unlessvalid)$/) {
367 msvalog('error', "Not a valid MSVA_KEYSERVER_POLICY):\n %s\n", $ENV{MSVA_KEYSERVER_POLICY});
369 return $default_keyserver_policy;
373 # We should read from (first hit wins):
375 if (exists $ENV{MSVA_KEYSERVER}) {
376 if ($ENV{MSVA_KEYSERVER} =~ /^((hkps?|finger|ldap):\/\/)?$RE{net}{domain}$/) {
379 msvalog('error', "Not a valid keyserver (from MSVA_KEYSERVER):\n %s\n", $ENV{MSVA_KEYSERVER});
382 # FIXME: some msva.conf file (system and user?)
383 # FIXME: the relevant gnupg.conf instead?
385 # the default_keyserver
386 return $default_keyserver;
389 sub fetch_uid_from_keyserver {
392 my $cmd = IO::Handle->new();
393 my $out = IO::Handle->new();
394 my $nul = IO::File->new("< /dev/null");
396 msvalog('debug', "start ks query for UserID: %s", $uid);
397 my $pid = $gnupg->wrap_call
398 ( handles => GnuPG::Handles->new( command => $cmd, stdout => $out, stderr => $nul ),
399 command_args => [ '='.$uid ],
400 commands => [ '--keyserver',
402 qw( --no-tty --with-colons --search ) ]
404 while (my $line = $out->getline()) {
405 msvalog('debug', "from ks query: (%d) %s", $cmd->fileno, $line);
406 if ($line =~ /^info:(\d+):(\d+)/ ) {
407 $cmd->print(join(' ', ($1..$2))."\n");
408 msvalog('debug', 'to ks query: '.join(' ', ($1..$2))."\n");
411 # FIXME: can we do something to avoid hanging forever?
413 msvalog('debug', "ks query returns %d\n", POSIX::WEXITSTATUS($?));
418 return if !ref $data;
420 my $status = '200 OK';
421 my $ret = { valid => JSON::false,
422 message => 'Unknown failure',
425 my $uid = getuid($data);
427 msvalog('error', "invalid peer/context: %s/%s\n", $data->{context}, $data->{peer});
428 $ret->{message} = sprintf('invalid peer/context');
429 return $status, $ret;
432 my $rawdata = join('', map(chr, @{$data->{pkc}->{data}}));
433 my $cert = Crypt::X509->new(cert => $rawdata);
434 msvalog('verbose', "cert subject: %s\n", $cert->subject_cn());
435 msvalog('verbose', "cert issuer: %s\n", $cert->issuer_cn());
436 msvalog('verbose', "cert pubkey algo: %s\n", $cert->PubKeyAlg());
437 msvalog('verbose', "cert pubkey: %s\n", unpack('H*', $cert->pubkey()));
439 if ($cert->PubKeyAlg() ne 'RSA') {
440 $ret->{message} = sprintf('public key was algo "%s" (OID %s). MSVA.pl only supports RSA',
441 $cert->PubKeyAlg(), $cert->pubkey_algorithm);
443 my $key = $rsa_decoder->decode($cert->pubkey());
445 # make sure that the returned integers are Math::BigInts:
446 $key->{exponent} = Math::BigInt->new($key->{exponent}) unless (ref($key->{exponent}));
447 $key->{modulus} = Math::BigInt->new($key->{modulus}) unless (ref($key->{modulus}));
448 msvalog('debug', "cert info:\nmodulus: %s\nexponent: %s\n",
449 $key->{modulus}->as_hex(),
450 $key->{exponent}->as_hex(),
453 if ($key->{modulus}->copy()->blog(2) < 1000) { # FIXME: this appears to be the full pubkey, including DER overhead
454 $ret->{message} = sprintf('public key size is less than 1000 bits (was: %d bits)', $cert->pubkey_size());
456 $ret->{message} = sprintf('Failed to validate "%s" through the OpenPGP Web of Trust.', $uid);
458 if (get_keyserver_policy() eq 'always') {
459 fetch_uid_from_keyserver($uid);
461 } elsif (get_keyserver_policy() eq 'never') {
465 # needed because $gnupg spawns child processes
466 $ENV{PATH} = '/usr/local/bin:/usr/bin:/bin';
469 foreach my $gpgkey ($gnupg->get_public_keys('='.$uid)) {
471 foreach my $tryuid ($gpgkey->user_ids) {
472 if ($tryuid->as_string eq $uid) {
474 if ($tryuid->validity eq 'f' ||
475 $tryuid->validity eq 'u');
479 msvalog('verbose', "got a key that was not fully-valid for UID %s\n", $uid);
482 if ($gpgkey->usage_flags =~ /a/) {
483 msvalog('verbose', "primary key 0x%s is authentication-capable\n", $gpgkey->hex_id);
484 if (keycomp($key, $gpgkey)) {
485 msvalog('verbose', "...and it matches!\n");
486 $ret->{valid} = JSON::true;
487 $ret->{message} = sprintf('Successfully validated "%s" through the OpenPGP Web of Trust.', $uid);
490 foreach my $subkey ($gpgkey->subkeys) {
491 msvalog('verbose', "subkey 0x%s is authentication-capable\n", $subkey->hex_id);
492 if (keycomp($key, $subkey)) {
493 msvalog('verbose', "...and it matches!\n");
494 $ret->{valid} = JSON::true;
495 $ret->{message} = sprintf('Successfully validated "%s" through the OpenPGP Web of Trust.', $uid);
503 fetch_uid_from_keyserver($uid);
509 msvalog('error', "failed to decode %s\n", unpack('H*', $cert->pubkey()));
510 $ret->{message} = sprintf('failed to decode the public key', $uid);
514 return $status, $ret;
522 msvalog('debug', "Subprocess %d terminated.\n", $pid);
524 if (exists $self->{child_pid} &&
525 ($self->{child_pid} == 0 ||
526 $self->{child_pid} == $pid)) {
527 my $exitstatus = POSIX::WEXITSTATUS($?);
528 msvalog('verbose', "Subprocess %d terminated; exiting %d.\n", $pid, $exitstatus);
529 $server->set_exit_status($exitstatus);
530 $server->server_close();
534 # use sparingly! We want to keep taint mode around for the data we
535 # get over the network. this is only here because we want to treat
536 # the command line arguments differently for the subprocess.
547 my $socketcount = @{ $server->{server}->{sock} };
548 if ( $socketcount != 1 ) {
549 msvalog('error', "%d sockets open; should have been 1.", $socketcount);
550 $server->set_exit_status(10);
551 $server->server_close();
553 my $port = @{ $server->{server}->{sock} }[0]->sockport();
554 if ((! defined $port) || ($port < 1) || ($port >= 65536)) {
555 msvalog('error', "got nonsense port: %d.", $port);
556 $server->set_exit_status(11);
557 $server->server_close();
559 if ((exists $ENV{MSVA_PORT}) && (($ENV{MSVA_PORT} + 0) != $port)) {
560 msvalog('error', "Explicitly requested port %d, but got port: %d.", ($ENV{MSVA_PORT}+0), $port);
561 $server->set_exit_status(13);
562 $server->server_close();
566 my $argcount = @ARGV;
568 $self->{child_pid} = 0; # indicate that we are planning to fork.
570 if (! defined $fork) {
571 msvalog('error', "could not fork\n");
574 msvalog('debug', "Child process has PID %d\n", $fork);
575 $self->{child_pid} = $fork;
577 msvalog('verbose', "PID %d executing: \n", $$);
578 for my $arg (@ARGV) {
579 msvalog('verbose', " %s\n", $arg);
581 $ENV{PATH} = untaint($ENV{PATH});
584 push @args, untaint($_);
586 # restore default SIGCHLD handling:
587 $SIG{CHLD} = 'DEFAULT';
588 $ENV{MONKEYSPHERE_VALIDATION_AGENT_SOCKET} = sprintf('http://localhost:%d', $self->port);
589 exec(@args) or exit 111;
593 printf("MONKEYSPHERE_VALIDATION_AGENT_SOCKET=http://localhost:%d;\nexport MONKEYSPHERE_VALIDATION_AGENT_SOCKET;\n", $self->port);
594 # FIXME: consider daemonizing here to behave more like
595 # ssh-agent. maybe avoid backgrounding by setting
596 # MSVA_NO_BACKGROUND.
603 return '500 not yet implemented', { };
609 my $server = MSVA->new();
610 $server->run(host=>'localhost',
611 log_level=>MSVA::get_log_level(),
612 user => POSIX::geteuid(), # explicitly choose regular user and group (avoids spew)
613 group => POSIX::getegid(),
619 msva-perl - Perl implementation of a Monkeysphere Validation Agent
623 msva-perl [ COMMAND [ ARGS ... ] ]
627 msva-perl provides a Perl implementation of the Monkeysphere
628 Validation Agent, a certificate validation service.
632 The Monkeysphere Validation Agent offers a local service for tools to
633 validate certificates (both X.509 and OpenPGP) and other public keys.
635 Clients of the validation agent query it with a public key carrier (a
636 raw public key, or some flavor of certificate), the supposed name of
637 the remote peer offering the pubkey, and the context in which the
638 validation check is relevant (e.g. ssh, https, etc).
640 The validation agent then tells the client whether it was able to
641 successfully validate the peer's use of the public key in the given
644 msva-perl relies on monkeysphere(1), which uses the user's OpenPGP web
645 of trust to validate the peer's use of public keys.
649 Launched with no arguments, msva-perl simply runs and listens forever.
651 Launched with arguments, it sets up a listener, spawns a subprocess
652 using the supplied command and arguments, but with the
653 MONKEYSPHERE_VALIDATION_AGENT_SOCKET environment variable set to refer
654 to its listener. When the subprocess terminates, msva-perl tears down
655 the listener and exits as well, returning the same value as the
658 This is a similar invocation pattern to that of ssh-agent(1).
660 =head1 ENVIRONMENT VARIABLES
662 msva-perl is configured by means of environment variables.
668 msva-perl logs messages about its operation to stderr. MSVA_LOG_LEVEL
669 controls its verbosity, and should be one of (in increasing
670 verbosity): silent, quiet, fatal, error, info, verbose, debug, debug1,
671 debug2, debug3. Default is 'error'.
673 =item MSVA_ALLOWED_USERS
675 If your system is capable of it, msva-perl tries to figure out the
676 owner of the connecting client. If MSVA_ALLOWED_USERS is unset,
677 msva-perl will only permit connections from the user msva is running
678 as. If you set MSVA_ALLOWED_USERS, msva-perl will treat it as a list
679 of local users (by name or user ID) who are allowed to connect.
683 msva-perl listens on a local TCP socket to facilitate access. You can
684 choose what port to bind to by setting MSVA_PORT. Default is to bind
685 on an arbitrary open port.
689 msva-perl will request information from OpenPGP keyservers. Set
690 MSVA_KEYSERVER to declare the keyserver you want it to check with.
691 Default is 'hkp://pool.sks-keyservers.net'.
693 =item MSVA_KEYSERVER_POLICY
695 msva-perl must decide when to check with keyservers (for new keys,
696 revocation certificates, new certifications, etc). There are three
697 possible options: 'always' means to check with the keyserver on every
698 query it receives. 'never' means to never check with a
699 keyserver. 'unlessvalid' will only check with the keyserver on a
700 specific query if no keys are already locally known to be valid for
701 the requested peer. Default is 'unlessvalid'.
705 =head1 COMMUNICATION PROTOCOL DETAILS
707 Communications with the Monkeysphere Validation Agent are in the form
708 of JSON requests over plain HTTP. Responses from the agent are also
709 JSON objects. For details on the structure of the requests and
710 responses, please see
711 http://web.monkeysphere.info/validation-agent/protocol
713 =head1 SECURITY CONSIDERATIONS
715 msva-perl deliberately binds to the loopback adapter (via named lookup
716 of "localhost") so that remote users do not get access to the daemon.
717 On systems (like Linux) which report ownership of TCP sockets in
718 /proc/net/tcp, msva-perl will refuse access from random users (see
719 MSVA_ALLOWED_USERS above).
723 monkeysphere(1), monkeysphere(7), ssh-agent(1)
725 =head1 BUGS AND FEEDBACK
727 Bugs or feature requests for msva-perl should be filed with the
728 Monkeysphere project's bug tracker at
729 https://labs.riseup.net/code/projects/monkeysphere/issues/
731 =head1 AUTHORS AND CONTRIBUTORS
733 Daniel Kahn Gillmor E<lt>dkg@fifthhorseman.net<gt>
735 The Monkeysphere Team http://web.monkeysphere.info/
737 =head1 COPYRIGHT AND LICENSE
739 Copyright © Daniel Kahn Gillmor and others from the Monkeysphere team.
740 msva-perl is free software, distributed under the GNU Public License,