/[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 32 - (show annotations)
Thu Dec 20 21:24:24 2007 UTC (12 years, 6 months ago) by andrew.betts
File size: 6040 byte(s)
Complete rewrite of the JS web client
Opera and Safari compatibility
Saner request format

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
57 return undef;
58 }
59
60 $doc->serveTo($client);
61
62 $::Statistics->{'documents_served'}++;
63
64 $doc;
65 }
66
67 sub emitHeaderToClient {
68 my $self=shift;
69 my $client=shift;
70 my $status=shift;
71 my $length=shift;
72 my $contenttype=shift;
73 $length = 0 unless ($length);
74 $contenttype = "text/html" unless ($contenttype);
75
76 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";
77
78 $client->write($header);
79 }
80
81 sub documentForPath {
82 my $class=shift;
83 my $relPath=shift;
84
85 unless(exists($Documents{$relPath}))
86 {
87 my $path=$class->pathToAbsolute($relPath);
88
89 return undef unless(defined($path));
90
91 my $doc=$class->newDocument($path);
92
93 return undef unless(defined($doc));
94
95 $Documents{$relPath}=$doc;
96 }
97
98 $Documents{$relPath};
99 }
100
101 sub clearDocuments {
102 %Documents=();
103 }
104
105 sub pathToAbsolute {
106 my $class=shift;
107 my $relPath=shift;
108
109 # Don't serve documents unless SubscriberDocumentRoot is set
110 unless(exists($::CONF{'SubscriberDocumentRoot'})
111 && $::CONF{'SubscriberDocumentRoot'} ne ''
112 && $::CONF{'SubscriberDocumentRoot'} ne '/'
113 )
114 {
115 return undef;
116 }
117
118 #
119 # Verify if name is legal
120 #
121 # Strip leading and trailing slashes
122 $relPath=~s/^[\/]*//;
123 $relPath=~s/[\/]*$//;
124
125
126 # NOTE: With the right strings the code below triggers a bug in
127 # perl (5.8.6 currently) that will result in messages like
128 #
129 # Attempt to free unreferenced scalar
130 #
131 # and an eventual crash.
132 #
133 # So it was replaced with the more naive code following this
134 # commented out code.
135 #
136 # # split into path components
137 # my @pathComponents=split(/[\/]+/,$relPath);
138 #
139 # # Check components
140 # foreach (@pathComponents)
141 # {
142 # # Very strict: We only allow alphanumeric characters, dash and
143 # # underscore, followed by any number of extensions that also
144 # # only allow the above characters.
145 # unless(/^[a-z0-9\-\_][a-z0-9\-\_\.]*$/i)
146 # {
147 # &::syslog('debug',
148 # "Meteor::Document: Rejecting path '%s' due to invalid component '%s'",
149 # $relPath,$_
150 # );
151 #
152 # return undef;
153 # }
154 # }
155 #
156 #my $path=$::CONF{'SubscriberDocumentRoot'}.'/'.join('/',@pathComponents);
157
158 #
159 # Check for all alphanumeric or dash, underscore, dot and slash
160 #
161 unless($relPath=~/^[a-z0-9\-\_\.\/]*$/i)
162 {
163 &::syslog('debug',
164 "Meteor::Document: Rejecting path '%s' due to invalid characters",
165 $relPath
166 );
167
168 return undef;
169 }
170 #
171 # Don't allow '..'
172 #
173 if(index($relPath,'..')>=0)
174 {
175 &::syslog('debug',
176 "Meteor::Document: Rejecting path '%s' due to invalid sequence '..'",
177 $relPath
178 );
179
180 return undef;
181 }
182
183 my $path=$::CONF{'SubscriberDocumentRoot'}.'/'.$relPath;
184
185 # If it is a directory, append DirectoryIndex config value
186 $path.='/'.$::CONF{'DirectoryIndex'} if(-d $path);
187
188 # Verify file is readable
189 return undef unless(-r $path);
190
191 $path;
192 }
193
194 ###############################################################################
195 # Factory methods
196 ###############################################################################
197 sub new {
198 #
199 # Create a new empty instance
200 #
201 my $class=shift;
202
203 my $obj={};
204
205 bless($obj,$class);
206 }
207
208 sub newDocument {
209 #
210 # new instance from new server connection
211 #
212 my $self=shift->new();
213
214 my $path=shift;
215 $self->{'path'}=$path;
216
217 # Read file
218 {
219 local $/; # enable localized slurp mode
220 open(IN,$path) or return undef;
221 $self->{'document'}=<IN>;
222 close(IN);
223 }
224
225 $self->{'size'}=length($self->{'document'});
226
227 $self;
228 }
229
230 ###############################################################################
231 # Instance methods
232 ###############################################################################
233 sub serveTo {
234 my $self=shift;
235 my $client=shift;
236 my $ct = "text/html";
237 if ($self->{'path'} =~/\.(js)$/) {
238 $ct = "text/javascript";
239 }
240
241 $self->emitHeaderToClient($client,'200 OK',$self->{'size'}, $ct);
242
243 $client->write($self->{'document'});
244
245 }
246
247 sub path {
248 shift->{'path'};
249 }
250
251 1;
252 ############################################################################EOF

  ViewVC Help
Powered by ViewVC 1.1.26