Sig: Varios Protocolos Sup: El Módulo Net::Server Ant: Parametrización del Servidor
pp2@nereida:~/src/perl/NET_SERVER$ cat -n httpd
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;
12
13 ###----------------------------------------------------------------###
14
15 #my $LOG;
16
17 ### set up some server parameters
18 sub configure_hook {
19 my $self = shift;
20
21 my $root = $self->{server_root} = "/home/pp2/public_html";
22
23 $self->{server}->{port} = '*:8080'; # port and addr to bind
24 # $self->{server}->{user} = 'nobody'; # user to run as
25 # $self->{server}->{group} = 'nobody'; # group to run as
26 # $self->{server}->{setsid} = 1; # daemonize
27 # $self->{server}->{pid_file} = "$root/server.pid"; # pid file
28 # $self->{server}->{log_file} = "$root/server.log";
29
30
31 $self->{document_root} = "$root/";
32 # $self->{access_log} = "$root/access.log";
33 # $self->{error_log} = "$root/error.log";
34
35 $self->{default_index} = [ qw(index.html index.htm main.htm) ];
36
37 }
38
39 sub post_configure_hook {
40 use vars qw{$CRLF};
41 $CRLF = "\015\012";
42
43 my $self = shift;
44
45 # open(STDERR, ">>". $self->{error_log}) || die "Couldn't open STDERR: $!";
46 # open($LOG, ">>". $self->{access_log}) || die "Couldn't open log file: $!";
47 # autoflush $LOG 1;
48 # autoflush STDERR 1;
49 }
50
51 ### process the request
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 }
112
113 sub error {
114 my ($self, $code, $message) = @_;
115 my $status_message = status_message($code);
116
117 print STDOUT "HTTP/1.0 $code Bad request$CRLF";
118 print STDOUT "Content-type: text/html$CRLF$CRLF";
119 print STDOUT <<"END";
120 <HTML>
121 <HEAD><TITLE>$code Bad Request</TITLE></HEAD>
122 <BODY><H1>$status_message</H1>
123 <P>$message</P>
124 </BODY>
125 </HTML>
126 END
127 }
128
129 sub redirect {
130 my ($url) = @_;
131
132 my $moved_to = "$url";
133 print STDOUT "HTTP/1.0 301 Moved permanently$CRLF";
134 print STDOUT "Location: $moved_to$CRLF";
135 print STDOUT "Content-type: text/html$CRLF$CRLF";
136 print STDOUT <<"END";
137 <HTML>
138 <HEAD><TITLE>301 Moved</TITLE></HEAD>
139 <BODY><H1>Moved</H1>
140 <P>The requested document has moved
141 <A HREF="$moved_to">here</A>.</P>
142 </BODY>
143 </HTML>
144 END
145 }
146
147 1;
Casiano Rodríguez León