Un Servidor HTTP Simple:Códigos

Código Completo del Módulo

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;

Un Servidor Secuencial

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.

Ejercicio 14.2.1  



Subsecciones
Casiano Rodríguez León
Licencia de Creative Commons
Programación Distribuida y Mejora del Rendimiento
por Casiano Rodríguez León is licensed under a Creative Commons Reconocimiento 3.0 Unported License.

Permissions beyond the scope of this license may be available at http://campusvirtual.ull.es/ocw/course/view.php?id=44.
2012-06-19