/[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 38 by knops.gerd, Fri Feb 1 21:54:05 2008 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                    $::Statistics->{'documents_not_found'}++;
57                    
58                    return undef;
59            }
60            
61            $doc->serveTo($client);
62            
63            $::Statistics->{'documents_served'}++;
64            
65            $doc;
66    }
67    
68    sub emitHeaderToClient {
69            my $self=shift;
70            my $client=shift;
71            my $status=shift;
72            my $length=shift;
73            my $contenttype=shift;
74            $length = 0 unless ($length);
75            $contenttype = "text/html" unless ($contenttype);
76            
77            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";
78            
79            $client->write($header);
80    }
81    
82    sub documentForPath {
83            my $class=shift;
84            my $relPath=shift;
85            
86            unless(exists($Documents{$relPath}))
87            {
88                    my $path=$class->pathToAbsolute($relPath);
89                    
90                    return undef unless(defined($path));
91                    
92                    my $doc=$class->newDocument($path);
93                    
94                    return undef unless(defined($doc));
95                    
96                    $Documents{$relPath}=$doc;
97            }
98            
99            $Documents{$relPath};
100    }
101    
102    sub clearDocuments {
103            %Documents=();
104    }
105    
106    sub pathToAbsolute {
107            my $class=shift;
108            my $relPath=shift;
109            
110            # Don't serve documents unless SubscriberDocumentRoot is set
111            unless(exists($::CONF{'SubscriberDocumentRoot'})
112                    && $::CONF{'SubscriberDocumentRoot'} ne ''
113                    && $::CONF{'SubscriberDocumentRoot'} ne '/'
114            )
115            {
116                    return undef;
117            }
118            
119            #
120            # Verify if name is legal
121            #
122            # Strip leading and trailing slashes
123            $relPath=~s/^[\/]*//;
124            $relPath=~s/[\/]*$//;
125            
126            
127            # NOTE: With the right strings the code below triggers a bug in
128            # perl (5.8.6 currently) that will result in messages like
129            #
130            #       Attempt to free unreferenced scalar
131            #
132            # and an eventual crash.
133            #
134            # So it was replaced with the more naive code following this
135            # commented out code.
136            #
137            # # split into path components
138            # my @pathComponents=split(/[\/]+/,$relPath);
139            #
140            # # Check components
141            # foreach (@pathComponents)
142            # {
143            #       # Very strict: We only allow alphanumeric characters, dash and
144            #       # underscore, followed by any number of extensions that also
145            #       # only allow the above characters.
146            #       unless(/^[a-z0-9\-\_][a-z0-9\-\_\.]*$/i)
147            #       {
148            #               &::syslog('debug',
149            #                       "Meteor::Document: Rejecting path '%s' due to invalid component '%s'",
150            #                       $relPath,$_
151            #               );
152            #              
153            #               return undef;
154            #       }
155            # }
156            #
157            #my $path=$::CONF{'SubscriberDocumentRoot'}.'/'.join('/',@pathComponents);
158            
159            #
160            # Check for all alphanumeric or dash, underscore, dot and slash
161            #
162            unless($relPath=~/^[a-z0-9\-\_\.\/]*$/i)
163            {
164                    &::syslog('debug',
165                            "Meteor::Document: Rejecting path '%s' due to invalid characters",
166                            $relPath
167                    );
168                    
169                    return undef;
170            }
171            #
172            # Don't allow '..'
173            #
174            if(index($relPath,'..')>=0)
175            {
176                    &::syslog('debug',
177                            "Meteor::Document: Rejecting path '%s' due to invalid sequence '..'",
178                            $relPath
179                    );
180                    
181                    return undef;
182            }
183            
184            my $path=$::CONF{'SubscriberDocumentRoot'}.'/'.$relPath;
185            
186            # If it is a directory, append DirectoryIndex config value
187            $path.='/'.$::CONF{'DirectoryIndex'} if(-d $path);
188            
189            # Verify file is readable
190            return undef unless(-r $path);
191            
192            $path;
193    }
194    
195    ###############################################################################
196    # Factory methods
197    ###############################################################################
198    sub new {
199            #
200            # Create a new empty instance
201            #
202            my $class=shift;
203            
204            my $obj={};
205            
206            bless($obj,$class);
207    }
208            
209    sub newDocument {
210            #
211            # new instance from new server connection
212            #
213            my $self=shift->new();
214            
215            my $path=shift;
216            $self->{'path'}=$path;
217            
218            # Read file
219            {
220                local $/; # enable localized slurp mode
221                    open(IN,$path) or return undef;
222                    $self->{'document'}=<IN>;
223                    close(IN);
224            }
225            
226            $self->{'size'}=length($self->{'document'});
227            
228            $self;
229    }
230    
231    ###############################################################################
232    # Instance methods
233    ###############################################################################
234    sub serveTo {
235            my $self=shift;
236            my $client=shift;
237            my $ct = "text/html";
238            if ($self->{'path'} =~/\.(js)$/) {
239                    $ct = "text/javascript";
240            }
241            
242            $self->emitHeaderToClient($client,'200 OK',$self->{'size'}, $ct);
243            
244            $client->write($self->{'document'});
245    
246    }
247    
248    sub path {
249            shift->{'path'};
250    }
251    
252    1;
253    ############################################################################EOF
Legend:
Removed from v.9  
changed lines
  Added in v.38
  ViewVC Help
Powered by ViewVC 1.1.26