/[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 8 by andrew.betts, Mon Nov 20 17:59:30 2006 UTC revision 9 by andrew.betts, Fri Dec 8 16:52:58 2006 UTC
# Line 1  Line 1 
1  #!/usr/bin/perl -w  #!/usr/bin/perl -w
2  ###############################################################################  ###############################################################################
3  #   Meteor  #   Meteor
4  #   An HTTP server for the 2.0 web  #   An HTTP server for the 2.0 web
5  #   Copyright (c) 2006 contributing authors  #   Copyright (c) 2006 contributing authors
6  #  #
7  #   Subscriber.pm  #   Subscriber.pm
8  #  #
9  #       Description:  #       Description:
10  #       Cache and serve static documents  #       Cache and serve static documents
11  #  #
12  ###############################################################################  ###############################################################################
13  #  #
14  #   This program is free software; you can redistribute it and/or modify it  #   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  #   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)  #   Software Foundation; either version 2 of the License, or (at your option)
17  #   any later version.  #   any later version.
18  #  #
19  #   This program is distributed in the hope that it will be useful, but WITHOUT  #   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  #   ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
21  #   FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for  #   FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
22  #   more details.  #   more details.
23  #  #
24  #   You should have received a copy of the GNU General Public License along  #   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.,  #   with this program; if not, write to the Free Software Foundation, Inc.,
26  #   59 Temple Place, Suite 330, Boston, MA 02111-1307 USA  #   59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
27  #  #
28  #   For more information visit www.meteorserver.org  #   For more information visit www.meteorserver.org
29  #  #
30  ###############################################################################  ###############################################################################
31    
32  package Meteor::Document;  package Meteor::Document;
33  ###############################################################################  ###############################################################################
34  # Configuration  # Configuration
35  ###############################################################################  ###############################################################################
36                    
37          use strict;          use strict;
38                    
39          our %Documents=();          our %Documents=();
40    
41  ###############################################################################  ###############################################################################
42  # Class methods  # Class methods
43  ###############################################################################  ###############################################################################
44  sub serveFileToClient {  sub serveFileToClient {
45          my $class=shift;          my $class=shift;
46          my $relPath=shift;          my $relPath=shift;
47          my $client=shift;          my $client=shift;
48                    
49          my $doc=$class->documentForPath($relPath);          my $doc=$class->documentForPath($relPath);
50                    
51          unless(defined($doc))          unless(defined($doc))
52          {          {
53                  $class->emitHeaderToClient($client,'404 Not Found');                  $class->emitHeaderToClient($client,'404 Not Found');
54                                    
55                  return undef;                  return undef;
56          }          }
57                    
58          $doc->serveTo($client);          $doc->serveTo($client);
59                    
60          $doc;          $doc;
61  }  }
62    
63  sub emitHeaderToClient {  sub emitHeaderToClient {
64          my $self=shift;          my $self=shift;
65          my $client=shift;          my $client=shift;
66          my $status=shift;          my $status=shift;
67                    
68          my $header=$::CONF{'DocumentHeaderTemplate'};          my $header=$::CONF{'DocumentHeaderTemplate'};
69                    
70          $header=~s/~([^~]+)~/          $header=~s/~([^~]+)~/
71                  if(!defined($1) || $1 eq '')                  if(!defined($1) || $1 eq '')
72                  {                  {
73                          '~';                          '~';
74                  }                  }
75                  elsif($1 eq 'server')                  elsif($1 eq 'server')
76                  {                  {
77                          $::PGM;                          $::PGM;
78                  }                  }
79                  elsif($1 eq 'status')                  elsif($1 eq 'status')
80                  {                  {
81                          $status;                          $status;
82                  }                  }
83                  else                  else
84                  {                  {
85                          '';                          '';
86                  }                  }
87          /gex;          /gex;
88                    
89          $client->write($header);          $client->write($header);
90  }  }
91    
92  sub documentForPath {  sub documentForPath {
93          my $class=shift;          my $class=shift;
94          my $relPath=shift;          my $relPath=shift;
95                    
96          unless(exists($Documents{$relPath}))          unless(exists($Documents{$relPath}))
97          {          {
98                  my $path=$class->pathToAbsolute($relPath);                  my $path=$class->pathToAbsolute($relPath);
99                                    
100                  return undef unless(defined($path));                  return undef unless(defined($path));
101                                    
102                  my $doc=$class->newDocument($path);                  my $doc=$class->newDocument($path);
103                                    
104                  return undef unless(defined($doc));                  return undef unless(defined($doc));
105                                    
106                  $Documents{$relPath}=$doc;                  $Documents{$relPath}=$doc;
107          }          }
108                    
109          $Documents{$relPath};          $Documents{$relPath};
110  }  }
111    
112  sub clearDocuments {  sub clearDocuments {
113          %Documents=();          %Documents=();
114  }  }
115    
116  sub pathToAbsolute {  sub pathToAbsolute {
117          my $class=shift;          my $class=shift;
118          my $relPath=shift;          my $relPath=shift;
119                    
120          # Don't serve documents unless SubscriberDocumentRoot is set          # Don't serve documents unless SubscriberDocumentRoot is set
121          unless(exists($::CONF{'SubscriberDocumentRoot'})          unless(exists($::CONF{'SubscriberDocumentRoot'})
122                  && $::CONF{'SubscriberDocumentRoot'} ne ''                  && $::CONF{'SubscriberDocumentRoot'} ne ''
123                  && $::CONF{'SubscriberDocumentRoot'} ne '/'                  && $::CONF{'SubscriberDocumentRoot'} ne '/'
124          )          )
125          {          {
126                  return undef;                  return undef;
127          }          }
128                    
129          #          #
130          # Verify if name is legal          # Verify if name is legal
131          #          #
132          # Strip leading and trailing slashes          # Strip leading and trailing slashes
133          $relPath=~s/^[\/]*//;          $relPath=~s/^[\/]*//;
134          $relPath=~s/[\/]*$//;          $relPath=~s/[\/]*$//;
135                    
136          # split into path components          # split into path components
137          my @pathComponents=split(/[\/]+/,$relPath);          my @pathComponents=split(/[\/]+/,$relPath);
138                    
139          # Check components          # Check components
140          foreach (@pathComponents)          foreach (@pathComponents)
141          {          {
142                  # Very strict: We only allow alphanumric characters, dash and                  # Very strict: We only allow alphanumric characters, dash and
143                  # underscore, followed by any number of extensions that also                  # underscore, followed by any number of extensions that also
144                  # only allow the above characters.                  # only allow the above characters.
145                  unless(/^[a-z0-9\-\_][a-z0-9\-\_\.]*$/i)                  unless(/^[a-z0-9\-\_][a-z0-9\-\_\.]*$/i)
146                  {                  {
147                          &::syslog('debug',                          &::syslog('debug',
148                                  "Meteor::Document: Rejecting path '%s' due to invalid component '%s'",                                  "Meteor::Document: Rejecting path '%s' due to invalid component '%s'",
149                                  $relPath,$_                                  $relPath,$_
150                          );                          );
151                                                    
152                          return undef;                          return undef;
153                  }                  }
154          }          }
155                    
156          my $path=$::CONF{'SubscriberDocumentRoot'}.'/'.join('/',@pathComponents);          my $path=$::CONF{'SubscriberDocumentRoot'}.'/'.join('/',@pathComponents);
157                    
158          # If it is a directory, append DirectoryIndex config value          # If it is a directory, append DirectoryIndex config value
159          $path.='/'.$::CONF{'DirectoryIndex'} if(-d $path);          $path.='/'.$::CONF{'DirectoryIndex'} if(-d $path);
160                    
161          # Verify file is readable          # Verify file is readable
162          return undef unless(-r $path);          return undef unless(-r $path);
163                    
164          $path;          $path;
165  }  }
166    
167  ###############################################################################  ###############################################################################
168  # Factory methods  # Factory methods
169  ###############################################################################  ###############################################################################
170  sub new {  sub new {
171          #          #
172          # Create a new empty instance          # Create a new empty instance
173          #          #
174          my $class=shift;          my $class=shift;
175                    
176          my $obj={};          my $obj={};
177                    
178          bless($obj,$class);          bless($obj,$class);
179  }  }
180                    
181  sub newDocument {  sub newDocument {
182          #          #
183          # new instance from new server connection          # new instance from new server connection
184          #          #
185          my $self=shift->new();          my $self=shift->new();
186                    
187          my $path=shift;          my $path=shift;
188          $self->{'path'}=$path;          $self->{'path'}=$path;
189                    
190          # Read file          # Read file
191          {          {
192              local $/; # enable localized slurp mode              local $/; # enable localized slurp mode
193                  open(IN,$path) or return undef;                  open(IN,$path) or return undef;
194                  $self->{'document'}=<IN>;                  $self->{'document'}=<IN>;
195                  close(IN);                  close(IN);
196          }          }
197                    
198          $self->{'size'}=length($self->{'document'});          $self->{'size'}=length($self->{'document'});
199                    
200          $self;          $self;
201  }  }
202    
203  ###############################################################################  ###############################################################################
204  # Instance methods  # Instance methods
205  ###############################################################################  ###############################################################################
206  sub serveTo {  sub serveTo {
207          my $self=shift;          my $self=shift;
208          my $client=shift;          my $client=shift;
209                    
210          $self->emitHeaderToClient($client,'200 OK');          $self->emitHeaderToClient($client,'200 OK');
211                    
212          $client->write($self->{'document'});          $client->write($self->{'document'});
213  }  }
214    
215  sub path {  sub path {
216          shift->{'path'};          shift->{'path'};
217  }  }
218    
219  1;  1;
220  ############################################################################EOF  ############################################################################EOF
Legend:
Removed from v.8  
changed lines
  Added in v.9
  ViewVC Help
Powered by ViewVC 1.1.26