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
  29   use JSON;
  30   use POSIX qw(strftime);
  31
  32   my %dispatch = (
  33                   '/' => { handler => \&noop,
  34                            methods => { 'GET' => 1 },
  35                          },
  36                   '/reviewcert' => { handler => \&reviewcert,
  37                                      methods => { 'POST' => 1 },
  38                                    },
  39                   '/extracerts' => { handler => \&extracerts,
  40                                      methods => { 'POST' => 1 },
  41                                    },
  42                  );
  43
  44   my %loglevels = (
  45                    'silent' => 1,
  46                    'quiet' => 2,
  47                    'fatal' => 3,
  48                    'error' => 4,
  49                    'info' => 5,
  50                    'verbose' => 6,
  51                    'debug' => 7,
  52                    'debug1' => 7,
  53                    'debug2' => 8,
  54                    'debug3' => 9,
  55                   );
  56
  57   sub msvalog {
  58 #    my $self = shift;
  59     my $msglevel = shift;
  60
  61     my $level = $loglevels{lc($ENV{MSVA_LOG_LEVEL})};
  62     $level = $loglevels{info} if (! defined $level);
  63
  64     if ($loglevels{lc($msglevel)} <= $level) {
  65       printf STDERR @_;
  66     }
  67   };
  68
  69   sub new {
  70     my $class = shift;
  71     # start the server on port 8901
  72     my $self = $class->SUPER::new(8901);
  73
  74     $self->{_gpg} = new Crypt::GPG;
  75
  76     bless ($self, $class);
  77     return $self;
  78   }
  79
  80   sub noop {
  81     my $self = shift;
  82     my $cgi = shift;
  83     return '200 OK', { available => JSON::true,
  84                        protoversion => 1,
  85                        server => "MSVA-Perl 0.1" };
  86   }
  87
  88   sub handle_request {
  89     my $self = shift;
  90     my $cgi  = shift;
  91
  92     # FIXME: check SO_PEERCRED -- if this was a TCP socket, Linux
  93     # might not be able to support SO_PEERCRED (even on the loopback),
  94     # though apparently some kernels (Solaris?) are able to.
  95
  96     # another option in Linux would be to parse the contents of
  97     # /proc/net/tcp to find the uid of the peer process based on that
  98     # information.
  99
 100     my $path = $cgi->path_info();
 101     my $handler = $dispatch{$path};
 102
 103     if (ref($handler) eq "HASH") {
 104       if (! exists $handler->{methods}->{$cgi->request_method()}) {
 105         printf("HTTP/1.0 405 Method not allowed\r\nAllow: %s\r\nDate: %s\r\n",
 106                join(', ', keys(%{$handler->{methods}})),
 107                strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())));
 108       } elsif (ref($handler->{handler}) ne "CODE") {
 109         printf("HTTP/1.0 500 Server Error\r\nDate: %s\r\n",
 110                strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())));
 111       } else {
 112         my $data = {};
 113         my $ctype = $cgi->content_type();
 114         msvalog('info', "Got %s %s (Content-Type: %s)\n", $cgi->request_method(), $path, defined $ctype ? $ctype : '**none supplied**');
 115         if (defined $ctype) {
 116           my @ctypes = split(/; */, $ctype);
 117           $ctype = shift @ctypes;
 118           if ($ctype eq 'application/json') {
 119             $data = from_json($cgi->param('POSTDATA'));
 120           }
 121         };
 122
 123         my ($status, $object) = $handler->{handler}($data);
 124         my $ret = to_json($object);
 125         msvalog('info', "returning: %s\n", $ret);
 126         printf("HTTP/1.0 %s\r\nDate: %s\r\nContent-Type: application/json\r\n\r\n%s",
 127                $status,
 128                strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())),
 129                $ret);
 130       }
 131     } else {
 132       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",
 133              strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())),
 134              $path, ' * '.join("\r\n * ", keys %dispatch) );
 135     }
 136   }
 137
 138   sub reviewcert {
 139     my $data  = shift;
 140     return if !ref $data;
 141
 142     my $uid = $data->{context}.'://'.$data->{uid};
 143
 144     my $cert = Crypt::X509->new(cert => join('', map(chr, @{$data->{pkc}->{data}})));
 145
 146     msvalog('info', "cert subject: %s\n", $cert->subject_cn());
 147     msvalog('info', "cert issuer: %s\n", $cert->issuer_cn());
 148
 149     my $ret = { valid => JSON::true,
 150                 message => sprintf('tried to validate "%s" through the OpenPGP Web of Trust', $uid) };
 151     my $status = '200 match found, authentication details to follow';
 152
 153     return $status, $ret;
 154   }
 155
 156   sub extracerts {
 157     my $data = shift;
 158
 159     return '500 not yet implemented', { };
 160   }
 161
 162   1;
 163 }
 164
 165 my $server = MSVA->new();
 166 $server->run();