Crypt/Monkeysphere/Validator.pm

   1 package Crypt::Monkeysphere::Validator;
   2 use Carp;
   3 use strict;
   4 use warnings;
   5
   6 use parent 'Crypt::Monkeysphere::Keyserver';
   7
   8 =pod
   9
  10 =head2 new
  11
  12 Create a new Crypt::Monkeysphere::Validator instance
  13
  14 Arguments
  15
  16      Param hash, all optional.
  17
  18      context => 'e-mail|https|ssh|...'
  19                         control what counts as suitable user IDs and key capabilities.
  20
  21      kspolicy => 'always|never|unlessvalid'
  22                         when to fetch keys and key updates from keyserver.
  23
  24   (plus arguments for Crypt::Monkeysphere::{Keyserver,Logger}::new )
  25
  26 =head2 lookup
  27
  28 Arguments
  29
  30     Param hash.
  31
  32     uid => (mandatory) OpenPGP User ID desired.
  33
  34     fpr => fingerprint of the key to compare
  35
  36     key => hash of pubkey parameters as Math::BigInt values
  37
  38 one of either fpr or key must be supplied.
  39
  40 Return Value
  41
  42     Returns a hashref
  43
  44     If the lookup succeeded, then the hashref has a key named
  45     valid_key that points to a hashref { fingerprint => $fpr, val =>
  46     $validity }.
  47
  48     If no fully-valid keys+userid were found, but some keys matched
  49     with less-than-valid user IDs, then the hashref has a key named
  50     subvalid_keys that points to an arrayref of { fingerprint => $fpr,
  51     val => $validity } hashrefs.
  52
  53 =cut
  54
  55 sub new {
  56   my $class=shift;
  57   my %opts=@_;
  58
  59   my $self=$class->SUPER::new(%opts);
  60
  61   $self->{context}=$opts{context} || 'ssh';
  62   $self->{kspolicy}=$opts{kspolicy} || 'unlessvalid';
  63   return $self;
  64 }
  65
  66 sub test_capable {
  67   my $self=shift;
  68   my $subkey=shift;
  69
  70   if ($self->{context} eq 'e-mail') {
  71     if ($subkey->usage_flags =~ /s/) {
  72       $self->log('verbose', "...and is signing-capable...\n");
  73       return 1;
  74     } else {
  75       $self->log('verbose', "...but is not signing-capable (%s).\n",$subkey->usage_flags);
  76     }
  77   } else {
  78     if ($subkey->usage_flags =~ /a/) {
  79       $self->log('verbose', "...and is authentication-capable...\n");
  80       return 1;
  81     } else {
  82       $self->log('verbose', "...but is not authentication-capable (%s).\n",$subkey->usage_flags);
  83     }
  84   }
  85   return 0;
  86 }
  87
  88 sub _tryquery {
  89   my $self=shift;
  90   my %args=@_;
  91
  92   my $uid=$args{uid} || croak "uid argument is mandatory";
  93   my $fpr=$args{fpr};
  94   my $key=$args{key};
  95   defined($fpr) || defined($key) || croak "Must supply either a fingerprint or a key";
  96
  97   my $subvalid_keys = [];
  98
  99   my $gpgquery = defined($fpr) ? '0x'.$fpr : '='.$uid;
 100
 101   foreach my $gpgkey ($self->{gnupg}->get_public_keys($gpgquery)) {
 102     my $validity = '-';
 103     foreach my $tryuid ($gpgkey->user_ids) {
 104       if ($tryuid->as_string eq $uid) {
 105         $validity = $tryuid->validity;
 106       }
 107     }
 108     # treat primary keys just like subkeys:
 109     foreach my $subkey ($gpgkey, @{$gpgkey->subkeys}) {
 110       if ((defined($key) && $self->keycomp($key, $subkey)) ||
 111           (defined($fpr) && ($subkey->fingerprint->as_hex_string eq $fpr))) {
 112         $self->log('verbose', "key 0x%s matches...\n",$subkey->hex_id);
 113         if ($self->test_capable($subkey) ) {
 114           if ($validity =~ /^[fu]$/) {
 115             $self->log('verbose', "...and is fully valid!\n");
 116             # we have a key that matches with a valid userid -- no need to look further.
 117             return {valid_key => { fingerprint => $subkey->fingerprint, val => $validity }};
 118           } else {
 119             $self->log('verbose', "...but is not fully valid (%s).\n",$validity);
 120             push(@{$subvalid_keys},
 121                  {fingerprint => $subkey->fingerprint, val => $validity });
 122           }
 123         }
 124       }
 125     }
 126   }
 127   return { subvalid_keys => $subvalid_keys };
 128 }
 129
 130 sub lookup {
 131   my $self=shift;
 132   my %opts=@_;
 133
 134   if ($self->{kspolicy} eq 'unlessvalid') {
 135     my $ret = $self->_tryquery(uid => $opts{uid}, fpr => $opts{fpr}, key => $opts{key});
 136     return $ret
 137       if exists($ret->{valid_key});
 138   };
 139
 140   if ($self->{kspolicy} ne 'never') {
 141     if (defined($opts{fpr})) {
 142       $self->fetch_fpr($opts{fpr});
 143     } else {
 144       $self->fetch_uid($opts{uid});
 145     }
 146   }
 147   return $self->_tryquery(uid => $opts{uid}, fpr => $opts{fpr}, key => $opts{key});
 148 }
 149
 150 sub keycomp {
 151   my $self=shift;
 152   my $rsakey = shift;
 153   my $gpgkey = shift;
 154
 155   if ($gpgkey->algo_num != 1) {
 156     my $self->log('verbose', "Monkeysphere only does RSA keys.  This key is algorithm #%d\n", $gpgkey->algo_num);
 157     } else {
 158       if ($rsakey->{exponent}->bcmp($gpgkey->pubkey_data->[1]) == 0 &&
 159           $rsakey->{modulus}->bcmp($gpgkey->pubkey_data->[0]) == 0) {
 160         return 1;
 161       }
 162     }
 163     return 0;
 164   }
 165
 166 1;