Un Servidor HTTP

Reescribiremos ahora el servidor con preforking adaptativo introducido en la sección 14.2. Para configurar la conducta del servidor hay que heredar de la clase Net::Server::PreFork. La estructura del programa principal es exactamente la misma que en los ejemplos anteriores:

 1  #!/usr/bin/perl
 2  use strict;
 3  use warnings;
 4  use base qw(Net::Server::PreFork);
 5  use MIME::Types;
 6  use HTTP::Status;
 7  use HTTP::Request;
 8
 9  ### run the server
10  __PACKAGE__->run;
11  exit;

En este caso el servicio proveído es la descarga de páginas estáticas solicitadas mediante el protocolo HTTP. El método process_request es el encargado de hacerlo. Es similar a la subrutina handle_connection del servidor presentado en la sección 14.2.

 52  sub process_request {
 53    my $self = shift;
 54
 55    local $/ = "$CRLF$CRLF";
 56    my $request = <STDIN>;      # read the request header
 57  # warn "header:\n$request\n";
 58
 59    my $r = HTTP::Request->parse( $request );
 60    my $method = $r->method; # GET | HEAD | ...
 61    my $url = $r->uri;
 62
 63    warn join(" ", time, $method, "$url")."\n";
 64
 65    ### do we support the type
 66    if ($method !~ /GET|HEAD/) {
 67      return $self->error(RC_BAD_REQUEST(), "Unsupported Method");
 68    }
 69
 70    ### clean up uri
 71    my $path = URI::Escape::uri_unescape($url);
 72    $path =~ s/\?.*$//;                            # ignore query
 73    $path =~ s/\#.*$//;                            # get rid of fragment
 74
 75    ### at this point the path should be ready to use
 76    $path = "$self->{document_root}$path";
 77
 78    ### see if there's an index page
 79    if (-d $path) {
 80      foreach (@{ $self->{default_index} }){
 81        if (-e "$path/$_") {
 82          return redirect("$url/$_");
 83        }
 84      }
 85    }
 86
 87    ### error 404
 88    return $self->error(RC_NOT_FOUND(), "file not found") unless -e $path;
 89
 90    ### spit it out
 91    open(my $fh, "<$path") || return $self->error(RC_INTERNAL_SERVER_ERROR(), "Can't open file [$!]");
 92    my $length = (stat($fh))[7];        # file size
 93
 94    my $mimeobj = MIME::Types->new->mimeTypeOf($path);
 95    my $type = $mimeobj->type if defined($mimeobj);
 96
 97    # print the header
 98    print STDOUT "HTTP/1.0 ".RC_OK." OK$CRLF";
 99    print STDOUT "Content-length: $length$CRLF";
100    print STDOUT "Content-type: $type; charset=utf-8";
101    print STDOUT "$CRLF$CRLF";
102
103    return unless $method eq 'GET';
104
105    # print the content
106    my $buffer;
107    while ( read($fh,$buffer,1024) ) {
108      print STDOUT $buffer;
109    }
110    close $fh;
111  }