/[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 47 - (show annotations)
Mon Feb 4 21:06:42 2008 UTC (16 years, 1 month ago) by knops.gerd
File size: 6234 byte(s)
• syslog change: If `SyslogFacility` is set to `none`, meteord will not put itself into the background and print all syslog messages with a priority higher than `debug` to standard output. The output will be prefixed with a timestamp (unix time in seconds) and a tab character.

• New syslog messges: joinchannel, leavechannel, document


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

  ViewVC Help
Powered by ViewVC 1.1.26