File Coverage

blib/lib/Net/OpenID/VerifiedIdentity.pm
Criterion Covered Total %
statement 12 140 8.5
branch 0 74 0.0
condition 0 10 0.0
subroutine 4 28 14.2
pod 11 15 73.3
total 27 267 10.1


line stmt bran cond sub pod time code
1 6     6   71 use strict;
  6         11  
  6         150  
2 6     6   31 use Carp ();
  6         11  
  6         318  
3              
4             ############################################################################
5             package Net::OpenID::VerifiedIdentity;
6             $Net::OpenID::VerifiedIdentity::VERSION = '1.17';
7             use fields (
8 6         40 'identity', # the verified identity URL
9             'id_uri', # the verified identity's URI object
10              
11             'claimed_identity', # The ClaimedIdentity object that we've verified
12             'semantic_info', # The "semantic info" (RSS URLs, etc) at the verified identity URL
13              
14             'consumer', # The Net::OpenID::Consumer module which created us
15              
16             'signed_fields' , # hashref of key->value of things that were signed. without "openid." prefix
17             'signed_message', # the signed fields as an IndirectMessage object. Created when needed.
18 6     6   30 );
  6         11  
19 6     6   9111 use URI;
  6         51498  
  6         13060  
20              
21             sub new {
22 0     0 0   my Net::OpenID::VerifiedIdentity $self = shift;
23 0 0         $self = fields::new( $self ) unless ref $self;
24 0           my %opts = @_;
25              
26 0           $self->{'consumer'} = delete $opts{'consumer'};
27              
28 0 0         if ($self->{'claimed_identity'} = delete $opts{'claimed_identity'}) {
29 0           $self->{identity} = $self->{claimed_identity}->claimed_url;
30 0 0         unless ($self->{'id_uri'} = URI->new($self->{identity})) {
31 0           return $self->{'consumer'}->_fail("invalid_uri");
32             }
33             }
34              
35 0           for my $par (qw(signed_fields)) {
36 0           $self->$par(delete $opts{$par});
37             }
38              
39 0 0         Carp::croak("Unknown options: " . join(", ", keys %opts)) if %opts;
40 0           return $self;
41             }
42              
43             sub url {
44 0     0 1   my Net::OpenID::VerifiedIdentity $self = shift;
45 0           return $self->{'identity'};
46             }
47              
48             sub display {
49 0     0 1   my Net::OpenID::VerifiedIdentity $self = shift;
50 0           return DisplayOfURL($self->{'identity'});
51             }
52              
53             sub _semantic_info_hash {
54 0     0     my ($self) = @_;
55 0 0         return $self->{semantic_info} if $self->{semantic_info};
56 0           my $sem_info = $self->{claimed_identity}->semantic_info;
57             $self->{semantic_info} = {
58             'foaf' => $self->_identity_relative_uri($sem_info->{"foaf"}),
59             'foafmaker' => $sem_info->{"foaf.maker"},
60             'rss' => $self->_identity_relative_uri($sem_info->{"rss"}),
61 0           'atom' => $self->_identity_relative_uri($sem_info->{"atom"}),
62             };
63 0           return $self->{semantic_info};
64             }
65              
66             sub _identity_relative_uri {
67 0     0     my $self = shift;
68 0           my $url = shift;
69              
70 0 0         return $url if ref $url;
71 0 0         return undef unless $url;
72 0           return URI->new_abs($url, $self->{'id_uri'});
73             }
74              
75 0     0 0   sub signed_fields { &_getset; }
76              
77 0     0 1   sub foaf { &_getset_semurl; }
78 0     0 1   sub rss { &_getset_semurl; }
79 0     0 1   sub atom { &_getset_semurl; }
80 0     0 1   sub foafmaker { &_getset_sem; }
81              
82 0     0 1   sub declared_foaf { &_dec_semurl; }
83 0     0 1   sub declared_rss { &_dec_semurl; }
84 0     0 1   sub declared_atom { &_dec_semurl; }
85              
86             sub extension_fields {
87 0     0 1   my ($self, $ns_uri) = @_;
88 0           return $self->_extension_fields($ns_uri, $self->{consumer}->message);
89             }
90              
91             sub signed_extension_fields {
92 0     0 1   my ($self, $ns_uri) = @_;
93              
94 0           return $self->_extension_fields($ns_uri, $self->signed_message);
95             }
96              
97             sub _extension_fields {
98 0     0     my ($self, $ns_uri, $args) = @_;
99              
100 0           return $args->get_ext($ns_uri);
101             }
102              
103             sub signed_message {
104 0     0 0   my ($self) = @_;
105              
106 0 0         return $self->{signed_message} if $self->{signed_message};
107              
108             # This is maybe a bit hacky.
109             # We need to synthesize an IndirectMessage object
110             # representing the signed fields, which means
111             # that we need to fake up the mandatory message
112             # arguments that probably weren't signed.
113              
114 0           my %args = map { 'openid.'.$_ => $self->{signed_fields}{$_} } keys %{$self->{signed_fields}};
  0            
  0            
115              
116 0           my $real_message = $self->{consumer}->message;
117 0 0         if ($real_message->protocol_version == 1) {
118             # OpenID 1.1 just needs a mode.
119 0           $args{'openid.mode'} = 'id_res';
120             }
121             else {
122             # OpenID 2.2 needs the namespace URI as well
123 0           $args{'openid.ns'} = 'http://specs.openid.net/auth/2.0';
124 0           $args{'openid.mode'} = 'id_res';
125             }
126              
127 0           my $message = Net::OpenID::IndirectMessage->new(\%args);
128              
129 0           return $self->{signed_message} = $message;
130             }
131              
132             sub _getset {
133 0     0     my $self = shift;
134 0           my $param = (caller(1))[3];
135 0           $param =~ s/.+:://;
136              
137 0 0         if (@_) {
138 0           my $val = shift;
139 0 0         Carp::croak("Too many parameters") if @_;
140 0           $self->{$param} = $val;
141             }
142 0           return $self->{$param};
143             }
144              
145             sub _getset_sem {
146 0     0     my $self = shift;
147 0           my $param = (caller(1))[3];
148 0           $param =~ s/.+:://;
149              
150 0           my $info = $self->_semantic_info_hash;
151              
152 0 0         if (my $value = shift) {
153 0 0         Carp::croak("Too many parameters") if @_;
154 0           $info->{$param} = $value;
155             }
156 0           return $info->{$param};
157             }
158              
159             sub _getset_semurl {
160 0     0     my $self = shift;
161 0           my $param = (caller(1))[3];
162 0           $param =~ s/.+:://;
163              
164 0           my $info = $self->_semantic_info_hash;
165              
166 0 0         if (my $surl = shift) {
167 0 0         Carp::croak("Too many parameters") if @_;
168              
169             # TODO: make absolute URL from possibly relative one
170 0           my $abs = URI->new_abs($surl, $self->{'id_uri'});
171 0           $info->{$param} = $abs;
172             }
173              
174 0           my $uri = $info->{$param};
175 0 0 0       return $uri && _url_is_under($self->{'id_uri'}, $uri) ? $uri->as_string : undef;
176             }
177              
178             sub _dec_semurl {
179 0     0     my $self = shift;
180 0           my $param = (caller(1))[3];
181 0           $param =~ s/.+::declared_//;
182              
183 0           my $info = $self->_semantic_info_hash;
184              
185 0           my $uri = $info->{$param};
186 0 0         return $uri ? $uri->as_string : undef;
187             }
188              
189             sub DisplayOfURL {
190 0     0 0   my $url = shift;
191 0           my $dev_mode = shift;
192              
193 0 0         return $url unless
194             $url =~ m!^https?://([^/]+)(/.*)?$!;
195              
196 0           my ($host, $path) = ($1, $2);
197 0           $host = lc($host);
198              
199 0 0         if ($dev_mode) {
200 0           $host =~ s!^dev\.!!;
201 0           $host =~ s!:\d+!!;
202             }
203              
204 0           $host =~ s/:.+//;
205 0           $host =~ s/^www\.//i;
206              
207 0 0         if (length($path) <= 1) {
208 0           return $host;
209             }
210              
211             # obvious username
212 0 0 0       if ($path =~ m!^/~([^/]+)/?$! ||
213             $path =~ m!^/(?:users?|members?)/([^/]+)/?$!) {
214 0           return "$1 [$host]";
215             }
216              
217 0 0         if ($host =~ m!^profile\.(.+)!i) {
218 0           my $site = $1;
219 0 0         if ($path =~ m!^/([^/]+)/?$!) {
220 0           return "$1 [$site]";
221             }
222             }
223              
224 0           return $url;
225             }
226              
227             # FIXME: duplicated in Net::OpenID::Server
228             sub _url_is_under {
229 0     0     my ($root, $test, $err_ref) = @_;
230              
231             my $err = sub {
232 0 0   0     $$err_ref = shift if $err_ref;
233 0           return undef;
234 0           };
235              
236 0 0         my $ru = ref $root ? $root : URI->new($root);
237 0 0         return $err->("invalid root scheme") unless $ru->scheme =~ /^https?$/;
238 0 0         my $tu = ref $test ? $test : URI->new($test);
239 0 0         return $err->("invalid test scheme") unless $tu->scheme =~ /^https?$/;
240 0 0         return $err->("schemes don't match") unless $ru->scheme eq $tu->scheme;
241 0 0         return $err->("ports don't match") unless $ru->port == $tu->port;
242              
243             # check hostnames
244 0           my $ru_host = $ru->host;
245 0           my $tu_host = $tu->host;
246 0           my $wildcard_host = 0;
247 0 0         if ($ru_host =~ s!^\*\.!!) {
248 0           $wildcard_host = 1;
249             }
250 0 0         unless ($ru_host eq $tu_host) {
251 0 0         if ($wildcard_host) {
252 0 0         return $err->("host names don't match") unless
253             $tu_host =~ /\.\Q$ru_host\E$/;
254             } else {
255 0           return $err->("host names don't match");
256             }
257             }
258              
259             # check paths
260 0   0       my $ru_path = $ru->path || "/";
261 0   0       my $tu_path = $tu->path || "/";
262 0 0         $ru_path .= "/" unless $ru_path =~ m!/$!;
263 0 0         $tu_path .= "/" unless $tu_path =~ m!/$!;
264 0 0         return $err->("path not a subpath") unless $tu_path =~ m!^\Q$ru_path\E!;
265              
266 0           return 1;
267             }
268              
269             1;
270              
271             __END__