1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
|
# ABSTRACT: Responder for static files
package Pinto::Server::Responder::File;
use Moose;
use Plack::Response;
use Plack::MIME;
use HTTP::Date ();
#-------------------------------------------------------------------------------
our $VERSION = '0.14'; # VERSION
#-------------------------------------------------------------------------------
extends qw(Pinto::Server::Responder);
#-------------------------------------------------------------------------------
sub respond {
my ($self) = @_;
# e.g. /stack_name/modules/02packages.details.txt.gz
my ( undef, @path_parts ) = split '/', $self->request->path_info;
my $file = $self->root->file(@path_parts);
return not_found($file) if not -f $file;
return not_found($file) if index($file, '/../') > 0;
my @stat = stat($file);
my $modified_since = HTTP::Date::str2time( $self->request->env->{HTTP_IF_MODIFIED_SINCE} );
return [ 304, [], [] ] if $modified_since && $stat[9] <= $modified_since;
my $response = Plack::Response->new;
$response->content_type( Plack::MIME->mime_type($file) );
$response->content_length( $stat[7] );
$response->header( 'Last-Modified' => HTTP::Date::time2str( $stat[9] ) );
$response->header( 'Cache-Control' => 'no-cache' ) if $self->should_not_cache($file);
$response->body( $file->openr ) unless $self->request->method eq "HEAD";
$response->status(200);
return $response;
}
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------
sub should_not_cache {
my ( $self, $file ) = @_;
# force caches to always revalidate the indices, i.e.
# 01mailrc.txt.gz, 02packages.details.txt.gz, 03modlist.data.gz
my $basename = $file->basename;
return 1 if $basename eq '01mailrc.txt.gz';
return 1 if $basename eq '02packages.details.txt.gz';
return 1 if $basename eq '03modlist.data.gz';
return 0;
}
#-------------------------------------------------------------------------------
sub not_found {
my $file = shift;
my $body = "File $file not found";
my $headers = [ 'Content-Type' => 'text/plain', 'Content-Length' => length($body) ];
return [ 404, $headers, [$body] ];
}
#-------------------------------------------------------------------------------
__PACKAGE__->meta->make_immutable;
#-------------------------------------------------------------------------------
1;
__END__
=pod
=encoding UTF-8
=for :stopwords Jeffrey Ryan Thalhammer
=head1 NAME
Pinto::Server::Responder::File - Responder for static files
=head1 VERSION
version 0.14
=head1 METHODS
=head2 should_not_cache($file)
Returns true if the file should not be cached, and therefore the Cache-Control
header should be set to 'no-cache' in the response. Currently, only the index
files should not be cached.
=head1 AUTHOR
Jeffrey Ryan Thalhammer <jeff@stratopan.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
|
