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