/[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

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

Parent Directory Parent Directory | Revision Log Revision Log


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

1 andrew.betts 10 #!/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 knops.gerd 25
49 andrew.betts 10 &::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 knops.gerd 38 $::Statistics->{'documents_not_found'}++;
57 andrew.betts 10
58     return undef;
59     }
60    
61     $doc->serveTo($client);
62    
63 knops.gerd 25 $::Statistics->{'documents_served'}++;
64    
65 andrew.betts 10 $doc;
66     }
67    
68     sub emitHeaderToClient {
69     my $self=shift;
70     my $client=shift;
71     my $status=shift;
72 andrew.betts 32 my $length=shift;
73     my $contenttype=shift;
74     $length = 0 unless ($length);
75     $contenttype = "text/html" unless ($contenttype);
76 andrew.betts 10
77 andrew.betts 32 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 andrew.betts 10
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 knops.gerd 12 # 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 andrew.betts 10 {
164 knops.gerd 12 &::syslog('debug',
165     "Meteor::Document: Rejecting path '%s' due to invalid characters",
166     $relPath
167     );
168    
169     return undef;
170 andrew.betts 10 }
171 knops.gerd 12 #
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 andrew.betts 10
184 knops.gerd 12 my $path=$::CONF{'SubscriberDocumentRoot'}.'/'.$relPath;
185 andrew.betts 10
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 andrew.betts 32 my $ct = "text/html";
238     if ($self->{'path'} =~/\.(js)$/) {
239     $ct = "text/javascript";
240     }
241 andrew.betts 10
242 andrew.betts 32 $self->emitHeaderToClient($client,'200 OK',$self->{'size'}, $ct);
243 andrew.betts 10
244     $client->write($self->{'document'});
245 andrew.betts 32
246 andrew.betts 10 }
247    
248     sub path {
249     shift->{'path'};
250     }
251    
252     1;
253     ############################################################################EOF

  ViewVC Help
Powered by ViewVC 1.1.26