File Coverage

blib/lib/Catalyst/Plugin/Cache/HTTP/Preempt.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

line	stmt	sub	time	code
1	1	1	2032	use utf8;
	1		11
	1		5
2				package Catalyst::Plugin::Cache::HTTP::Preempt;
3
4	1	1	62	use v5.10;
	1		3
	1		44
5
6	1	1	14	use strict;
	1		2
	1		31
7	1	1	6	use warnings;
	1		1
	1		30
8
9	1	1	433	use Moose::Role;
	0
	0
10
11				use Catalyst::Utils;
12				use DateTime;
13				use English qw( -no_match_vars );
14				use HTTP::Status qw( :constants );
15				use HTTP::Headers::ETag;
16				use List::Util ();
17				use Readonly;
18
19				Readonly::Scalar my $CONFIG_NAMESPACE => 'Plugin::Cache::HTTP::Preempt';
20
21				=head1 NAME
22
23				Catalyst::Plugin::Cache::HTTP::Preempt - preemptive HTTP cache control
24
25				=begin readme
26
27				=head1 VERSION
28
29				v0.1.3
30
31				=cut
32
33				use version 0.77; our $VERSION = version->declare("v0.1.3");
34
35				=head1 REQUIREMENTS
36
37				This module requires Perl v5.10 or later.
38
39				The following non-core Perl modules are required:
40
41				=over 4
42
43				=item Catalyst
44
45				=item DateTime
46
47				=item HTTP::Message 6.06
48
49				=item Moose
50
51				=item Readonly
52
53				=back
54
55				Additional modules may be required for running tests:
56
57				=over 4
58
59				=item DateTime::Format::HTTP
60
61				=item Digest::MD5
62
63				=item ok
64
65				=item Test::WWW::Mechanize::Catalyst
66
67				=item URI
68
69				=back
70
71				=end readme
72
73				=head1 DESCRIPTION
74
75				This is a L<Catalyst> plugin handles HTTP 1.1 cache-control queries.
76
77				The functionality is similar to L<Catalyst::Plugin::Cache::HTTP>,
78				except that it processes the cache control queries before
79				data-intensive queries, rather rather than delaying processing until
80				the view is generated.
81
82				=head1 SYNOPSIS
83
84				use Catalyst qw/
85				Cache::HTTP::Preempt
86				/;
87
88				__PACKAGE__->config(
89
90				'Plugin::Cache::HTTP::Preempt' => {
91
92				no_preempt_head => 0,
93
94				etag_generator => sub {
95				my ($c, $config) = @_;
96				return "W/" . sprintf("%x", $c->res->headers->last_modified);
97				},
98
99				},
100
101				);
102
103				=head1 CONFIGURATION OPTIONS
104
105				=over
106
107				=item no_preempt_head
108
109				By default, the L</not_cached> method will return C<false> for
110				C<HEAD> requests (even though it will still process cache control
111				headers).
112
113				If you still want to handle C<HEAD> requests, then set this option to
114				a C<true> value.
115
116				=item no_etag
117
118				Do not set the C<ETag> header.
119
120				=item no_last_modified
121
122				Do not set the C<Last-Modified> header.
123
124				=item no_expires
125
126				Do not set the C<Expires> header.
127
128				=item etag_generator
129
130				You can change how the C<ETag> is generated by using the
131				C<etag_generator> option:
132
133				sub etag_generator {
134				my ($c, $config) = @_;
135				my $mtime = $c->req->headers->last_modified;
136				return sprintf( $config->{strong} ? "%x" : "W/%x" , $mtime);
137				}
138
139				if ($c->not_cached({ etag_generator => \&etag_generator }) {
140				...
141				}
142
143				This is useful if you want to use something other than the
144				modification date of an entity for generating the C<ETag>.
145
146				The purpose of this function is to I<only> generate the C<ETag>. No
147				headers should be changed.
148
149				Returning an C<undef> value corresponds to not setting an C<ETag>.
150
151				=item strong
152
153				Generate a strong C<ETag>. By default, a weak C<ETag> is used, since
154				the C<ETag> is based on the C<Last-Modified> time rather than the
155				content.
156
157				As per the HTTP 1.1 specification, weak C<ETags> will not work with
158				the C<If-Match> header.
159
160				=item check_if_range
161
162				When this option, is true, it will check for the C<If-Range> and
163				C<Range> headers. The controller is responsible for sending the
164				correct response. (See the discussion for the L</not_cached> method
165				below.)
166
167				=back
168
169				=head1 METHODS
170
171				=cut
172
173
174				=head2 not_cached
175
176				$c->res->headers->last_modified( $obj->mtime );
177
178				...
179
180				if ($c->not_cached(\%options)) {
181
182				# The response is not cached, so should be generated
183
184				...
185
186				} else {
187
188				...
189
190				}
191
192				Checks the requests for HTTP 1.1 cache control headers and handles
193				them accordingly.
194
195				This method sets the C<ETag> header based on the C<Last-Modified>
196				header (unless one is already set) and checks for the
197				C<If-Modified-Since>, C<If-Unmodified-Since>, C<If-Match> and
198				C<If-None-Match> request headers to see if generating the entity can
199				be preempted.
200
201				If the entity can be preempted (i.e. if it has not been modified since
202				the given date), then the status is set appropriately, and this
203				method returns false.
204
205				Otherwise it returns true. This allows you to avoid reading data from
206				a database or otherwise data-intensive processing when it's not
207				actually needed.
208
209				If C<%options> are given, then they will override the L<global
210				options\|/CONFIGURATION OPTIONS>.
211
212				If the C<Last-Modified> header is unset, then this function
213				will assume the last-modification time is the current time.
214
215				If no C<Expires> header is set and the function will return a true
216				value, then it will set it to the current time. (This is important
217				for web browsers that aggressively cache responses, such as Firefox.)
218
219				Cache control options will be processed for C<HEAD> requests, but this
220				method will always return false, unless the C<no_preempt_head> option
221				is true.
222
223				If the status is already set to something other than C<2xx> when this
224				method is called, then the the C<If-Match>, C<If-None-Match> and
225				C<If-Unmodified-Since> headers will be ignored. However, the C<ETag>,
226				C<Expires> and C<Last-Modified> headers will still be set. (Ideally,
227				you would not be calling the L</not_cached> method if there is an
228				error.)
229
230				If the C<check_if_range> option is true, then you I<must> check
231				whether the status code has been set to C<206> or C<200>, and respond
232				accordingly:
233
234				if ($c->not_cached( { check_if_range => 1 }) {
235
236				if ($c->res->code == 206) {
237
238				# Return partial content as per the Range header.
239
240				...
241
242
243				} else {
244
245				# Return full content. Note that the status is set to 200, so
246				# it must be updated if there are other errors
247
248				...
249
250				}
251
252				}
253
254
255				=cut
256
257				sub not_cached {
258				my ($self, $opts) = @ARG;
259
260				my $config = Catalyst::Utils::merge_hashes(
261				$self->config->{$CONFIG_NAMESPACE} // { },
262				$opts // { });
263
264				my $req_h = $self->req->headers;
265				my $res_h = $self->res->headers;
266
267				my $method = $self->req->method;
268
269				my $current_time = time;
270
271				unless ($config->{no_last_modified} \|\| (defined $res_h->last_modified)) {
272				$res_h->last_modified($current_time);
273				}
274
275				my $last_modified = $res_h->last_modified;
276
277				my $generator = $config->{etag_generator} // sub {
278				my ($c, $config) = @ARG;
279				return sprintf( $config->{strong} ? "%x" : "W/%x" , $last_modified);
280				};
281
282				unless ($res_h->etag \|\| $config->{no_etag}) {
283				$res_h->etag( &{$generator}($self, $config) );
284				}
285
286				my $etag = $res_h->etag;
287				my $is_weak = (substr($etag, 0, 2) eq 'W/');
288
289				# We check to see if the status is set, and if so, ignore headers
290				# as specified in HTTP 1.1 specification.
291
292				my $status = $self->res->code;
293				my $no_ignore = (!$status) \|\| ($status =~ /^2\d\d$/);
294
295				# This code largely follows what Plugin::Cache::HTTP does
296
297				if ($no_ignore && (my @checks = $req_h->if_match)) {
298
299				my $match = $is_weak ? undef :
300				List::Util::first { ($ARG eq '"*"') \|\| ($ARG eq $etag) } @checks;
301
302				unless (defined $match) {
303
304				$self->log->debug("No Match") if ($self->debug);
305
306				$self->res->status(HTTP_PRECONDITION_FAILED);
307
308				return 0;
309
310				}
311
312				}
313
314				elsif ($no_ignore && ($ARG = $req_h->if_unmodified_since) && ($ARG < $last_modified)) {
315
316				$self->log->debug("Modified Since") if ($self->debug);
317
318				$self->res->status(HTTP_PRECONDITION_FAILED);
319
320				return 0;
321
322				}
323
324				elsif ($no_ignore && (@checks = $req_h->if_none_match)) {
325
326				my $match =
327				List::Util::first { ($ARG eq '"*"') \|\| ($ARG eq $etag) } @checks;
328
329				if (defined $match) {
330
331				$self->log->debug("Match") if ($self->debug);
332
333				# The HTTP 1.1 specification is inconsistent here. In
334				# 13.3.3 is says that weak validation may only be used for
335				# GET requests, but in 14.26 it says that weak comparison
336				# can be used for GET or HEAD requests.
337
338				if (($method eq 'GET') \|\| ($method eq 'HEAD')) {
339				$self->res->status(HTTP_NOT_MODIFIED);
340				return 0;
341				} elsif (!$is_weak) {
342				$self->res->status(HTTP_PRECONDITION_FAILED);
343				return 0;
344				}
345
346				}
347
348				}
349
350				elsif (($ARG = $req_h->if_modified_since) && ($ARG <= $last_modified)) {
351
352				$self->log->debug("Not Modified Since") if ($self->debug);
353
354				# Note: the controller is expected to check for range handlers
355				# and process them appropriately.
356
357				unless ($req_h->header('Range')) {
358
359				$self->res->status(HTTP_NOT_MODIFIED);
360
361				return 0;
362
363				}
364
365				}
366
367				elsif ((my @check = $req_h->if_range) && ($req_h->range) && $config->{check_if_range}) {
368
369				my $match =
370				List::Util::first {
371				(($ARG =~ /^\d+$/) && ($ARG >= $last_modified)) \|\| ($ARG eq '"*"') \|\| ($ARG eq $etag)
372				} @checks;
373
374				$self->res->status( (defined $match) ? HTTP_PARTIAL_CONTENT : HTTP_OK );
375
376				}
377
378				# The expiration time is only set when not_cached if true.
379
380				unless ($config->{no_expires} \|\| (defined $res_h->expires)) {
381				$res_h->expires( $current_time );
382				}
383
384				if ($method eq 'HEAD') {
385				return ($config->{no_preempt_head} \|\| 0);
386				}
387
388				return 1;
389				}
390
391				=head1 Using with Catalyst::Plugin::Cache::HTTP
392
393				This module can be used with L<Catalyst::Plugin::Cache::HTTP> in a
394				L<Catalyst> application, although it is not recommended that you use
395				it in the same method.
396
397				If you are using both plugins, then you should modify the view
398				processing method to check if an C<ETag> header has already been set:
399
400				sub process {
401				my $self = shift;
402				my $c = $_[0];
403
404				$self->next::method(@_)
405				or return 0;
406
407				my $method = $c->req->method;
408				return 1
409				if ((($method ne 'GET') and ($method ne 'HEAD'))
410				or $c->stash->{nocache}); # disable caching explicitely
411
412				unless ($c->res->headers->etag \|\| $c->stash->{no_etag}) {
413				...
414				}
415
416				}
417
418				=head1 Using with Catalyst::Controller::REST
419
420				L<Catalyst::Controller::REST> does not have status helpers for
421				"304 Not Modified" and and "412 Precondition Failed" responses.
422
423				To work around this, you need to manually set the entity using an
424				undocumented method:
425
426				$c->res->headers->last_modified( $obj->mtime );
427
428				if ($c->modified) {
429
430				# Do more processing to generate the page
431
432				} else {
433
434				$self->_set_entity($c, { error => "Not Modified" });
435
436				return 1;
437
438				}
439
440				=head1 SEE ALSO
441
442				=over 4
443
444				=item * L<Catalyst>
445
446				=item * L<Catalyst::Plugin::Cache::HTTP>
447
448				=item * L<HTTP 1.1\|https://www.ietf.org/rfc/rfc2616.txt>
449
450				=back
451
452				=head1 AUTHOR
453
454				Interactive Information, Ltd C<< <cpan at interactive.co.uk> >>
455
456				=head1 SUPPORT
457
458				You can find documentation for this module with the perldoc command.
459
460				perldoc Catalyst::Plugin::Cache::HTTP::Preempt
461
462				You can also find information at:
463
464				=over 4
465
466				=item * RT: CPAN's request tracker (report bugs here)
467
468				L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Catalyst-Plugin-Cache-HTTP-Preempt>
469
470				=item * AnnoCPAN: Annotated CPAN documentation
471
472				L<http://annocpan.org/dist/Catalyst-Plugin-Cache-HTTP-Preempt>
473
474				=item * CPAN Ratings
475
476				L<http://cpanratings.perl.org/d/Catalyst-Plugin-Cache-HTTP-Preempt>
477
478				=item * Search CPAN
479
480				L<http://search.cpan.org/dist/Catalyst-Plugin-Cache-HTTP-Preempt/>
481
482				=back
483
484
485				=head1 LICENSE AND COPYRIGHT
486
487				Copyright (c) 2012-2013 Interactive Information, Ltd
488
489				This program is free software; you can redistribute it and/or modify it
490				under the terms of the the Artistic License (2.0). You may obtain a
491				copy of the full license at:
492
493				L<http://www.perlfoundation.org/artistic_license_2_0>
494
495				Any use, modification, and distribution of the Standard or Modified
496				Versions is governed by this Artistic License. By using, modifying or
497				distributing the Package, you accept this license. Do not use, modify,
498				or distribute the Package, if you do not accept this license.
499
500				If your Modified Version has been derived from a Modified Version made
501				by someone other than you, you are nevertheless required to ensure that
502				your Modified Version complies with the requirements of this license.
503
504				This license does not grant you the right to use any trademark, service
505				mark, tradename, or logo of the Copyright Holder.
506
507				This license includes the non-exclusive, worldwide, free-of-charge
508				patent license to make, have made, use, offer to sell, sell, import and
509				otherwise transfer the Package with respect to any patent claims
510				licensable by the Copyright Holder that are necessarily infringed by the
511				Package. If you institute patent litigation (including a cross-claim or
512				counterclaim) against any party alleging that the Package constitutes
513				direct or contributory patent infringement, then this Artistic License
514				to you shall terminate on the date that such litigation is filed.
515
516				Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER
517				AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES.
518				THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
519				PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY
520				YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR
521				CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR
522				CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE,
523				EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
524
525
526				=cut
527
528				1; # End of Catalyst::Plugin::Cache::HTTP::Preempt