#!/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 parent qw(HTTP::Server::Simple::CGI);
  require Crypt::X509;
  use Convert::ASN1;
  use MIME::Base64;
  use IO::Socket;
  use IO::File;
  use Socket;

  use JSON;
  use POSIX qw(strftime);

  my $version = '0.1';

  my %dispatch = (
                  '/' => { handler => \&noop,
                           methods => { 'GET' => 1 },
                         },
                  '/reviewcert' => { handler => \&reviewcert,
                                     methods => { 'POST' => 1 },
                                   },
                  '/extracerts' => { handler => \&extracerts,
                                     methods => { 'POST' => 1 },
                                   },
                 );

# Net::Server log_level goes from 0 to 4
# this is scaled to match.
  my %loglevels = (
                   'silent' => 0,
                   'quiet' => 0.25,
                   'fatal' => 0.5,
                   'error' => 1,
                   'info' => 2,
                   'verbose' => 3,
                   'debug' => 4,
                   'debug1' => 4,
                   'debug2' => 5,
                   'debug3' => 6,
                  );

  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{error} if (! defined $level);

    if ($loglevels{lc($msglevel)} <= $level) {
      printf STDERR @_;
    }
  };

  sub get_log_level {
    my $level = $loglevels{lc($ENV{MSVA_LOG_LEVEL})};
    $level = $loglevels{error} if (! defined $level);
    return $level;
  }

  sub net_server {
    return 'Net::Server::MSVA';
  };

  sub new {
    my $class = shift;

    my $port = 0;
    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 requested port
    my $self = $class->SUPER::new($port);
    if (! exists $ENV{MSVA_PORT}) {
      # we can't pass port 0 to the constructor because it evaluates
      # to false, so HTTP::Server::Simple just uses its internal
      # default of 8080.  But if we want to select an arbitrary open
      # port, we *can* set it here.
      $self->port(0);
    }

    $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 ".$version };
  }

  # 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 child_dies {
    my $self = shift;
    my $pid = shift;
    my $server = shift;

    msvalog('debug', "Subprocess %d terminated.\n", $pid);

    if (exists $self->{child_pid} &&
        ($self->{child_pid} == 0 ||
         $self->{child_pid} == $pid)) {
      my $exitstatus = POSIX::WEXITSTATUS($?);
      msvalog('verbose', "Subprocess %d terminated; exiting %d.\n", $pid, $exitstatus);
      $server->set_exit_status($exitstatus);
      $server->server_close();
    }
  }

  # use sparingly!  We want to keep taint mode around for the data we
  # get over the network.  this is only here because we want to treat
  # the command line arguments differently for the subprocess.
  sub untaint {
    my $x = shift;
    $x =~ /^(.*)$/ ;
    return $1;
  }

  sub post_bind_hook {
    my $self = shift;
    my $server = shift;

    my $socketcount = @{ $server->{server}->{sock} };
    if ( $socketcount != 1 ) {
      msvalog('error', "%d sockets open; should have been 1.", $socketcount);
      $server->set_exit_status(10);
      $server->server_close();
    }
    my $port = @{ $server->{server}->{sock} }[0]->sockport();
    if ((! defined $port) || ($port < 1) || ($port >= 65536)) {
      msvalog('error', "got nonsense port: %d.", $port);
      $server->set_exit_status(11);
      $server->server_close();
    }
    if ((exists $ENV{MSVA_PORT}) && (($ENV{MSVA_PORT} + 0) != $port)) {
      msvalog('error', "Explicitly requested port %d, but got port: %d.", ($ENV{MSVA_PORT}+0), $port);
      $server->set_exit_status(13);
      $server->server_close();
    }
    $self->port($port);

    my $argcount = @ARGV;
    if ($argcount) {
      $self->{child_pid} = 0; # indicate that we are planning to fork.
      my $fork = fork();
      if (! defined $fork) {
        msvalog('error', "could not fork\n");
      } else {
        if ($fork) {
          msvalog('debug', "Child process has PID %d\n", $fork);
          $self->{child_pid} = $fork;
        } else {
          msvalog('verbose', "PID %d executing: \n", $$);
          for my $arg (@ARGV) {
            msvalog('verbose', " %s\n", $arg);
          }
          $ENV{PATH} = untaint($ENV{PATH});
          my @args;
          foreach (@ARGV) {
            push @args, untaint($_);
          }
          $ENV{MONKEYSPHERE_VALIDATION_AGENT_SOCKET} = sprintf('http://localhost:%d', $self->port);
          exec(@args) or exit 111;
        }
      }
    } else {
      printf("MONKEYSPHERE_VALIDATION_AGENT_SOCKET=http://localhost:%d;\nexport MONKEYSPHERE_VALIDATION_AGENT_SOCKET;\n", $self->port);
      # FIXME: consider daemonizing here to behave more like
      # ssh-agent.  maybe avoid backgrounding by setting
      # MSVA_NO_BACKGROUND.
    };
  }

  sub extracerts {
    my $data = shift;

    return '500 not yet implemented', { };
  }

  1;
}

my $server = MSVA->new();
$server->run(host=>'localhost',
             log_level=>MSVA::get_log_level(),
             user => POSIX::geteuid(),  # explicitly choose regular user and group (avoids spew)
             group => POSIX::getegid(),
             msva=>$server);
__END__

=head1 NAME

msva-perl - Perl implementation of a Monkeysphere Validation Agent

=head1 SYNOPSIS

  msva-perl [ COMMAND [ ARGS ... ] ]

=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 USAGE

Launched with no arguments, msva-perl simply runs and listens forever.

Launched with arguments, it sets up a listener, spawns a subprocess
using the supplied command and arguments, but with the
MONKEYSPHERE_VALIDATION_AGENT_SOCKET environment variable set to refer
to its listener.  When the subprocess terminates, msva-perl tears down
the listener and exits as well, returning the same value as the
subprocess.

This is a similar invocation pattern to that of ssh-agent(1).

=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 'error'.

=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 to bind
on an arbitrary open port.

=back

=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), ssh-agent(1)

=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.