package Web; #++ # file: Web.pm # # Modified version of figure 15.1 (Core Web Server Routines) pp.449-454 # from Network Programming With Perl # by Lincoln D. Stein (c)2001 Addison-Wesley # # utility routines for a minimal web server. # handle_connection() and docroot() are only exported functions #-- use strict; use IO::File; use vars '@ISA','@EXPORT'; require Exporter; @ISA = 'Exporter'; @EXPORT = qw(handle_connection docroot); my $DOCUMENT_ROOT = '/var/http'; my $CRLF = "\015\012"; sub handle_connection { my $c = shift; # socket my ($fh,$type,$length,$url,$method); local $/ = "$CRLF$CRLF"; # set end-of-line character my $request = <$c>; # read the request header print STDERR "request is\n", formatted_request($request), "\n"; return invalid_request($c) unless ($method,$url) = $request =~ m!^(GET|HEAD) (/.*) HTTP/1\.[01]!; return not_found($c) unless ($fh,$type,$length) = lookup_file($url); return homepage($c) if $type eq 'tilde'; return redirect($c,"$url/") if $type eq 'directory'; # print the header print $c "HTTP/1.0 200 OK" . $CRLF; print $c "Content-length: $length" . $CRLF; print $c "Content-type: $type" . $CRLF; print $c $CRLF; return unless $method eq 'GET'; # print the content my $buffer; while ( read($fh,$buffer,1024) ) { print $c $buffer; } close $fh; } sub lookup_file { my $url = shift; my $path = $DOCUMENT_ROOT . $url; # turn into a path $path =~ s/\?.*$//; # get rid of query $path =~ s/\#.*$//; # get rid of fragment $path .= 'index.html' if $url=~m|/$|; # get index.html if path ends in / return if $path =~ m|/\.\./|; # don't allow relative paths (..) return (undef,'tilde',undef) if $path =~ m|/~|; # don't allow ~foo return (undef,'directory',undef) if -d $path; # oops! a directory my $type = 'text/plain'; # default MIME type $type = 'text/html' if $path =~ /\.html?$/i; # HTML file? $type = 'image/gif' if $path =~ /\.gif$/i; # GIF? $type = 'image/jpeg' if $path =~ /\.jpe?g$/i; # JPEG? return unless my $length = (stat(_))[7]; # file size return unless my $fh = IO::File->new($path,"<");# try to open file return ($fh,$type,$length); } sub redirect { my ($c,$url) = @_; my $host = $c->sockhost; my $port = $c->sockport; my $moved_to = "http://$host:$port$url"; print $c "HTTP/1.0 301 Moved permanently$CRLF"; print $c "Location: $moved_to$CRLF"; print $c "Content-type: text/html$CRLF$CRLF"; print $c < 301 Moved

Moved

The requested document has moved to here.

END } sub invalid_request { my $c = shift; print $c "HTTP/1.0 400 Bad request$CRLF"; print $c "Content-type: text/html$CRLF$CRLF"; print $c < 400 Bad Request

Bad Request

Your browser sent a request that this server does not support.

END } sub homepage { my $c = shift; print $c "HTTP/1.0 400 Bad request$CRLF"; print $c "Content-type: text/html$CRLF$CRLF"; print $c < 400 Bad Request

Bad Request

Your browser sent a request that this server does not support.

This server does not understand the ~foo syntax.

END } sub not_found { my $c = shift; print $c "HTTP/1.0 404 Document not found$CRLF"; print $c "Content-type: text/html$CRLF$CRLF"; print $c < 404 Not Found

Not Found

The requested document was not found on this server.

END ; print $c "

(Note: the document root for this server is $DOCUMENT_ROOT on host $ENV{HOSTNAME})

"; print $c < END } sub docroot { $DOCUMENT_ROOT = shift if @_; return $DOCUMENT_ROOT; } sub formatted_request { my $request = $_[0]; my @list = split "$CRLF", $request; my @formatted = (); my $i; for ($i=0; $i<$#list; $i++) { push @formatted, " $i" . ":" . $list[$i] . "\n"; } return @formatted; } 1;