/[meteor]/googlecode.com/svn/trunk/Meteor/Document.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Contents of /googlecode.com/svn/trunk/Meteor/Document.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 38 - (show annotations)
Fri Feb 1 21:54:05 2008 UTC (16 years, 1 month ago) by knops.gerd
File size: 6084 byte(s)
• Add documents_not_found statistics value for invalid document requests

1 #!/usr/bin/perl -w
2 ###############################################################################
3 # Meteor
4 # An HTTP server for the 2.0 web
5 # Copyright (c) 2006 contributing authors
6 #
7 # Subscriber.pm
8 #
9 # Description:
10 # Cache and serve static documents
11 #
12 ###############################################################################
13 #
14 # This program is free software; you can redistribute it and/or modify it
15 # under the terms of the GNU General Public License as published by the Free
16 # Software Foundation; either version 2 of the License, or (at your option)
17 # any later version.
18 #
19 # This program is distributed in the hope that it will be useful, but WITHOUT
20 # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
21 # FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
22 # more details.
23 #
24 # You should have received a copy of the GNU General Public License along
25 # with this program; if not, write to the Free Software Foundation, Inc.,
26 # 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
27 #
28 # For more information visit www.meteorserver.org
29 #
30 ###############################################################################
31
32 package Meteor::Document;
33 ###############################################################################
34 # Configuration
35 ###############################################################################
36
37 use strict;
38
39 our %Documents=();
40
41 ###############################################################################
42 # Class methods
43 ###############################################################################
44 sub serveFileToClient {
45 my $class=shift;
46 my $relPath=shift;
47 my $client=shift;
48
49 &::syslog('debug',"Meteor::Document: Request received for '%s'",$relPath);
50
51 my $doc=$class->documentForPath($relPath);
52
53 unless(defined($doc))
54 {
55 $class->emitHeaderToClient($client,'404 Not Found');
56 $::Statistics->{'documents_not_found'}++;
57
58 return undef;
59 }
60
61 $doc->serveTo($client);
62
63 $::Statistics->{'documents_served'}++;
64
65 $doc;
66 }
67
68 sub emitHeaderToClient {
69 my $self=shift;
70 my $client=shift;
71 my $status=shift;
72 my $length=shift;
73 my $contenttype=shift;
74 $length = 0 unless ($length);
75 $contenttype = "text/html" unless ($contenttype);
76
77 my $header="HTTP/1.1 ".$status."\r\nServer: ".$::PGM."\r\nContent-Type: ".$contenttype."; charset=utf-8\r\nPragma: no-cache\r\nCache-Control: no-cache, no-store, must-revalidate\r\nExpires: Thu, 1 Jan 1970 00:00:00 GMT\r\nContent-length: ".$length."\r\n\r\n";
78
79 $client->write($header);
80 }
81
82 sub documentForPath {
83 my $class=shift;
84 my $relPath=shift;
85
86 unless(exists($Documents{$relPath}))
87 {
88 my $path=$class->pathToAbsolute($relPath);
89
90 return undef unless(defined($path));
91
92 my $doc=$class->newDocument($path);
93
94 return undef unless(defined($doc));
95
96 $Documents{$relPath}=$doc;
97 }
98
99 $Documents{$relPath};
100 }
101
102 sub clearDocuments {
103 %Documents=();
104 }
105
106 sub pathToAbsolute {
107 my $class=shift;
108 my $relPath=shift;
109
110 # Don't serve documents unless SubscriberDocumentRoot is set
111 unless(exists($::CONF{'SubscriberDocumentRoot'})
112 && $::CONF{'SubscriberDocumentRoot'} ne ''
113 && $::CONF{'SubscriberDocumentRoot'} ne '/'
114 )
115 {
116 return undef;
117 }
118
119 #
120 # Verify if name is legal
121 #
122 # Strip leading and trailing slashes
123 $relPath=~s/^[\/]*//;
124 $relPath=~s/[\/]*$//;
125
126
127 # NOTE: With the right strings the code below triggers a bug in
128 # perl (5.8.6 currently) that will result in messages like
129 #
130 # Attempt to free unreferenced scalar
131 #
132 # and an eventual crash.
133 #
134 # So it was replaced with the more naive code following this
135 # commented out code.
136 #
137 # # split into path components
138 # my @pathComponents=split(/[\/]+/,$relPath);
139 #
140 # # Check components
141 # foreach (@pathComponents)
142 # {
143 # # Very strict: We only allow alphanumeric characters, dash and
144 # # underscore, followed by any number of extensions that also
145 # # only allow the above characters.
146 # unless(/^[a-z0-9\-\_][a-z0-9\-\_\.]*$/i)
147 # {
148 # &::syslog('debug',
149 # "Meteor::Document: Rejecting path '%s' due to invalid component '%s'",
150 # $relPath,$_
151 # );
152 #
153 # return undef;
154 # }
155 # }
156 #
157 #my $path=$::CONF{'SubscriberDocumentRoot'}.'/'.join('/',@pathComponents);
158
159 #
160 # Check for all alphanumeric or dash, underscore, dot and slash
161 #
162 unless($relPath=~/^[a-z0-9\-\_\.\/]*$/i)
163 {
164 &::syslog('debug',
165 "Meteor::Document: Rejecting path '%s' due to invalid characters",
166 $relPath
167 );
168
169 return undef;
170 }
171 #
172 # Don't allow '..'
173 #
174 if(index($relPath,'..')>=0)
175 {
176 &::syslog('debug',
177 "Meteor::Document: Rejecting path '%s' due to invalid sequence '..'",
178 $relPath
179 );
180
181 return undef;
182 }
183
184 my $path=$::CONF{'SubscriberDocumentRoot'}.'/'.$relPath;
185
186 # If it is a directory, append DirectoryIndex config value
187 $path.='/'.$::CONF{'DirectoryIndex'} if(-d $path);
188
189 # Verify file is readable
190 return undef unless(-r $path);
191
192 $path;
193 }
194
195 ###############################################################################
196 # Factory methods
197 ###############################################################################
198 sub new {
199 #
200 # Create a new empty instance
201 #
202 my $class=shift;
203
204 my $obj={};
205
206 bless($obj,$class);
207 }
208
209 sub newDocument {
210 #
211 # new instance from new server connection
212 #
213 my $self=shift->new();
214
215 my $path=shift;
216 $self->{'path'}=$path;
217
218 # Read file
219 {
220 local $/; # enable localized slurp mode
221 open(IN,$path) or return undef;
222 $self->{'document'}=<IN>;
223 close(IN);
224 }
225
226 $self->{'size'}=length($self->{'document'});
227
228 $self;
229 }
230
231 ###############################################################################
232 # Instance methods
233 ###############################################################################
234 sub serveTo {
235 my $self=shift;
236 my $client=shift;
237 my $ct = "text/html";
238 if ($self->{'path'} =~/\.(js)$/) {
239 $ct = "text/javascript";
240 }
241
242 $self->emitHeaderToClient($client,'200 OK',$self->{'size'}, $ct);
243
244 $client->write($self->{'document'});
245
246 }
247
248 sub path {
249 shift->{'path'};
250 }
251
252 1;
253 ############################################################################EOF

  ViewVC Help
Powered by ViewVC 1.1.26