/[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 12 - (hide annotations)
Thu Dec 14 16:58:18 2006 UTC (13 years, 6 months ago) by knops.gerd
File size: 5735 byte(s)
• Simplify check for valid path names. The old check was triggering a bug in perl (Attempt to free unreferenced scalar) that would eventually lead to a crash. 

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

  ViewVC Help
Powered by ViewVC 1.1.26