/[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 10 by andrew.betts, Thu Dec 14 10:45:43 2006 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            $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            # split into path components
139            my @pathComponents=split(/[\/]+/,$relPath);
140            
141            # Check components
142            foreach (@pathComponents)
143            {
144                    # Very strict: We only allow alphanumric characters, dash and
145                    # underscore, followed by any number of extensions that also
146                    # only allow the above characters.
147                    unless(/^[a-z0-9\-\_][a-z0-9\-\_\.]*$/i)
148                    {
149                            &::syslog('debug',
150                                    "Meteor::Document: Rejecting path '%s' due to invalid component '%s'",
151                                    $relPath,$_
152                            );
153                            
154                            return undef;
155                    }
156            }
157            
158            my $path=$::CONF{'SubscriberDocumentRoot'}.'/'.join('/',@pathComponents);
159            
160            # If it is a directory, append DirectoryIndex config value
161            $path.='/'.$::CONF{'DirectoryIndex'} if(-d $path);
162            
163            # Verify file is readable
164            return undef unless(-r $path);
165            
166            $path;
167    }
168    
169    ###############################################################################
170    # Factory methods
171    ###############################################################################
172    sub new {
173            #
174            # Create a new empty instance
175            #
176            my $class=shift;
177            
178            my $obj={};
179            
180            bless($obj,$class);
181    }
182            
183    sub newDocument {
184            #
185            # new instance from new server connection
186            #
187            my $self=shift->new();
188            
189            my $path=shift;
190            $self->{'path'}=$path;
191            
192            # Read file
193            {
194                local $/; # enable localized slurp mode
195                    open(IN,$path) or return undef;
196                    $self->{'document'}=<IN>;
197                    close(IN);
198            }
199            
200            $self->{'size'}=length($self->{'document'});
201            
202            $self;
203    }
204    
205    ###############################################################################
206    # Instance methods
207    ###############################################################################
208    sub serveTo {
209            my $self=shift;
210            my $client=shift;
211            
212            $self->emitHeaderToClient($client,'200 OK');
213            
214            $client->write($self->{'document'});
215    }
216    
217    sub path {
218            shift->{'path'};
219    }
220    
221    1;
222    ############################################################################EOF

Legend:
Removed from v.9  
changed lines
  Added in v.10

  ViewVC Help
Powered by ViewVC 1.1.26