File Coverage

blib/lib/Net/OpenID/URIFetch.pm
Criterion Covered Total %
statement 47 102 46.0
branch 0 22 0.0
condition 0 11 0.0
subroutine 15 20 75.0
pod 0 1 0.0
total 62 156 39.7


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2              
3             =head1 NAME
4              
5             Net::OpenID::URIFetch - fetch and cache content from HTTP URLs
6              
7             =head1 VERSION
8              
9             version 1.19
10              
11             =head1 DESCRIPTION
12              
13             This is roughly based on Ben Trott's URI::Fetch module, but
14             URI::Fetch doesn't cache enough headers that Yadis can be implemented
15             with it, so this is a lame copy altered to allow Yadis support.
16              
17             Hopefully one day URI::Fetch can be modified to do what we need and
18             this can go away.
19              
20             This module is tailored to the needs of Net::OpenID::Consumer and probably
21             isn't much use outside of it. See URI::Fetch for a more general module.
22              
23             =cut
24              
25             package Net::OpenID::URIFetch;
26             {
27             $Net::OpenID::URIFetch::VERSION = '1.19';
28             }
29              
30 2     2   21945 use HTTP::Request;
  2         52090  
  2         58  
31 2     2   1482 use HTTP::Status;
  2         8319  
  2         653  
32 2     2   11 use strict;
  2         4  
  2         39  
33 2     2   10 use warnings;
  2         3  
  2         46  
34 2     2   10 use Carp();
  2         4  
  2         42  
35              
36 2     2   10 use constant URI_OK => 200;
  2         4  
  2         204  
37 2     2   11 use constant URI_MOVED_PERMANENTLY => 301;
  2         2  
  2         90  
38 2     2   9 use constant URI_NOT_MODIFIED => 304;
  2         4  
  2         81  
39 2     2   10 use constant URI_GONE => 410;
  2         4  
  2         1697  
40              
41             # Fetch a document, either from cache or from a server
42             # URI -- location of document
43             # CONSUMER -- where to find user-agent and cache
44             # CONTENT_HOOK -- applied to freshly-retrieved document
45             # to normalize it into some particular format/structure
46             # PREFIX -- used as part of the cache key, distinguishes
47             # different content formats and must change whenever
48             # CONTENT_HOOK is switched to a new format; this way,
49             # cache entries from a previous run of this server that
50             # are using a different content format will not kill us.
51             sub fetch {
52 0     0 0   my ($class, $uri, $consumer, $content_hook, $prefix) = @_;
53 0   0       $prefix ||= '';
54              
55 0 0         if ($uri eq 'x-xrds-location') {
56 0           Carp::confess("Buh?");
57             }
58              
59 0           my $ua = $consumer->ua;
60 0           my $cache = $consumer->cache;
61 0           my $ref;
62              
63 0           my $cache_key = "URIFetch:${prefix}:${uri}";
64              
65 0 0         if ($cache) {
66 0 0         if (my $blob = $cache->get($cache_key)) {
67 0           $ref = Storable::thaw($blob);
68             }
69             }
70             my $cached_response = sub {
71             return Net::OpenID::URIFetch::Response->new(
72             status => 200,
73             content => $ref->{Content},
74             last_modified => $ref->{LastModified},
75             headers => $ref->{Headers},
76             final_uri => $ref->{FinalURI},
77 0     0     );
78 0           };
79              
80             # We just serve anything from the last 60 seconds right out of the cache,
81             # thus avoiding doing several requests to the same URL when we do
82             # Yadis, then HTML discovery.
83             # TODO: Make this tunable?
84 0 0 0       if ($ref && $ref->{CacheTime} > (time() - 60)) {
85 0           $consumer->_debug("Cache HIT for $uri");
86 0           return $cached_response->();
87             }
88             else {
89 0           $consumer->_debug("Cache MISS for $uri");
90             }
91              
92 0           my $req = HTTP::Request->new(GET => $uri);
93 0           $req->header('Accept-Encoding', scalar HTTP::Message::decodable());
94 0 0         if ($ref) {
95 0 0         if (my $etag = ($ref->{Headers}->{etag})) {
96 0           $req->header('If-None-Match', $etag);
97             }
98 0 0         if (my $ts = $ref->{LastModified}) {
99 0           $req->if_modified_since($ts);
100             }
101             }
102              
103 0           my $res = $ua->request($req);
104              
105             # There are only a few headers that OpenID/Yadis care about
106 0           my @useful_headers = qw(last-modified etag content-type x-yadis-location x-xrds-location);
107              
108 0           my %response_fields;
109              
110 0 0         if ($res->code == HTTP::Status::RC_NOT_MODIFIED()) {
111 0           $consumer->_debug("Server says it's not modified. Serving from cache.");
112 0           return $cached_response->();
113             }
114             else {
115 0           my $final_uri = $res->request->uri->as_string();
116 0           my $final_cache_key = "URIFetch:${prefix}:${final_uri}";
117              
118 0   0       my $content = $res->decoded_content # Decode content-encoding and charset
119             || $res->decoded_content(charset => 'none') # Decode content-encoding
120             || $res->content; # Undecoded content
121              
122 0 0         if ($content_hook) {
123 0           $content_hook->(\$content);
124             }
125              
126 0           my $headers = {};
127 0           foreach my $k (@useful_headers) {
128 0           $headers->{$k} = $res->header($k);
129             }
130              
131 0           my $ret = Net::OpenID::URIFetch::Response->new(
132             status => $res->code,
133             last_modified => $res->last_modified,
134             content => $content,
135             headers => $headers,
136             final_uri => $final_uri,
137             );
138              
139 0 0 0       if ($cache && $res->code == 200) {
140 0           my $cache_data = {
141             LastModified => $ret->last_modified,
142             Headers => $ret->headers,
143             Content => $ret->content,
144             CacheTime => time(),
145             FinalURI => $final_uri,
146             };
147 0           my $cache_blob = Storable::freeze($cache_data);
148 0           $cache->set($final_cache_key, $cache_blob);
149 0           $cache->set($cache_key, $cache_blob);
150             }
151              
152 0           return $ret;
153             }
154              
155             }
156              
157             package Net::OpenID::URIFetch::Response;
158             {
159             $Net::OpenID::URIFetch::Response::VERSION = '1.19';
160             }
161              
162 2     2   36 use strict;
  2         8  
  2         227  
163 2     2   17 use constant FIELDS => [qw(final_uri status content headers last_modified)];
  2         5  
  2         250  
164 2     2   2224 use fields @{FIELDS()};
  2         4557  
  2         6  
  2         18  
165 2     2   223 use Carp();
  2         5  
  2         323  
166              
167             sub new {
168 0     0     my ($class, %opts) = @_;
169 0           my $self = fields::new($class);
170 0           @{$self}{@{FIELDS()}} = delete @opts{@{FIELDS()}};
  0            
  0            
  0            
171 0 0         Carp::croak("Unknown option(s): " . join(", ", keys %opts)) if %opts;
172 0           return $self;
173             }
174              
175             BEGIN {
176 2     2   7 foreach my $field_name (@{FIELDS()}) {
  2         8  
177 2     2   12 no strict 'refs';
  2         5  
  2         179  
178 10         222 *{__PACKAGE__ . '::' . $field_name}
179 10     0   43 = sub { return $_[0]->{$field_name}; };
  0            
180             }
181             }
182              
183             sub header {
184 0     0     return $_[0]->{headers}{lc($_[1])};
185             }
186              
187             1;