1use strict;
2use Carp ();
3
4############################################################################
5package Net::OpenID::Association;
6$Net::OpenID::Association::VERSION = '1.18';
7use fields (
8            '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            );
14
15use Storable ();
16use Digest::SHA ();
17use Net::OpenID::Common;
18use 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#
29my %_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#
39my %_assoc_types   = ();
40# {versionkey}{name} -> association type
41# {MAX}{versionkey}  -> strongest encryption atype for this version
42
43my %_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)
54sub _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?
59sub _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
111sub 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
122sub handle {
123    my $self = shift;
124    die if @_;
125    $self->{'handle'};
126}
127
128sub secret {
129    my $self = shift;
130    die if @_;
131    $self->{'secret'};
132}
133
134sub type {
135    my $self = shift;
136    die if @_;
137    $self->{'type'};
138}
139
140sub 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
146sub server {
147    my Net::OpenID::Association $self = shift;
148    Carp::croak("Too many parameters") if @_;
149    return $self->{server};
150}
151
152sub expired {
153    my Net::OpenID::Association $self = shift;
154    return time() > $self->{'expiry'};
155}
156
157sub 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#
177sub 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#
236sub 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
373sub 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
396sub invalidate_handle {
397    my ($csr, $server, $handle) = @_;
398    my $cache = $csr->cache
399        or return;
400    $cache->set("hassoc:$server:$handle", "");
401}
402
4031;
404
405__END__
406
407=head1 NAME
408
409Net::OpenID::Association - A relationship with an identity provider
410
411=head1 VERSION
412
413version 1.18
414
415=head1 DESCRIPTION
416
417Internal class.
418
419=head1 COPYRIGHT, WARRANTY, AUTHOR
420
421See L<Net::OpenID::Consumer> for author, copyright and licensing information.
422
423=head1 SEE ALSO
424
425L<Net::OpenID::Consumer>
426
427L<Net::OpenID::VerifiedIdentity>
428
429L<Net::OpenID::Server>
430
431Website:  L<http://openid.net/>
432