/[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 32 by andrew.betts, Thu Dec 20 21:24:24 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            my $length=shift;
72            my $contenttype=shift;
73            $length = 0 unless ($length);
74            $contenttype = "text/html" unless ($contenttype);
75            
76            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            
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            # 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            {
163                    &::syslog('debug',
164                            "Meteor::Document: Rejecting path '%s' due to invalid characters",
165                            $relPath
166                    );
167                    
168                    return undef;
169            }
170            #
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            
183            my $path=$::CONF{'SubscriberDocumentRoot'}.'/'.$relPath;
184            
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            my $ct = "text/html";
237            if ($self->{'path'} =~/\.(js)$/) {
238                    $ct = "text/javascript";
239            }
240            
241            $self->emitHeaderToClient($client,'200 OK',$self->{'size'}, $ct);
242            
243            $client->write($self->{'document'});
244    
245    }
246    
247    sub path {
248            shift->{'path'};
249    }
250    
251    1;
252    ############################################################################EOF
Legend:
Removed from v.9  
changed lines
  Added in v.32
  ViewVC Help
Powered by ViewVC 1.1.26