trunk/Meteor/Document.pm

#!/usr/bin/perl -w
###############################################################################
#   Meteor
#   An HTTP server for the 2.0 web
#   Copyright (c) 2006 contributing authors
#
#   Subscriber.pm
#
#       Description:
#       Cache and serve static documents
#
###############################################################################
#
#   This program is free software; you can redistribute it and/or modify it
#   under the terms of the GNU General Public License as published by the Free
#   Software Foundation; either version 2 of the License, or (at your option)
#   any later version.
#
#   This program is distributed in the hope that it will be useful, but WITHOUT
#   ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
#   FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
#   more details.
#
#   You should have received a copy of the GNU General Public License along
#   with this program; if not, write to the Free Software Foundation, Inc.,
#   59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
#
#   For more information visit www.meteorserver.org
#
###############################################################################

package Meteor::Document;
###############################################################################
# Configuration
###############################################################################
        
        use strict;
        
        our %Documents=();

###############################################################################
# Class methods
###############################################################################
sub serveFileToClient {
        my $class=shift;
        my $relPath=shift;
        my $client=shift;
        
        &::syslog('debug',"Meteor::Document: Request received for '%s'",$relPath);
        
        my $doc=$class->documentForPath($relPath);
        
        unless(defined($doc))
        {
                $class->emitHeaderToClient($client,'404 Not Found');
                
                return undef;
        }
        
        $doc->serveTo($client);
        
        $::Statistics->{'documents_served'}++;
        
        $doc;
}

sub emitHeaderToClient {
        my $self=shift;
        my $client=shift;
        my $status=shift;
        
        my $header=$::CONF{'DocumentHeaderTemplate'};
        
        $header=~s/~([^~]+)~/
                if(!defined($1) || $1 eq '')
                {
                        '~';
                }
                elsif($1 eq 'server')
                {
                        $::PGM;
                }
                elsif($1 eq 'status')
                {
                        $status;
                }
                else
                {
                        '';
                }
        /gex;
        
        $client->write($header);
}

sub documentForPath {
        my $class=shift;
        my $relPath=shift;
        
        unless(exists($Documents{$relPath}))
        {
                my $path=$class->pathToAbsolute($relPath);
                
                return undef unless(defined($path));
                
                my $doc=$class->newDocument($path);
                
                return undef unless(defined($doc));
                
                $Documents{$relPath}=$doc;
        }
        
        $Documents{$relPath};
}

sub clearDocuments {
        %Documents=();
}

sub pathToAbsolute {
        my $class=shift;
        my $relPath=shift;
        
        # Don't serve documents unless SubscriberDocumentRoot is set 
        unless(exists($::CONF{'SubscriberDocumentRoot'})
                && $::CONF{'SubscriberDocumentRoot'} ne ''
                && $::CONF{'SubscriberDocumentRoot'} ne '/'
        )
        {
                return undef;
        }
        
        #
        # Verify if name is legal
        #
        # Strip leading and trailing slashes
        $relPath=~s/^[\/]*//;
        $relPath=~s/[\/]*$//;
        
        
        # NOTE: With the right strings the code below triggers a bug in
        # perl (5.8.6 currently) that will result in messages like
        #
        #       Attempt to free unreferenced scalar
        #
        # and an eventual crash.
        #
        # So it was replaced with the more naive code following this
        # commented out code.
        #
        # # split into path components
        # my @pathComponents=split(/[\/]+/,$relPath);
        # 
        # # Check components
        # foreach (@pathComponents)
        # {
        #       # Very strict: We only allow alphanumeric characters, dash and
        #       # underscore, followed by any number of extensions that also
        #       # only allow the above characters.
        #       unless(/^[a-z0-9\-\_][a-z0-9\-\_\.]*$/i)
        #       {
        #               &::syslog('debug',
        #                       "Meteor::Document: Rejecting path '%s' due to invalid component '%s'",
        #                       $relPath,$_
        #               );
        #               
        #               return undef;
        #       }
        # }
        #
        #my $path=$::CONF{'SubscriberDocumentRoot'}.'/'.join('/',@pathComponents);
        
        #
        # Check for all alphanumeric or dash, underscore, dot and slash
        #
        unless($relPath=~/^[a-z0-9\-\_\.\/]*$/i)
        {
                &::syslog('debug',
                        "Meteor::Document: Rejecting path '%s' due to invalid characters",
                        $relPath
                );
                
                return undef;
        }
        #
        # Don't allow '..'
        #
        if(index($relPath,'..')>=0)
        {
                &::syslog('debug',
                        "Meteor::Document: Rejecting path '%s' due to invalid sequence '..'",
                        $relPath
                );
                
                return undef;
        }
        
        my $path=$::CONF{'SubscriberDocumentRoot'}.'/'.$relPath;
        
        # If it is a directory, append DirectoryIndex config value
        $path.='/'.$::CONF{'DirectoryIndex'} if(-d $path);
        
        # Verify file is readable
        return undef unless(-r $path);
        
        $path;
}

###############################################################################
# Factory methods
###############################################################################
sub new {
        #
        # Create a new empty instance
        #
        my $class=shift;
        
        my $obj={};
        
        bless($obj,$class);
}
        
sub newDocument {
        #
        # new instance from new server connection
        #
        my $self=shift->new();
        
        my $path=shift;
        $self->{'path'}=$path;
        
        # Read file
        {
            local $/; # enable localized slurp mode
                open(IN,$path) or return undef;
                $self->{'document'}=<IN>;
                close(IN);
        }
        
        $self->{'size'}=length($self->{'document'});
        
        $self;
}

###############################################################################
# Instance methods
###############################################################################
sub serveTo {
        my $self=shift;
        my $client=shift;
        
        $self->emitHeaderToClient($client,'200 OK');
        
        $client->write($self->{'document'});
}

sub path {
        shift->{'path'};
}

1;
############################################################################EOF
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
72			my $header=$::CONF{'DocumentHeaderTemplate'};
73
74			$header=~s/~([^~]+)~/
75			if(!defined($1) \|\| $1 eq '')
76			{
77			'~';
78			}
79			elsif($1 eq 'server')
80			{
81			$::PGM;
82			}
83			elsif($1 eq 'status')
84			{
85			$status;
86			}
87			else
88			{
89			'';
90			}
91			/gex;
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	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
252			$self->emitHeaderToClient($client,'200 OK');
253
254			$client->write($self->{'document'});
255			}
256
257			sub path {
258			shift->{'path'};
259			}
260
261			1;
262			############################################################################EOF