lhp@nereida:~/projects/perl/src/perl_networking/ch15$ cat -n HTTPServer2.pm 1 package HTTPServer2; 2 use strict; 3 use IO::File; 4 use MIME::Types; 5 use HTTP::Status; 6 use HTTP::Request; 7 require Exporter; 8 9 our @ISA = 'Exporter'; 10 our @EXPORT = qw(handle_connection docroot); 11 12 my $DOCUMENT_ROOT = '/var/www/'; 13 my $CRLF = "\015\012"; 14 15 sub handle_connection { 16 my $c = shift; # socket 17 my ($fh,$type,$length,$url,$method); 18 local $/ = "$CRLF$CRLF"; # set end-of-line character 19 my $request = <$c>; # read the request header 20 21 my $r = HTTP::Request->parse( $request ); 22 $method = $r->method; # GET | HEAD | ... 23 return error($c, RC_BAD_REQUEST(), 'Your browser sent a request that this server does not support.') 24 unless $method =~ m!^(GET|HEAD)$!; 25 26 $url = $r->uri; 27 28 return error($c, RC_NOT_FOUND, 'The requested document was not found on this server') 29 unless ($fh,$type,$length) = lookup_file($url); 30 31 warn "URL: $url\n"; 32 return redirect($c,"$url/") if $type eq 'directory'; 33 34 # print the header 35 print $c "HTTP/1.0 ".RC_OK." OK$CRLF"; 36 print $c "Content-length: $length$CRLF"; 37 print $c "Content-type: $type; charset=utf-8$CRLF"; 38 39 print $c $CRLF; 40 41 return unless $method eq 'GET'; 42 43 # print the content 44 my $buffer; 45 while ( read($fh,$buffer,1024) ) { 46 print $c $buffer; 47 } 48 close $fh; 49 } 50 51 sub lookup_file { 52 my $url = shift; 53 my $path; 54 if ($url =~ m{\~(\w+)/(.*)}) { 55 $path = "/home/$1/public_html/$2" # user pages 56 } 57 else { 58 $path = $DOCUMENT_ROOT . $url; # turn into a path 59 } 60 $path =~ s/\?.*$//; # ignore query 61 $path =~ s/\#.*$//; # get rid of fragment 62 $path .= 'index.html' if $path=~m!/$!; # get index.html if path ends in / 63 warn "path = $path\n"; 64 65 return if $path =~ m!/\.\./!; # don't allow relative paths (..) 66 return (undef,'directory',undef) if -d $path; # oops! a directory 67 68 my $type = 'text/plain'; # default MIME type 69 70 my $mimeobj = MIME::Types->new->mimeTypeOf($path); 71 $type = $mimeobj->type if defined($mimeobj); 72 73 warn "Type = $type\n"; 74 75 return unless my $length = (stat(_))[7]; # file size 76 return unless my $fh = IO::File->new($path,"<"); # try to open file 77 return ($fh,$type,$length); 78 } 79 80 sub redirect { 81 my ($c,$url) = @_; 82 my $host = $c->sockhost; 83 my $port = $c->sockport; 84 my $moved_to = "http://$host:$port$url"; 85 my $moved_code = RC_MOVED_PERMANTLY(); 86 print $c "HTTP/1.0 $moved_code Moved permanently$CRLF"; 87 print $c "Location: $moved_to$CRLF"; 88 print $c "Content-type: text/html$CRLF$CRLF"; 89 print $c <<"END"; 90 <HTML> 91 <HEAD><TITLE>$moved_code Moved</TITLE></HEAD> 92 <BODY><H1>Moved</H1> 93 <P>The requested document has moved 94 <A HREF="$moved_to">here</A>.</P> 95 </BODY> 96 </HTML> 97 END 98 } 99 100 sub error { 101 my ($c, $code, $message) = @_; 102 my $status_message = status_message($code); 103 104 print $c "HTTP/1.0 $code Bad request$CRLF"; 105 print $c "Content-type: text/html$CRLF$CRLF"; 106 print $c <<"END"; 107 <HTML> 108 <HEAD><TITLE>$code Bad Request</TITLE></HEAD> 109 <BODY><H1>$status_message</H1> 110 <P>$message</P> 111 </BODY> 112 </HTML> 113 END 114 } 115 116 sub docroot { 117 $DOCUMENT_ROOT = shift if @_; 118 return $DOCUMENT_ROOT; 119 } 120 121 1;
El siguiente servidor maneja las solicitudes secuencialmente.
lhp@nereida:~/projects/perl/src/perl_networking/ch15$ cat -n web_serial_server2.pl 1 #!/usr/bin/perl -w 2 use strict; 3 use IO::Socket; 4 use HTTPServer2; 5 6 my $port = shift || 8080; 7 my $socket = IO::Socket::INET->new( LocalPort => $port, 8 Listen => SOMAXCONN, 9 Reuse => 1 ) or die "Can't create listen socket: $!"; 10 while (my $c = $socket->accept) { 11 handle_connection($c); 12 close $c; 13 } 14 close $socket;La constante SOMAXCONN determina la máxima longitud de la cola de conexiones pendientes.
$ perl -MSocket -wde 0 main::(-e:1): 0 DB<1> p SOMAXCONN() 128
Al poner Reuse = 1
evitamos los mensajes del tipo address in use
.
http://foo/bar#frag
), etc.
Introduzca mensajes de aviso para observar la actividad del servidor.