[Pkg-privacy-commits] [msva-perl] 141/356: reorganize some code

Ximin Luo infinity0 at moszumanska.debian.org
Mon Aug 24 07:41:49 UTC 2015


This is an automated email from the git hooks/post-receive script.

infinity0 pushed a commit to branch debian
in repository msva-perl.

commit 0bbe92bcacc72791d66b83ba80b4cd42cb3c6480
Author: Daniel Kahn Gillmor <dkg at fifthhorseman.net>
Date:   Sun Oct 3 23:43:40 2010 -0400

    reorganize some code
---
 Changelog                               |   1 +
 msva-perl => Crypt/Monkeysphere/MSVA.pm | 142 +------
 msva-perl                               | 674 +-------------------------------
 3 files changed, 6 insertions(+), 811 deletions(-)

diff --git a/Changelog b/Changelog
index 6203ff4..4a79b18 100644
--- a/Changelog
+++ b/Changelog
@@ -3,6 +3,7 @@ msva-perl (0.4~pre) upstream;
   * removed dependency on monkeysphere package -- just invoke GnuPG
     directly (needs GnuPG::Interface, Regexp::Common)
   * adds MSVA_KEYSERVER_POLICY and MSVA_KEYSERVER environment variables.
+  * added a marginal UI (needs Gtk2 perl module)
 
  -- Daniel Kahn Gillmor <dkg at fifthhorseman.net>  Sat, 02 Oct 2010 23:54:11 -0400
 
diff --git a/msva-perl b/Crypt/Monkeysphere/MSVA.pm
similarity index 85%
copy from msva-perl
copy to Crypt/Monkeysphere/MSVA.pm
index df5e548..0756ad9 100755
--- a/msva-perl
+++ b/Crypt/Monkeysphere/MSVA.pm
@@ -1,5 +1,3 @@
-#!/usr/bin/perl -wT
-
 # Monkeysphere Validation Agent, Perl version
 # Copyright © 2010 Daniel Kahn Gillmor <dkg at fifthhorseman.net>
 #
@@ -16,10 +14,7 @@
 # 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;
+{ package Crypt::Monkeysphere::MSVA;
 
   use Crypt::Monkeysphere::MSVA::MarginalUI;
   use parent qw(HTTP::Server::Simple::CGI);
@@ -686,138 +681,3 @@ use strict;
 
   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.
-
-=item MSVA_KEYSERVER
-
-msva-perl will request information from OpenPGP keyservers.  Set
-MSVA_KEYSERVER to declare the keyserver you want it to check with.
-Default is 'hkp://pool.sks-keyservers.net'.
-
-=item MSVA_KEYSERVER_POLICY
-
-msva-perl must decide when to check with keyservers (for new keys,
-revocation certificates, new certifications, etc).  There are three
-possible options: 'always' means to check with the keyserver on every
-query it receives.  'never' means to never check with a
-keyserver. 'unlessvalid' will only check with the keyserver on a
-specific query if no keys are already locally known to be valid for
-the requested peer.  Default is 'unlessvalid'.
-
-=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 at 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.
-
diff --git a/msva-perl b/msva-perl
index df5e548..35bd202 100755
--- a/msva-perl
+++ b/msva-perl
@@ -19,677 +19,11 @@
 use warnings;
 use strict;
 
-{ package MSVA;
-
-  use Crypt::Monkeysphere::MSVA::MarginalUI;
-  use parent qw(HTTP::Server::Simple::CGI);
-  require Crypt::X509;
-  use Regexp::Common qw /net/;
-  use Convert::ASN1;
-  use MIME::Base64;
-  use IO::Socket;
-  use IO::File;
-  use Socket;
-
-  use JSON;
-  use POSIX qw(strftime);
-  # we need the version of GnuPG::Interface that knows about pubkey_data, etc:
-  use GnuPG::Interface 0.42.02;
-
-  my $version = '0.1';
-
-  my $gnupg = GnuPG::Interface->new();
-  $gnupg->options->quiet(1);
-  $gnupg->options->batch(1);
-
-  my %dispatch = (
-                  '/' => { handler => \&noop,
-                           methods => { 'GET' => 1 },
-                         },
-                  '/reviewcert' => { handler => \&reviewcert,
-                                     methods => { 'POST' => 1 },
-                                   },
-                  '/extracerts' => { handler => \&extracerts,
-                                     methods => { 'POST' => 1 },
-                                   },
-                 );
-
-  my $default_keyserver = 'hkp://pool.sks-keyservers.net';
-  my $default_keyserver_policy = 'unlessvalid';
-
-# 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 keycomp {
-    my $rsakey = shift;
-    my $gpgkey = shift;
-
-    if ($gpgkey->algo_num != 1) {
-      msvalog('verbose', "Monkeysphere only does RSA keys.  This key is algorithm #%d\n", $gpgkey->algo_num);
-    } else {
-      if ($rsakey->{exponent}->bcmp($gpgkey->pubkey_data->[1]) == 0 &&
-          $rsakey->{modulus}->bcmp($gpgkey->pubkey_data->[0]) == 0) {
-        return 1;
-      }
-    }
-    return 0;
-  }
-
-  sub getuid {
-    my $data = shift;
-    if ($data->{context} =~ /^(https|ssh)$/) {
-      $data->{context} = $1;
-      if ($data->{peer} =~ /^($RE{net}{domain})$/) {
-        $data->{peer} = $1;
-        return $data->{context}.'://'.$data->{peer};
-      }
-    }
-  }
-
-  sub get_keyserver_policy {
-    if (exists $ENV{MSVA_KEYSERVER_POLICY}) {
-      if ($ENV{MSVA_KEYSERVER_POLICY} =~ /^(always|never|unlessvalid)$/) {
-        return $1;
-      }
-      msvalog('error', "Not a valid MSVA_KEYSERVER_POLICY):\n  %s\n", $ENV{MSVA_KEYSERVER_POLICY});
-    }
-    return $default_keyserver_policy;
-  }
-
-  sub get_keyserver {
-    # We should read from (first hit wins):
-    # the environment
-    if (exists $ENV{MSVA_KEYSERVER}) {
-      if ($ENV{MSVA_KEYSERVER} =~ /^((hkps?|finger|ldap):\/\/)?$RE{net}{domain}$/) {
-        return $1;
-      }
-      msvalog('error', "Not a valid keyserver (from MSVA_KEYSERVER):\n  %s\n", $ENV{MSVA_KEYSERVER});
-    }
-
-    # FIXME: some msva.conf file (system and user?)
-    # FIXME: the relevant gnupg.conf instead?
-
-    # the default_keyserver
-    return $default_keyserver;
-  }
-
-  sub fetch_uid_from_keyserver {
-    my $uid = shift;
-
-    my $cmd = IO::Handle->new();
-    my $out = IO::Handle->new();
-    my $nul = IO::File->new("< /dev/null");
-
-    msvalog('debug', "start ks query for UserID: %s", $uid);
-    my $pid = $gnupg->wrap_call
-      ( handles => GnuPG::Handles->new( command => $cmd, stdout => $out, stderr => $nul ),
-        command_args => [ '='.$uid ],
-        commands => [ '--keyserver',
-                      get_keyserver(),
-                      qw( --no-tty --with-colons --search ) ]
-      );
-    while (my $line = $out->getline()) {
-      msvalog('debug', "from ks query: (%d) %s", $cmd->fileno, $line);
-      if ($line =~ /^info:(\d+):(\d+)/ ) {
-        $cmd->print(join(' ', ($1..$2))."\n");
-        msvalog('debug', 'to ks query: '.join(' ', ($1..$2))."\n");
-      }
-    }
-    # FIXME: can we do something to avoid hanging forever?
-    waitpid($pid, 0);
-    msvalog('debug', "ks query returns %d\n", POSIX::WEXITSTATUS($?));
-  }
-
-  sub reviewcert {
-    my $data  = shift;
-    return if !ref $data;
-
-    my $status = '200 OK';
-    my $ret =  { valid => JSON::false,
-                 message => 'Unknown failure',
-               };
-
-    my $uid = getuid($data);
-    if ($uid eq []) {
-        msvalog('error', "invalid peer/context: %s/%s\n", $data->{context}, $data->{peer});
-        $ret->{message} = sprintf('invalid peer/context');
-        return $status, $ret;
-    }
-
-    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()));
-
-    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 $lastloop = 0;
-          if (get_keyserver_policy() eq 'always') {
-            fetch_uid_from_keyserver($uid);
-            $lastloop = 1;
-          } elsif (get_keyserver_policy() eq 'never') {
-            $lastloop = 1;
-          }
-          my $foundvalid = 0;
-          # needed because $gnupg spawns child processes
-          $ENV{PATH} = '/usr/local/bin:/usr/bin:/bin';
-
-          # fingerprints of keys that are not fully-valid for this User ID, but match
-          # the key from the queried certificate:
-          my @subvalid_key_fprs;
-
-          while (1) {
-            foreach my $gpgkey ($gnupg->get_public_keys('='.$uid)) {
-              my $validity = '-';
-              foreach my $tryuid ($gpgkey->user_ids) {
-                if ($tryuid->as_string eq $uid) {
-                  $validity = $tryuid->validity;
-                }
-              }
-              # treat primary keys just like subkeys:
-              foreach my $subkey ($gpgkey, @{$gpgkey->subkeys}) {
-                my $primarymatch = keycomp($key, $subkey);
-                if ($primarymatch) {
-                  if ($subkey->usage_flags =~ /a/) {
-                    msvalog('verbose', "key matches, and 0x%s is authentication-capable\n", $subkey->hex_id);
-                    if ($validity =~ /^[fu]$/) {
-                      $foundvalid = 1;
-                      msvalog('verbose', "...and it matches!\n");
-                      $ret->{valid} = JSON::true;
-                      $ret->{message} = sprintf('Successfully validated "%s" through the OpenPGP Web of Trust.', $uid);
-                    } else {
-                      push(@subvalid_key_fprs, { fpr => $subkey->fingerprint, val => $validity }) if $lastloop;
-                    }
-                  } else {
-                    msvalog('verbose', "key matches, but 0x%s is not authentication-capable\n", $subkey->hex_id);
-                  }
-                }
-              }
-            }
-            if ($lastloop) {
-              last;
-            } else {
-              fetch_uid_from_keyserver($uid) if (!$foundvalid);
-              $lastloop = 1;
-            }
-          }
-          msvalog('debug', "%d subvalid_key_fprs\n", $#subvalid_key_fprs+1);
-          foreach my $keyfpr (@subvalid_key_fprs) {
-            my $fprx = sprintf('0x%.40s', $keyfpr->{fpr}->as_hex_string);
-            msvalog('debug', "checking on %s\n", $fprx);
-            foreach my $gpgkey ($gnupg->get_public_keys_with_sigs($fprx)) {
-              msvalog('debug', "found key %.40s\n", $gpgkey->fingerprint->as_hex_string);
-              # we're going to prompt the user here if we have any
-              # relevant certifiers:
-              my @valid_certifiers;
-              my @marginal_certifiers;
-
-              # FIXME: if there are multiple keys in the OpenPGP WoT
-              # with the same key material and the same User ID
-              # attached, we'll be throwing multiple prompts per
-              # query.  That's a mess, but i'm not sure what the
-              # better thing to do is.
-              foreach my $user_id ($gpgkey->user_ids) {
-                msvalog('debug', "found EE User ID %s\n", $user_id->as_string);
-                if ($user_id->as_string eq $uid) {
-                  # get a list of the certifiers of the relevant User ID for the key
-                  foreach my $cert (@{$user_id->signatures}) {
-                    if ($cert->hex_id =~ /^([A-Fa-f0-9]{16})$/) {
-                      my $certid = $1;
-                      msvalog('debug', "found certifier 0x%.16s\n", $certid);
-                      if ($cert->is_valid()) {
-                        foreach my $certifier ($gnupg->get_public_keys(sprintf('0x%.40s!', $certid))) {
-                          my $valid_cuid = 0;
-                          my $marginal = undef;
-                          foreach my $cuid ($certifier->user_ids) {
-                            # grab the first full or ultimate user ID on
-                            # this certifier's key:
-                            if ($cuid->validity =~ /^[fu]$/) {
-                              push(@valid_certifiers, { key_id => $cert->hex_id,
-                                                        user_id => $cuid->as_string,
-                                                      } );
-                              $valid_cuid = 1;
-                              last;
-                            } elsif ($cuid->validity =~ /^[m]$/) {
-                              $marginal = { key_id => $cert->hex_id,
-                                            user_id => $cuid->as_string,
-                                          };
-                            }
-                          }
-                          push(@marginal_certifiers, $marginal)
-                            if (! $valid_cuid && defined $marginal);
-                        }
-                      }
-                    } else {
-                      msvalog('error', "certifier ID does not fit expected pattern '%s'\n", $cert->hex_id);
-                    }
-                  }
-                }
-                # else ## do we care at all about other User IDs on this key?
-
-                # We now know the list of fully/ultimately-valid
-                # certifiers, and a separate list of marginally-valid
-                # certifiers.
-                if ($#valid_certifiers == -1) {
-                  msvalog('info', "No valid certifiers, so no marginal UI\n");
-                } else {
-                  my $certifier_list = join("\n", map { sprintf("[%s] %s", $_->{key_id}, $_->{user_id}) } @valid_certifiers);
-                  my $msg = sprintf("The matching key we found for [%s] only has validity %s.\n(Key Fingerprint: 0x%.40s)\n----\nBut it was certified by the following folks:\n%s",
-                                    $uid,
-                                    $keyfpr->{val},
-                                    $keyfpr->{fpr}->as_hex_string,
-                                    $certifier_list,
-                                   );
-                  msvalog('info', "%s\n", $msg);
-                  my $resp = Crypt::Monkeysphere::MSVA::MarginalUI::prompt($msg);
-                  msvalog('info', "response: %s\n", $resp);
-                  if ($resp) {
-                    $ret->{valid} = JSON::true;
-                    $ret->{message} = sprintf('Manually validated "%s" through the OpenPGP Web of Trust.', $uid);
-                  }
-                }
-                # FIXME: not doing anything with @marginal_certifiers
-                # -- that'd be yet more queries to gpg :(
-              }
-            }
-          }
-        }
-      } 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($_);
-          }
-          # restore default SIGCHLD handling:
-          $SIG{CHLD} = 'DEFAULT';
-          $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();
+use Crypt::Monkeysphere::MSVA;
+
+my $server = Crypt::Monkeysphere::MSVA->new();
 $server->run(host=>'localhost',
-             log_level=>MSVA::get_log_level(),
+             log_level=> Crypt::Monkeysphere::MSVA::get_log_level(),
              user => POSIX::geteuid(),  # explicitly choose regular user and group (avoids spew)
              group => POSIX::getegid(),
              msva=>$server);

-- 
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-privacy/packages/msva-perl.git



More information about the Pkg-privacy-commits mailing list