Sig: Servidor con Preforking Adaptativo: Sup: Preforking Ant: Rutinas de Soporte para
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.
