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

  ViewVC Help
Powered by ViewVC 1.1.26