File Coverage

blib/lib/Mojolicious/Plugin/XRD.pm
Criterion Covered Total %
statement 37 91 40.6
branch 10 66 15.1
condition 11 32 34.3
subroutine 6 8 75.0
pod 1 1 100.0
total 65 198 32.8


line stmt bran cond sub pod time code
1             package Mojolicious::Plugin::XRD;
2 2     2   1824 use Mojo::Base 'Mojolicious::Plugin';
  2         5  
  2         17  
3 2     2   436 use Mojo::Util qw/quote deprecated/;
  2         14  
  2         3131  
4            
5             our $VERSION = '0.24';
6            
7             # Todo: Support
8             # $self->reply->xrd( $xrd => {
9             # resource => 'acct:akron@sojolicious.example',
10             # expires => (30 * 24 * 60 * 60),
11             # cache => ...,
12             # chi => ...
13             # });
14             #
15             # - Add Acceptance for XRD and JRD and JSON as a header
16            
17             # UserAgent name
18             my $UA_NAME = __PACKAGE__ . ' v' . $VERSION;
19            
20             # UserAgent maximum redirects
21             my $UA_MAX_REDIRECTS = 10;
22            
23             # UserAgent connect timeout
24             my $UA_CONNECT_TIMEOUT = 7;
25            
26            
27             # Register Plugin
28             sub register {
29 2     2 1 76 my ($plugin, $mojo) = @_;
30            
31             # Add types
32 2         17 for ($mojo->types) {
33 2         52 $_->type(jrd => 'application/jrd+json');
34 2         108 $_->type(xrd => 'application/xrd+xml');
35             };
36            
37             my $reply_xrd = sub {
38 14     14   66072 my ($c, $xrd, $res) = @_;
39            
40             # Define xrd or jrd
41 14 50       44 unless ($c->stash('format')) {
42 14   100     187 $c->stash('format' => (
43             scalar $c->param('_format') || scalar $c->param('format')
44             ));
45             };
46            
47             # Add CORS header
48 14         3454 $c->res->headers->header(
49             'Access-Control-Allow-Origin' => '*'
50             );
51            
52 14         551 my $status = 200;
53            
54             # Not found
55 14 100 66     81 if (!defined $xrd || !ref($xrd)) {
    100          
56 6         9 $status = 404;
57 6         19 $xrd = $c->helpers->new_xrd;
58 6 50       1263 $xrd->subject("$res") if $res;
59             }
60            
61             # rel parameter
62             elsif ($c->param('rel')) {
63            
64             # Clone and filter relations
65 6         345 $xrd = $xrd->filter_rel( $c->every_param('rel') );
66             };
67            
68 14 100       53048 my $head_data = $c->req->method eq 'HEAD' ? '' : undef;
69            
70             # content negotiation
71             return $c->respond_to(
72            
73             # JSON request
74 2   66     929 json => sub { $c->render(
75             status => $status,
76             data => $head_data // $xrd->to_json,
77             format => 'json'
78             )},
79            
80             # JRD request
81 2   66     943 jrd => sub { $c->render(
82             status => $status,
83             data => $head_data // $xrd->to_json,
84             format => 'jrd'
85             )},
86            
87             # XML default
88 10   66     5059 any => sub { $c->render(
89             status => $status,
90             data => $head_data // $xrd->to_pretty_xml,
91             format => 'xrd'
92             )}
93 14         336 );
94 2         32 };
95            
96             # Add DEPRECATED 'render_xrd' helper
97             $mojo->helper(
98             render_xrd => sub {
99 8     8   294778 deprecated 'render_xrd is deprecated in favor of reply->xrd';
100 8         2142 $reply_xrd->(@_)
101             }
102 2         17 );
103            
104             # Add 'reply->xrd' helper
105 2         286 $mojo->helper( 'reply.xrd' => $reply_xrd);
106            
107             # Add 'get_xrd' helper
108 2         1588 $mojo->helper( get_xrd => \&_get_xrd );
109            
110             # Add 'new_xrd' helper
111 2 50       185 unless (exists $mojo->renderer->helpers->{'new_xrd'}) {
112 2         30 $mojo->plugin('XML::Loy' => {
113             new_xrd => [-XRD]
114             });
115             };
116             };
117            
118             # Get XRD document
119             sub _get_xrd {
120 1     1   15375 my $c = shift;
121 1         10 my $resource = Mojo::URL->new( shift );
122            
123             # Trim tail
124 1   33     365 pop while @_ && !defined $_[-1];
125            
126             # No valid resource
127 1 50       6 return unless $resource->host;
128            
129 0           my $header = {};
130 0 0 0       if ($_[0] && ref $_[0] && ref $_[0] eq 'HASH') {
      0        
131 0           $header = shift;
132             };
133            
134             # Check if security is forced
135 0           my $prot = $resource->protocol;
136 0           my $secure;
137 0 0 0       $secure = 1 if $prot && $prot eq 'https';
138            
139             # Get callback
140 0 0 0       my $cb = pop if ref($_[-1]) && ref($_[-1]) eq 'CODE';
141            
142             # Build relations parameter
143 0           my $rel;
144 0 0 0       $rel = shift if $_[0] && ref $_[0] eq 'ARRAY';
145            
146             # Get secure user agent
147 0 0         my $ua = Mojo::UserAgent->new(
148             name => $UA_NAME,
149             max_redirects => ($secure ? 0 : $UA_MAX_REDIRECTS),
150             connect_timeout => $UA_CONNECT_TIMEOUT
151             );
152            
153 0           my $xrd;
154            
155             # Set to secure, if not defined
156 0 0         $resource->scheme('https') unless $resource->scheme;
157            
158             # Get helpers proxy object
159 0           my $h = $c->helpers;
160            
161             # Is blocking
162 0 0         unless ($cb) {
163            
164             # Fetch Host-Meta XRD - first try ssl
165 0           my $tx = $ua->get($resource => $header);
166 0           my $xrd_res;
167            
168             # Transaction was not successful
169 0 0         return unless $xrd_res = $tx->success;
170            
171 0 0         unless ($xrd_res->is_success) {
172            
173             # Only support secure retrieval
174 0 0         return if $secure;
175            
176             # Was already insecure
177 0 0         return if $resource->protocol eq 'http';
178            
179             # Make request insecure
180 0           $resource->scheme('http');
181            
182             # Update insecure max_redirects;
183 0           $ua->max_redirects($UA_MAX_REDIRECTS);
184            
185             # Then try insecure
186 0           $tx = $ua->get($resource => $header);
187            
188             # Transaction was not successful
189 0 0         return unless $xrd_res = $tx->success;
190            
191             # Retrieval was successful
192 0 0         return unless $xrd_res->is_success;
193             };
194            
195             # Parse xrd document
196 0 0         $xrd = $h->new_xrd($xrd_res->body) or return;
197            
198             # Filter relations
199 0 0         $xrd = $xrd->filter_rel($rel) if $rel;
200            
201             # Return xrd
202 0 0         return ($xrd, $xrd_res->headers->clone) if wantarray;
203 0           return $xrd;
204             };
205            
206             # Non-blocking
207             # Create delay for https with or without redirection
208             my $delay = Mojo::IOLoop->delay(
209             sub {
210 0     0     my $delay = shift;
211            
212             # Get with https - possibly without redirects
213 0           $ua->get($resource => $header => $delay->begin);
214             },
215             sub {
216 0     0     my ($delay, $tx) = @_;
217            
218             # Get response
219 0 0         if (my $xrd_res = $tx->success) {
220            
221             # Fine
222 0 0         if ($xrd_res->is_success) {
223            
224             # Parse xrd document
225 0 0         $xrd = $h->new_xrd($xrd_res->body) or return $cb->(undef);
226            
227             # Filter relations
228 0 0         $xrd = $xrd->filter_rel($rel) if $rel;
229            
230             # Send to callback
231 0           return $cb->($xrd, $xrd_res->headers->clone);
232             };
233            
234             # Only support secure retrieval
235 0 0         return $cb->(undef) if $secure;
236             }
237            
238             # Fail
239             else {
240 0           return $cb->(undef);
241             };
242            
243             # Was already insecure
244 0 0         return if $resource->protocol eq 'http';
245            
246             # Try http with redirects
247             $delay->steps(
248             sub {
249 0           my $delay = shift;
250            
251 0           $resource->scheme('http');
252            
253             # Get with http and redirects
254 0           $ua->max_redirects($UA_MAX_REDIRECTS);
255 0           $ua->get($resource => $header => $delay->begin );
256             },
257             sub {
258 0           my $delay = shift;
259            
260             # Transaction was successful
261 0 0         if (my $xrd_res = pop->success) {
262            
263             # Parse xrd document
264 0 0         $xrd = $h->new_xrd($xrd_res->body) or return $cb->(undef);
265            
266             # Filter relations
267 0 0         $xrd = $xrd->filter_rel($rel) if $rel;
268            
269             # Send to callback
270 0           return $cb->($xrd, $xrd_res->headers->clone);
271             };
272            
273             # Fail
274 0           return $cb->(undef);
275 0           });
276             }
277 0           );
278            
279             # Wait if IOLoop is not running
280 0 0         $delay->wait unless Mojo::IOLoop->is_running;
281 0           return;
282             };
283            
284            
285             1;
286            
287            
288             __END__