/[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 47 - (hide annotations)
Mon Feb 4 21:06:42 2008 UTC (12 years, 5 months 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 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 knops.gerd 47 &::syslog('info','',
59     'document',
60     $relPath,
61     0,
62     404
63     );
64    
65 andrew.betts 10 return undef;
66     }
67    
68     $doc->serveTo($client);
69    
70 knops.gerd 25 $::Statistics->{'documents_served'}++;
71    
72 knops.gerd 47 &::syslog('info','',
73     'document',
74     $relPath,
75     $doc->{'size'},
76     200
77     );
78    
79 andrew.betts 10 $doc;
80     }
81    
82     sub emitHeaderToClient {
83     my $self=shift;
84     my $client=shift;
85     my $status=shift;
86 andrew.betts 32 my $length=shift;
87     my $contenttype=shift;
88     $length = 0 unless ($length);
89     $contenttype = "text/html" unless ($contenttype);
90 andrew.betts 10
91 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";
92 andrew.betts 10
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 knops.gerd 12 # 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 andrew.betts 10 {
178 knops.gerd 12 &::syslog('debug',
179     "Meteor::Document: Rejecting path '%s' due to invalid characters",
180     $relPath
181     );
182    
183     return undef;
184 andrew.betts 10 }
185 knops.gerd 12 #
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 andrew.betts 10
198 knops.gerd 12 my $path=$::CONF{'SubscriberDocumentRoot'}.'/'.$relPath;
199 andrew.betts 10
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 andrew.betts 32 my $ct = "text/html";
252     if ($self->{'path'} =~/\.(js)$/) {
253     $ct = "text/javascript";
254     }
255 andrew.betts 10
256 andrew.betts 32 $self->emitHeaderToClient($client,'200 OK',$self->{'size'}, $ct);
257 andrew.betts 10
258     $client->write($self->{'document'});
259 andrew.betts 32
260 andrew.betts 10 }
261    
262     sub path {
263     shift->{'path'};
264     }
265    
266     1;
267     ############################################################################EOF

  ViewVC Help
Powered by ViewVC 1.1.26