File Coverage

blib/lib/Net/OpenID/ClaimedIdentity.pm
Criterion Covered Total %
statement 12 97 12.3
branch 0 60 0.0
condition 0 14 0.0
subroutine 4 12 33.3
pod 6 8 75.0
total 22 191 11.5


line stmt bran cond sub pod time code
1 6     6   18 use strict;
  6         8  
  6         121  
2 6     6   18 use Carp ();
  6         6  
  6         214  
3              
4             ############################################################################
5             package Net::OpenID::ClaimedIdentity;
6             $Net::OpenID::ClaimedIdentity::VERSION = '1.18';
7             use fields (
8 6         23 'identity', # the canonical URL that was found, following redirects
9             'server', # author-identity identity provider endpoint
10             'consumer', # ref up to the Net::OpenID::Consumer which generated us
11             'delegate', # the delegated URL actually asserted by the provider
12             'protocol_version', # The version of the OpenID Authentication Protocol that is used
13             'semantic_info', # Stuff that we've discovered in the identifier page's metadata
14             'extension_args', # Extension arguments that the caller wants to add to the request
15 6     6   17 );
  6         7  
16              
17 6     6   2454 use Digest::SHA qw(hmac_sha1_hex);
  6         11692  
  6         4951  
18              
19             sub new {
20 0     0 0   my Net::OpenID::ClaimedIdentity $self = shift;
21 0 0         $self = fields::new( $self ) unless ref $self;
22 0           my %opts = @_;
23 0           for my $f (qw( identity server consumer delegate protocol_version semantic_info )) {
24 0           $self->{$f} = delete $opts{$f};
25             }
26              
27 0   0       $self->{protocol_version} ||= 1;
28 0 0 0       unless ($self->{protocol_version} == 1 || $self->{protocol_version} == 2) {
29 0           Carp::croak("Unsupported protocol version");
30             }
31              
32             # lowercase the scheme and hostname
33 0           $self->{'identity'} =~ s!^(https?://.+?)(/(?:.*))?$!lc($1) . $2!ie;
  0            
34              
35 0           $self->{extension_args} = {};
36              
37 0 0         Carp::croak("unknown options: " . join(", ", keys %opts)) if %opts;
38 0           return $self;
39             }
40              
41             sub claimed_url {
42 0     0 1   my Net::OpenID::ClaimedIdentity $self = shift;
43 0 0         Carp::croak("Too many parameters") if @_;
44 0           return $self->{'identity'};
45             }
46              
47             sub delegated_url {
48 0     0 1   my Net::OpenID::ClaimedIdentity $self = shift;
49 0 0         Carp::croak("Too many parameters") if @_;
50 0           return $self->{'delegate'};
51             }
52              
53             sub identity_server {
54 0     0 1   my Net::OpenID::ClaimedIdentity $self = shift;
55 0 0         Carp::croak("Too many parameters") if @_;
56 0           return $self->{server};
57             }
58              
59             sub protocol_version {
60 0     0 1   my Net::OpenID::ClaimedIdentity $self = shift;
61 0 0         Carp::croak("Too many parameters") if @_;
62 0           return $self->{protocol_version};
63             }
64              
65             sub semantic_info {
66 0     0 0   my Net::OpenID::ClaimedIdentity $self = shift;
67 0 0         Carp::croak("Too many parameters") if @_;
68 0 0         return $self->{semantic_info} if $self->{semantic_info};
69 0           my $final_url = '';
70 0           my $info = $self->{consumer}->_find_semantic_info($self->claimed_url, \$final_url);
71             # Don't return anything if the URL has changed. Something bad may be happening.
72 0 0         $info = {} if $final_url ne $self->claimed_url;
73 0           return $self->{semantic_info} = $info;
74             }
75              
76             sub set_extension_args {
77 0     0 1   my Net::OpenID::ClaimedIdentity $self = shift;
78 0           my $ext_uri = shift;
79 0           my $args = shift;
80 0 0         Carp::croak("Too many parameters") if @_;
81 0 0         Carp::croak("No extension URI given") unless $ext_uri;
82 0 0 0       Carp::croak("Expecting hashref of args") if defined($args) && ref $args ne 'HASH';
83              
84 0           $self->{extension_args}{$ext_uri} = $args;
85             }
86              
87             sub check_url {
88 0     0 1   my Net::OpenID::ClaimedIdentity $self = shift;
89 0           my (%opts) = @_;
90              
91 0           my $return_to = delete $opts{'return_to'};
92 0           my $trust_root = delete $opts{'trust_root'};
93 0           my $delayed_ret = delete $opts{'delayed_return'};
94 0           my $force_reassociate = delete $opts{'force_reassociate'};
95 0           my $use_assoc_handle = delete $opts{'use_assoc_handle'};
96 0           my $actually_return_association = delete $opts{'actually_return_association'};
97              
98 0 0         Carp::croak("Unknown options: " . join(", ", keys %opts)) if %opts;
99 0 0         Carp::croak("Invalid/missing return_to") unless $return_to =~ m!^https?://!;
100              
101 0           my $csr = $self->{consumer};
102              
103             my $ident_server = $self->{server} or
104 0 0         Carp::croak("No identity server");
105              
106             # get an assoc (or undef for dumb mode)
107 0           my $assoc;
108 0 0         if ($use_assoc_handle) {
109 0           $assoc = Net::OpenID::Association::handle_assoc($csr, $ident_server, $use_assoc_handle);
110             } else {
111             $assoc = Net::OpenID::Association::server_assoc($csr, $ident_server, $force_reassociate, (
112 0           %{$csr->assoc_options},
  0            
113             protocol_version => $self->protocol_version,
114             ));
115             }
116              
117             # for the openid-test project: (doing interop testing)
118 0 0         if ($actually_return_association) {
119 0           return $assoc;
120             }
121              
122 0   0       my $identity_arg = $self->{'delegate'} || $self->{'identity'};
123              
124             # make a note back to ourselves that we're using a delegate
125             # but only in the 1.1 case because 2.0 has a core field for this
126 0 0 0       if ($self->{'delegate'} && $self->protocol_version == 1) {
127             OpenID::util::push_url_arg(\$return_to,
128 0           "oic.identity", $self->{identity});
129             }
130              
131             # add a HMAC-signed time so we can verify the return_to URL wasn't spoofed
132 0           my $sig_time = time();
133 0           my $c_secret = $csr->_get_consumer_secret($sig_time);
134 0           my $sig = substr(hmac_sha1_hex($sig_time, $c_secret), 0, 20);
135 0           OpenID::util::push_url_arg(\$return_to,
136             "oic.time", "${sig_time}-$sig");
137              
138 0           my $curl = $ident_server;
139 0 0         if ($self->protocol_version == 1) {
    0          
140 0 0         OpenID::util::push_url_arg(\$curl,
    0          
    0          
141             "openid.mode" => ($delayed_ret ? "checkid_setup" : "checkid_immediate"),
142             "openid.identity" => $identity_arg,
143             "openid.return_to" => $return_to,
144              
145             ($trust_root ? (
146             "openid.trust_root" => $trust_root
147             ) : ()),
148              
149             ($assoc ? (
150             "openid.assoc_handle" => $assoc->handle
151             ) : ()),
152             );
153             }
154             elsif ($self->protocol_version == 2) {
155             # NOTE: OpenID Auth 2.0 uses different terminology for a bunch
156             # of things than 1.1 did. This library still uses the 1.1 terminology
157             # in its API.
158 0 0         OpenID::util::push_openid2_url_arg(\$curl,
    0          
    0          
159             "mode" => ($delayed_ret ? "checkid_setup" : "checkid_immediate"),
160             "claimed_id" => $self->claimed_url,
161             "identity" => $identity_arg,
162             "return_to" => $return_to,
163              
164             ($trust_root ? (
165             "realm" => $trust_root
166             ) : ()),
167              
168             ($assoc ? (
169             "assoc_handle" => $assoc->handle
170             ) : ()),
171             );
172             }
173              
174             # Finally we add in the extension arguments, if any
175 0           my %ext_url_args = ();
176 0           my $ext_idx = 1;
177 0           foreach my $ext_uri (keys %{$self->{extension_args}}) {
  0            
178 0           my $ext_alias;
179              
180 0 0         if ($ext_uri eq "http://openid.net/extensions/sreg/1.1") {
    0          
181             # For OpenID 1.1 only the "SREG" extension is allowed,
182             # and it must use the "openid.sreg." prefix.
183 0           $ext_alias = "sreg";
184             }
185             elsif ($self->protocol_version < 2) {
186 0           next;
187             }
188             else {
189 0           $ext_alias = 'e'.($ext_idx++);
190             }
191 0           $ext_url_args{'openid.ns.'.$ext_alias} = $ext_uri;
192              
193 0           foreach my $k (keys %{$self->{extension_args}{$ext_uri}}) {
  0            
194 0           $ext_url_args{'openid.'.$ext_alias.'.'.$k} = $self->{extension_args}{$ext_uri}{$k};
195             }
196             }
197 0 0         OpenID::util::push_url_arg(\$curl, %ext_url_args) if %ext_url_args;
198              
199 0           $self->{consumer}->_debug("check_url for (del=$self->{delegate}, id=$self->{identity}) = $curl");
200 0           return $curl;
201             }
202              
203              
204             1;
205              
206             __END__