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::GPG;
  27   require Crypt::X509;
  28   use Convert::ASN1;
  29   use MIME::Base64;
  30
  31   use JSON;
  32   use POSIX qw(strftime);
  33
  34   my %dispatch = (
  35                   '/' => { handler => \&noop,
  36                            methods => { 'GET' => 1 },
  37                          },
  38                   '/reviewcert' => { handler => \&reviewcert,
  39                                      methods => { 'POST' => 1 },
  40                                    },
  41                   '/extracerts' => { handler => \&extracerts,
  42                                      methods => { 'POST' => 1 },
  43                                    },
  44                  );
  45
  46   my %loglevels = (
  47                    'silent' => 1,
  48                    'quiet' => 2,
  49                    'fatal' => 3,
  50                    'error' => 4,
  51                    'info' => 5,
  52                    'verbose' => 6,
  53                    'debug' => 7,
  54                    'debug1' => 7,
  55                    'debug2' => 8,
  56                    'debug3' => 9,
  57                   );
  58
  59 my $rsa_decoder = Convert::ASN1->new;
  60 $rsa_decoder->prepare(q<
  61
  62    SEQUENCE {
  63         modulus INTEGER,
  64         exponent INTEGER
  65    }
  66           >);
  67
  68 #   $rsa_decoder->configure(-options => 'DER');
  69
  70   sub msvalog {
  71 #    my $self = shift;
  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 new {
  83     my $class = shift;
  84     # start the server on port 8901
  85     my $self = $class->SUPER::new(8901);
  86
  87     $self->{_gpg} = new Crypt::GPG;
  88
  89
  90     bless ($self, $class);
  91     return $self;
  92   }
  93
  94   sub noop {
  95     my $self = shift;
  96     my $cgi = shift;
  97     return '200 OK', { available => JSON::true,
  98                        protoversion => 1,
  99                        server => "MSVA-Perl 0.1" };
 100   }
 101
 102   sub handle_request {
 103     my $self = shift;
 104     my $cgi  = shift;
 105
 106     # FIXME: check SO_PEERCRED -- if this was a TCP socket, Linux
 107     # might not be able to support SO_PEERCRED (even on the loopback),
 108     # though apparently some kernels (Solaris?) are able to.
 109
 110     # another option in Linux would be to parse the contents of
 111     # /proc/net/tcp to find the uid of the peer process based on that
 112     # information.
 113
 114     my $path = $cgi->path_info();
 115     my $handler = $dispatch{$path};
 116
 117     if (ref($handler) eq "HASH") {
 118       if (! exists $handler->{methods}->{$cgi->request_method()}) {
 119         printf("HTTP/1.0 405 Method not allowed\r\nAllow: %s\r\nDate: %s\r\n",
 120                join(', ', keys(%{$handler->{methods}})),
 121                strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())));
 122       } elsif (ref($handler->{handler}) ne "CODE") {
 123         printf("HTTP/1.0 500 Server Error\r\nDate: %s\r\n",
 124                strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())));
 125       } else {
 126         my $data = {};
 127         my $ctype = $cgi->content_type();
 128         msvalog('info', "Got %s %s (Content-Type: %s)\n", $cgi->request_method(), $path, defined $ctype ? $ctype : '**none supplied**');
 129         if (defined $ctype) {
 130           my @ctypes = split(/; */, $ctype);
 131           $ctype = shift @ctypes;
 132           if ($ctype eq 'application/json') {
 133             $data = from_json($cgi->param('POSTDATA'));
 134           }
 135         };
 136
 137         my ($status, $object) = $handler->{handler}($data);
 138         my $ret = to_json($object);
 139         msvalog('info', "returning: %s\n", $ret);
 140         printf("HTTP/1.0 %s\r\nDate: %s\r\nContent-Type: application/json\r\n\r\n%s",
 141                $status,
 142                strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())),
 143                $ret);
 144       }
 145     } else {
 146       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",
 147              strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())),
 148              $path, ' * '.join("\r\n * ", keys %dispatch) );
 149     }
 150   }
 151
 152   sub reviewcert {
 153     my $data  = shift;
 154     return if !ref $data;
 155
 156     my $uid = $data->{context}.'://'.$data->{uid};
 157
 158     my $rawdata = join('', map(chr, @{$data->{pkc}->{data}}));
 159     my $cert = Crypt::X509->new(cert => $rawdata);
 160     msvalog('info', "cert subject: %s\n", $cert->subject_cn());
 161     msvalog('info', "cert issuer: %s\n", $cert->issuer_cn());
 162     msvalog('info', "cert pubkey algo: %s\n", $cert->PubKeyAlg());
 163     msvalog('info', "cert pubkey: %s\n", unpack('H*', $cert->pubkey()));
 164
 165 #    if ($cert->pubkey_algorithm
 166 #    msvalog('info', "public key: %s\n", $cert->
 167
 168     my $status = '200 OK';
 169     my $ret =  { valid => JSON::false,
 170                  message => 'Unknown failure',
 171                };
 172     if ($cert->PubKeyAlg() ne 'RSA') {
 173       $ret->{message} = sprintf('public key was algo "%s" (OID %s).  MSVA.pl only supports RSA',
 174                                 $cert->PubKeyAlg(), $cert->pubkey_algorithm);
 175     } elsif ($cert->pubkey_size() < 1024) { # FIXME: this appears to be the full pubkey, including DER overhead
 176       $ret->{message} = sprintf('public key size is less than 1024 bits (was: %d bits)', $cert->pubkey_size());
 177     } else {
 178       my $key = $rsa_decoder->decode($cert->pubkey());
 179       if ($key) {
 180         msvalog('info', "cert info:\nmodulus: %s\nexponent: %d\n",
 181                 $key->{modulus}->as_hex(),
 182                 $key->{exponent},
 183                );
 184         $ret->{message} = sprintf('tried to validate "%s" through the OpenPGP Web of Trust, failed.', $uid);
 185       } else {
 186         msvalog('info', "failed to decode %s\n", unpack('H*', $cert->pubkey()));
 187         $ret->{message} = sprintf('tried to validate "%s" through the OpenPGP Web of Trust', $uid);
 188       }
 189     }
 190
 191     return $status, $ret;
 192   }
 193
 194   sub extracerts {
 195     my $data = shift;
 196
 197     return '500 not yet implemented', { };
 198   }
 199
 200   1;
 201 }
 202
 203 my $server = MSVA->new();
 204 $server->run();