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);
        
        $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
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