File Coverage

blib/lib/Net/OpenID/Association.pm
Criterion Covered Total %
statement 16 18 88.8
branch n/a
condition n/a
subroutine 6 6 100.0
pod n/a
total 22 24 91.6


line stmt bran cond sub pod time code
1 6     6   18 use strict;
  6         8  
  6         124  
2 6     6   17 use Carp ();
  6         5  
  6         187  
3              
4             ############################################################################
5             package Net::OpenID::Association;
6             $Net::OpenID::Association::VERSION = '1.18';
7             use fields (
8 6         21 'server', # author-identity identity provider endpoint
9             'secret', # the secret for this association
10             'handle', # the 255-character-max ASCII printable handle (33-126)
11             'expiry', # unixtime, adjusted, of when this association expires
12             'type', # association type
13 6     6   17 );
  6         5  
14              
15 6     6   3378 use Storable ();
  6         13557  
  6         109  
16 6     6   27 use Digest::SHA ();
  6         7  
  6         70  
17 6     6   2510 use Net::OpenID::Common;
  0            
  0            
18             use URI::Escape qw(uri_escape);
19              
20             ################################################################
21             # Association and Session Types
22              
23             # session type hash
24             # name - by which session type appears in URI parameters (required)
25             # len - number of bytes in digest (undef => accommodates any length)
26             # fn - DH hash function (undef => secret passed in the clear)
27             # https - must use encrypted connection (boolean)
28             #
29             my %_session_types = ();
30             # {versionkey}{name} -> session type
31             # {NO}{versionkey} -> no-encryption stype for this version
32             # {MAX}{versionkey} -> strongest encryption stype for this version
33              
34             # association type hash
35             # name - by which assoc. type appears in URI parameters (required)
36             # len - number of bytes in digest (required)
37             # macfn - MAC hash function (required)
38             #
39             my %_assoc_types = ();
40             # {versionkey}{name} -> association type
41             # {MAX}{versionkey} -> strongest encryption atype for this version
42              
43             my %_assoc_macfn = ();
44             # {name} -> hmac function
45             # ... since association types in the cache are only listed by name
46             # and don't say what version they're from. Which should not matter
47             # as long as the macfn associated with a given association type
48             # name does not change in future versions.
49              
50             # (floating point version numbers scare me)
51             # (also version key can stay the same if the
52             # set of hash functions available does not change)
53             # ('NO' and 'MAX' should never be used as version keys)
54             sub _version_key_from_numeric {
55             my ($numeric_protocol_version) = @_;
56             return $numeric_protocol_version < 2 ? 'v1' : 'v2';
57             }
58             # can SESSION_TYPE be used with ASSOC_TYPE?
59             sub _compatible_stype_atype {
60             my ($s_type, $a_type) = @_;
61             return !$s_type->{len} || $s_type->{len} == $a_type->{len};
62             }
63              
64             {
65             # Define the no-encryption session types.
66             # In version 1.1/1.0, the no-encryption session type
67             # is the default and never explicitly specified
68             $_session_types{$_->[0]}{$_->[1]}
69             = $_session_types{NO}{$_->[0]}
70             = {
71             name => $_->[1],
72             https => 1,
73             }
74             foreach ([v1 => ''], [v2 => 'no-encryption']);
75              
76             # Define SHA-based session and association types
77             my %_sha_fns =
78             (
79             SHA1 => { minv => 'v1', # first version group in which this appears
80             v1max => 1, # best encryption for v1
81             len => 20, # number of bytes in digest
82             fn => \&Digest::SHA::sha1,
83             macfn => \&Digest::SHA::hmac_sha1, },
84             SHA256 => { minv => 'v2',
85             v2max => 1, # best encryption for v2
86             len => 32,
87             fn => \&Digest::SHA::sha256,
88             macfn => \&Digest::SHA::hmac_sha256, },
89             # doubtless there will be more...
90             );
91             foreach my $SHAX (keys %_sha_fns) {
92             my $s = $_sha_fns{$SHAX};
93             my $a_type = { name => "HMAC-${SHAX}", map {$_,$s->{$_}} qw(len macfn) };
94             my $s_type = { name => "DH-${SHAX}", map {$_,$s->{$_}} qw(len fn) };
95             my $seen_minv = 0;
96             foreach my $v (qw(v1 v2)) {
97             $seen_minv = 1 if $v eq $s->{minv};
98             next unless $seen_minv;
99             $_assoc_types{$v}{$a_type->{name}} = $a_type;
100             $_session_types{$v}{$s_type->{name}} = $s_type;
101             if ($s->{"${v}max"}) {
102             $_assoc_types{MAX}{$v} = $a_type;
103             $_session_types{MAX}{$v} = $s_type;
104             }
105             }
106             $_assoc_macfn{$a_type->{name}} = $a_type->{macfn};
107             }
108             }
109             ################################################################
110              
111             sub new {
112             my Net::OpenID::Association $self = shift;
113             $self = fields::new( $self ) unless ref $self;
114             my %opts = @_;
115             for my $f (qw( server secret handle expiry type )) {
116             $self->{$f} = delete $opts{$f};
117             }
118             Carp::croak("unknown options: " . join(", ", keys %opts)) if %opts;
119             return $self;
120             }
121              
122             sub handle {
123             my $self = shift;
124             die if @_;
125             $self->{'handle'};
126             }
127              
128             sub secret {
129             my $self = shift;
130             die if @_;
131             $self->{'secret'};
132             }
133              
134             sub type {
135             my $self = shift;
136             die if @_;
137             $self->{'type'};
138             }
139              
140             sub generate_signature {
141             my Net::OpenID::Association $self = shift;
142             my $string = shift;
143             return OpenID::util::b64($_assoc_macfn{$self->type}->($string, $self->secret));
144             }
145              
146             sub server {
147             my Net::OpenID::Association $self = shift;
148             Carp::croak("Too many parameters") if @_;
149             return $self->{server};
150             }
151              
152             sub expired {
153             my Net::OpenID::Association $self = shift;
154             return time() > $self->{'expiry'};
155             }
156              
157             sub usable {
158             my Net::OpenID::Association $self = shift;
159             return 0 unless $self->{'handle'} =~ /^[\x21-\x7e]{1,255}$/;
160             return 0 unless $self->{'expiry'} =~ /^\d+$/;
161             return 0 unless $self->{'secret'};
162             return 0 if $self->expired;
163             return 1;
164             }
165              
166              
167             # server_assoc(CSR, SERVER, FORCE_REASSOCIATE, OPTIONS...)
168             #
169             # Return an association for SERVER (provider), whether already
170             # cached and not yet expired, or freshly negotiated.
171             # Return undef if no local storage/cache is available
172             # or negotiation fails for whatever reason,
173             # in which case the caller goes into dumb consumer mode.
174             # FORCE_REASSOCIATE true => ignore the cache
175             # OPTIONS... are passed to new_server_assoc()
176             #
177             sub server_assoc {
178             my ($csr, $server, $force_reassociate, @opts) = @_;
179              
180             # closure to return undef (dumb consumer mode) and log why
181             my $dumb = sub {
182             $csr->_debug("server_assoc: dumb mode: $_[0]");
183             return undef;
184             };
185              
186             my $cache = $csr->cache;
187             return $dumb->("no_cache") unless $cache;
188              
189             unless ($force_reassociate) {
190             # try first from cached association handle
191             if (my $handle = $cache->get("shandle:$server")) {
192             my $assoc = handle_assoc($csr, $server, $handle);
193              
194             if ($assoc && $assoc->usable) {
195             $csr->_debug("Found association from cache (handle=$handle)");
196             return $assoc;
197             }
198             }
199             }
200              
201             # make a new association
202             my ($assoc, $err, $retry) = new_server_assoc($csr, $server, @opts);
203             return $dumb->($err)
204             if $err;
205             ($assoc, $err) = new_server_assoc($csr, $server, @opts, %$retry)
206             if $retry;
207             return $dumb->($err || 'second_retry')
208             unless $assoc;
209              
210             my $ahandle = $assoc->handle;
211             $cache->set("hassoc:$server:$ahandle", Storable::freeze({%$assoc}));
212             $cache->set("shandle:$server", $ahandle);
213              
214             # now we test that the cache object given to us actually works. if it
215             # doesn't, it'll also fail later, making the verify fail, so let's
216             # go into stateless (dumb mode) earlier if we can detect this.
217             $cache->get("shandle:$server")
218             or return $dumb->("cache_broken");
219              
220             return $assoc;
221             }
222              
223             # new_server_assoc(CSR, SERVER, OPTIONS...)
224             #
225             # Attempts to negotiate a fresh association from C<$server> (provider)
226             # with session and association types determined by OPTIONS...
227             # (accepts protocol_version and all assoc_options from Consumer,
228             # however max_encrypt and session_no_encrypt_https are ignored
229             # if assoc_type and session_type are passed directly as hashes)
230             # Returns
231             # ($association) on success
232             # (undef, $error_message) on unrecoverable failure
233             # (undef, undef, {retry...}) if identity provider suggested
234             # alternate session/assoc types in an error response
235             #
236             sub new_server_assoc {
237             my ($csr, $server, %opts) = @_;
238             my $server_is_https = lc($server) =~ m/^https:/;
239             my $protocol_version = delete $opts{protocol_version} || 1;
240             my $version_key = _version_key_from_numeric($protocol_version);
241             my $allow_eavesdropping = (delete $opts{allow_eavesdropping} || 0) && $protocol_version < 2;
242              
243             my $a_maxencrypt = delete $opts{max_encrypt} || 0;
244             my $s_noencrypt = delete $opts{session_no_encrypt_https} && $server_is_https;
245              
246             my $s_type = delete $opts{session_type} || "DH-SHA1";
247             unless (ref $s_type) {
248             if ($s_noencrypt) {
249             $s_type = $_session_types{NO}{$version_key};
250             }
251             elsif ($a_maxencrypt) {
252             $s_type = $_session_types{MAX}{$version_key};
253             }
254             }
255              
256             my $a_type = delete $opts{assoc_type} || "HMAC-SHA1";
257             unless (ref $a_type) {
258             $a_type = $_assoc_types{MAX}{$version_key}
259             if $a_maxencrypt;
260             }
261              
262             Carp::croak("unknown options: " . join(", ", keys %opts)) if %opts;
263              
264             $a_type = $_assoc_types{$version_key}{$a_type} unless ref $a_type;
265             Carp::croak("unknown association type") unless $a_type;
266              
267             $s_type = $_session_types{$version_key}{$s_type} unless ref $s_type;
268             Carp::croak("unknown session type") unless $s_type;
269              
270             my $error = sub { return (undef, $_[0].($_[1]?" ($_[1])":'')); };
271              
272             return $error->("incompatible_session_type")
273             unless _compatible_stype_atype($s_type, $a_type);
274              
275             return $error->("https_required")
276             if $s_type->{https} && !$server_is_https && !$allow_eavesdropping;
277              
278             my %post = ( "openid.mode" => "associate" );
279             $post{'openid.ns'} = OpenID::util::version_2_namespace()
280             if $protocol_version == 2;
281             $post{'openid.assoc_type'} = $a_type->{name};
282             $post{'openid.session_type'} = $s_type->{name} if $s_type->{name};
283              
284             my $dh;
285             if ($s_type->{fn}) {
286             $dh = OpenID::util::get_dh();
287             $post{'openid.dh_consumer_public'} = OpenID::util::int2arg($dh->pub_key);
288             }
289              
290             my $req = HTTP::Request->new(POST => $server);
291             $req->header("Content-Type" => "application/x-www-form-urlencoded");
292             $req->content(join("&", map { "$_=" . uri_escape($post{$_}) } keys %post));
293              
294             $csr->_debug("Associate mode request: " . $req->content);
295              
296             my $ua = $csr->ua;
297             my $res = $ua->request($req);
298              
299             return $error->("http_no_response") unless $res;
300              
301             my $recv_time = time();
302             my $content = $res->content;
303             my %args = OpenID::util::parse_keyvalue($content);
304             $csr->_debug("Response to associate mode: [$content] parsed = " . join(",", %args));
305              
306             my $r_a_type = $_assoc_types{$version_key}{$args{'assoc_type'}};
307             my $r_s_type = $_session_types{$version_key}{$args{'session_type'}||''};
308              
309             unless ($res->is_success) {
310             # direct error
311             return $error->("http_failure_no_associate")
312             if ($protocol_version < 2);
313             return $error->("http_direct_error")
314             unless $args{'error_code'} eq 'unsupported_type';
315             return (undef,undef,{assoc_type => $r_a_type, session_type => $r_s_type})
316             if $r_a_type && $r_s_type && ($r_a_type != $a_type || $r_s_type != $s_type);
317             return $error->("unsupported_type");
318             }
319             return $error->("unknown_assoc_type",$args{'assoc_type'})
320             unless $r_a_type;
321             return $error->("unknown_session_type",$args{'session_type'})
322             unless $r_s_type;
323             return $error->("wrong_assoc_type",$r_a_type->{name})
324             unless $a_type == $r_a_type;
325             return $error->("wrong_session_type",$r_s_type->{name})
326             unless $s_type == $r_s_type || ($protocol_version < 2);
327              
328             # protocol version 1.1
329             my $expires_in = $args{'expires_in'};
330              
331             # protocol version 1.0 (DEPRECATED)
332             if (! $expires_in) {
333             if (my $issued = OpenID::util::w3c_to_time($args{'issued'})) {
334             my $expiry = OpenID::util::w3c_to_time($args{'expiry'});
335             my $replace_after = OpenID::util::w3c_to_time($args{'replace_after'});
336              
337             # seconds ahead (positive) or behind (negative) the provider is
338             $expires_in = ($replace_after || $expiry) - $issued;
339             }
340             }
341              
342             # between 1 second and 2 years
343             return $error->("bogus_expires_in")
344             unless $expires_in > 0 && $expires_in < 63072000;
345              
346             my $ahandle = $args{'assoc_handle'};
347              
348             my $secret;
349             unless ($r_s_type->{fn}) {
350             $secret = OpenID::util::d64($args{'mac_key'});
351             }
352             else {
353             my $server_pub = OpenID::util::arg2int($args{'dh_server_public'});
354             my $dh_sec = $dh->compute_secret($server_pub);
355             $secret = OpenID::util::d64($args{'enc_mac_key'})
356             ^ $r_s_type->{fn}->(OpenID::util::int2bytes($dh_sec));
357             }
358             return $error->("bad_secret_length")
359             if $r_s_type->{len} && length($secret) != $r_s_type->{len};
360              
361             my %assoc = (
362             handle => $ahandle,
363             server => $server,
364             secret => $secret,
365             type => $r_a_type->{name},
366             expiry => $recv_time + $expires_in,
367             );
368              
369             return Net::OpenID::Association->new( %assoc );
370             }
371              
372             # returns association, or undef if it can't be found
373             sub handle_assoc {
374             my ($csr, $server, $handle) = @_;
375              
376             # closure to return undef (dumb consumer mode) and log why
377             my $dumb = sub {
378             $csr->_debug("handle_assoc: dumb mode: $_[0]");
379             return undef;
380             };
381              
382             return $dumb->("no_handle") unless $handle;
383              
384             my $cache = $csr->cache;
385             return $dumb->("no_cache") unless $cache;
386              
387             my $frozen = $cache->get("hassoc:$server:$handle");
388             return $dumb->("not_in_cache") unless $frozen;
389              
390             my $param = eval { Storable::thaw($frozen) };
391             return $dumb->("not_a_hashref") unless ref $param eq "HASH";
392              
393             return Net::OpenID::Association->new( %$param );
394             }
395              
396             sub invalidate_handle {
397             my ($csr, $server, $handle) = @_;
398             my $cache = $csr->cache
399             or return;
400             $cache->set("hassoc:$server:$handle", "");
401             }
402              
403             1;
404              
405             __END__