/[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

Diff of /googlecode.com/svn/trunk/Meteor/Document.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 9 by andrew.betts, Fri Dec 8 16:52:58 2006 UTC revision 25 by knops.gerd, Sun May 20 19:40:53 2007 UTC
# Line 1  Line 1 
 #!/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;  
           
         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/[\/]*$//;  
           
         # split into path components  
         my @pathComponents=split(/[\/]+/,$relPath);  
           
         # Check components  
         foreach (@pathComponents)  
         {  
                 # Very strict: We only allow alphanumric 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);  
           
         # 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    #!/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            $::Statistics->{'documents_served'}++;
63            
64            $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            # 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            {
178                    &::syslog('debug',
179                            "Meteor::Document: Rejecting path '%s' due to invalid characters",
180                            $relPath
181                    );
182                    
183                    return undef;
184            }
185            #
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            
198            my $path=$::CONF{'SubscriberDocumentRoot'}.'/'.$relPath;
199            
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
Legend:
Removed from v.9  
changed lines
  Added in v.25
  ViewVC Help
Powered by ViewVC 1.1.26