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 $length=shift;
        my $contenttype=shift;
        $length = 0 unless ($length);
        $contenttype = "text/html" unless ($contenttype);
        
        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";
        
        $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;
        my $ct = "text/html";
        if ($self->{'path'} =~/\.(js)$/) {
                $ct = "text/javascript";
        }
        
        $self->emitHeaderToClient($client,'200 OK',$self->{'size'}, $ct);
        
        $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	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