Coro/myhttpd/httpd.pl

use Coro;
use Coro::Semaphore;
use Coro::EV;
use Coro::Socket;
use Coro::Signal;
use Coro::AIO ();

use HTTP::Date;
use POSIX ();

use Compress::Zlib ();

no utf8;
use bytes;

# at least on my machine, this thingy serves files
# quite a bit faster than apache, ;)
# and quite a bit slower than thttpd :(

$SIG{PIPE} = 'IGNORE';

our $accesslog;
our $errorlog;

our $NOW;
our $HTTP_NOW;

our $ERROR_LOG;
our $ACCESS_LOG;

our $update_time = EV::periodic 0, 1, undef, sub {
   $NOW = time;
   $HTTP_NOW = time2str $NOW;
};
$update_time->invoke;

if ($ERROR_LOG) {
   use IO::Handle;
   open $errorlog, ">>$ERROR_LOG"
     or die "$ERROR_LOG: $!";
   $errorlog->autoflush(1);
}

if ($ACCESS_LOG) {
   use IO::Handle;
   open $accesslog, ">>$ACCESS_LOG"
     or die "$ACCESS_LOG: $!";
   $accesslog->autoflush(1);
}

sub slog {
   my $level = shift;
   my $format = shift;
   my $NOW = (POSIX::strftime "%Y-%m-%d %H:%M:%S", gmtime $::NOW);
   printf "$NOW: $format\n", @_;
   printf $errorlog "$NOW: $format\n", @_ if $errorlog;
}

our $connections = new Coro::Semaphore $MAX_CONNECTS || 250;
our $httpevent   = new Coro::Signal;

our $queue_file  = new transferqueue $MAX_TRANSFERS;
our $queue_index = new transferqueue 10;

our $tbf_top     = new tbf rate => $TBF_RATE || 100000;

my $unused_bytes = 0;
my $unused_last  = time;

sub unused_bandwidth {
   $unused_bytes += $_[0];
   if ($unused_last < $NOW - 30 && $unused_bytes / ($NOW - $unused_last) > 50000) {
      $unused_last = $NOW;
      $unused_bytes = 0;
      $queue_file->force_wake_next;
      slog 1, "forced filetransfer due to unused bandwidth";
   }
}

my @newcons;
my @pool;

# one "execution thread"
sub handler {
   while () {
      if (@newcons) {
         eval {
            conn->new (@{pop @newcons})->handle;
         };
         slog 1, "$@" if $@ && !ref $@;

         $httpevent->broadcast; # only for testing, but doesn't matter much

         $connections->up;
      } else {
         last if @pool >= $MAX_POOL;
         push @pool, $Coro::current;
         schedule;
      }
   }
}

sub listen_on {
   my $listen = $_[0];

   push @listen_sockets, $listen;

   # the "main thread"
   async {
      slog 1, "accepting connections";
      while () {
         $connections->down;
         push @newcons, [$listen->accept];
         #slog 3, "accepted @$connections ".scalar(@pool);
         if (@pool) {
            (pop @pool)->ready;
         } else {
            async \&handler;
         }
      }
   };
}

my $http_port = new Coro::Socket
        LocalAddr => $SERVER_HOST,
        LocalPort => $SERVER_PORT,
        ReuseAddr => 1,
        Listen    => 50,
   or die "unable to start server";

listen_on $http_port;

if ($SERVER_PORT2) {
   my $http_port = new Coro::Socket
           LocalAddr => $SERVER_HOST,
           LocalPort => $SERVER_PORT2,
           ReuseAddr => 1,
           Listen    => 50,
      or die "unable to start server";

   listen_on $http_port;
}

package conn;

use strict;
use bytes;

use Socket;
use HTTP::Date;
use Convert::Scalar 'weaken';
use IO::AIO;

IO::AIO::min_parallel $::AIO_PARALLEL;

our $AIO_WATCHER = EV::io IO::AIO::poll_fileno, EV::READ, \&IO::AIO::poll_cb;

our %conn; # $conn{ip}{self} => connobj
our %uri;  # $uri{ip}{uri}{self}
our %blocked;
our %mimetype;

sub read_mimetypes {
   if (open my $fh, "<mime_types") {
      while (<$fh>) {
         if (/^([^#]\S+)\t+(\S+)$/) {
            $mimetype{lc $1} = $2;
         }
      }
   } else {
      print "cannot open mime_types\n";
   }
}

read_mimetypes;

sub new {
   my $class = shift;
   my $fh = shift;
   my $peername = shift;
   my $self = bless { fh => $fh }, $class;
   my (undef, $iaddr) = unpack_sockaddr_in $peername
      or $self->err (500, "unable to decode peername");

   $self->{remote_addr} =
      $self->{remote_id} = inet_ntoa $iaddr;

   $self->{time} = $::NOW;

   weaken ($Coro::current->{conn} = $self);

   ++$::conns;
   $::maxconns = $::conns if $::conns > $::maxconns;

   $self
}

sub DESTROY {
   my $self = shift;

   --$::conns;
}

sub prune_cache {
   my $hash = $_[0];

   for (keys %$hash) {
      if (ref $hash->{$_} eq HASH::) {
         prune_cache($hash->{$_});
         unless (scalar keys %{$hash->{$_}}) {
            delete $hash->{$_};
         }
      }
   }
}

sub prune_caches {
   prune_cache \%conn;
   prune_cache \%uri;

   for (keys %blocked) {
      delete $blocked{$_} unless $blocked{$_}[0] > $::NOW;
   }
}

our $PRUNE_WATCHER = EV::timer 60, 60, \&prune_caches;

sub slog {
   my $self = shift;
   main::slog($_[0], "$self->{remote_id}> $_[1]");
}

sub response {
   my ($self, $code, $msg, $hdr, $content) = @_;
   my $res = "HTTP/1.1 $code $msg\015\012";
   my $GZ = "";

   if (exists $hdr->{Connection}) {
      if ($hdr->{Connection} =~ /close/) {
         $self->{h}{connection} = "close"
      }
   } else {
      if ($self->{version} < 1.1) {
         if ($self->{h}{connection} =~ /keep-alive/i) {
            $hdr->{Connection} = "Keep-Alive";
         } else {
            $self->{h}{connection} = "close"
         }
      }
   }

   if ($self->{method} ne "HEAD"
       && $self->{h}{"accept-encoding"} =~ /\bgzip\b/
       && 400 < length $content
       && $hdr->{"Content-Length"} == length $content
       && !exists $hdr->{"Content-Encoding"}
   ) {
      my $orig = length $content;
      $hdr->{"Content-Encoding"} = "gzip";
      $content = Compress::Zlib::memGzip(\$content);
      $hdr->{"Content-Length"} = length $content;
      $GZ = sprintf "GZ%02d", 100 - 100*((length $content) / $orig);
   }

   $res .= "Date: $HTTP_NOW\015\012";
   $res .= "Server: $::NAME\015\012";

   while (my ($h, $v) = each %$hdr) {
      $res .= "$h: $v\015\012"
   }
   $res .= "\015\012";

   $res .= $content if defined $content and $self->{method} ne "HEAD";

   my $log = (POSIX::strftime "%Y-%m-%d %H:%M:%S", gmtime $::NOW).
             " $self->{remote_id} \"$self->{uri}\" $code ".$hdr->{"Content-Length"}.$GZ.
             " \"$self->{h}{referer}\"\n";

   print $::accesslog $log if $::accesslog;
   print STDERR $log;

   $tbf_top->request(length $res, 1e6);
   $self->{written} += print {$self->{fh}} $res;
}

sub err {
   my $self = shift;
   my ($code, $msg, $hdr, $content) = @_;

   unless (defined $content) {
      $content = "$code $msg\n";
      $hdr->{"Content-Type"} = "text/plain";
      $hdr->{"Content-Length"} = length $content;
   }
   $hdr->{"Connection"} = "close";

   $self->response ($code, $msg, $hdr, $content);

   die bless {}, err::
}

sub handle {
   my $self = shift;
   my $fh = $self->{fh};

   my $host;

   $fh->timeout($::REQ_TIMEOUT);
   while () {
      $self->{reqs}++;

      # read request and parse first line
      my $req = $fh->readline("\015\012\015\012");

      unless (defined $req) {
         if (exists $self->{version}) {
            last;
         } else {
            $self->err(408, "request timeout");
         }
      }

      $self->{h} = {};

      $fh->timeout($::RES_TIMEOUT);

      $req =~ /^(?:\015\012)?
                (GET|HEAD) \040+
                ([^\040]+) \040+
                HTTP\/([0-9]+\.[0-9]+)
                \015\012/gx
         or $self->err(405, "method not allowed", { Allow => "GET,HEAD" });

      $self->{method} = $1;
      $self->{uri} = $2;
      $self->{version} = $3;

      $3 =~ /^1\./
         or $self->err(506, "http protocol version $3 not supported");

      # parse headers
      {
         my (%hdr, $h, $v);

         $hdr{lc $1} .= ",$2"
            while $req =~ /\G
                  ([^:\000-\040]+):
                  [\011\040]*
                  ((?: [^\015\012]+ | \015\012[\011\040] )*)
                  \015\012
               /gxc;

         $req =~ /\G\015\012$/
            or $self->err(400, "bad request");

         $self->{h}{$h} = substr $v, 1
            while ($h, $v) = each %hdr;
      }

      # remote id should be unique per user
      my $id = $self->{remote_addr};

      if (exists $self->{h}{"client-ip"}) {
         $id .= "[".$self->{h}{"client-ip"}."]";
      } elsif (exists $self->{h}{"x-forwarded-for"}) {
         $id .= "[".$self->{h}{"x-forwarded-for"}."]";
      }

      $self->{remote_id} = $id;

      weaken (local $conn{$id}{$self*1} = $self);

      if ($blocked{$id}) {
         $self->err_blocked
            if $blocked{$id}[0] > $::NOW;

         delete $blocked{$id};
      }

      # find out server name and port
      if ($self->{uri} =~ s/^http:\/\/([^\/?#]*)//i) {
         $host = $1;
      } else {
         $host = $self->{h}{host};
      }

      if (defined $host) {
         $self->{server_port} = $host =~ s/:([0-9]+)$// ? $1 : 80;
      } else {
         ($self->{server_port}, $host)
            = unpack_sockaddr_in $self->{fh}->sockname
               or $self->err(500, "unable to get socket name");
         $host = inet_ntoa $host;
      }

      $self->{server_name} = $host;

      weaken (local $uri{$id}{$self->{uri}}{$self*1} = $self);

      eval {
         $self->map_uri;
         $self->respond;
      };

      die if $@ && !ref $@;

      last if $self->{h}{connection} =~ /close/i;

      $httpevent->broadcast;

      $fh->timeout($::PER_TIMEOUT);
   }
}

sub block {
   my $self = shift;

   $blocked{$self->{remote_id}} = [$::NOW + $_[0], $_[1]];
   $self->slog(2, "blocked ip $self->{remote_id}");
   $self->err_blocked;
}

# uri => path mapping
sub map_uri {
   my $self = shift;
   my $host = $self->{server_name};
   my $uri = $self->{uri};

   # some massaging, also makes it more secure
   $uri =~ s/%([0-9a-fA-F][0-9a-fA-F])/chr hex $1/ge;
   $uri =~ s%//+%/%g;
   $uri =~ s%/\.(?=/|$)%%g;
   1 while $uri =~ s%/[^/]+/\.\.(?=/|$)%%;

   $uri =~ m%^/?\.\.(?=/|$)%
      and $self->err(400, "bad request");

   $self->{name} = $uri;

   # now do the path mapping
   $self->{path} = "$::DOCROOT/$host$uri";

   $self->access_check;
}

sub _cgi {
   my $self = shift;
   my $path = shift;
   my $fh;

   # no two-way xxx supported
   if (0 == fork) {
      open STDOUT, ">&".fileno($self->{fh});
      if (chdir $::DOCROOT) {
         $ENV{SERVER_SOFTWARE} = "thttpd-myhttpd"; # we are thttpd-alike
         $ENV{HTTP_HOST}       = $self->{server_name};
         $ENV{HTTP_PORT}       = $self->{server_port};
         $ENV{SCRIPT_NAME}     = $self->{name};
         exec $path;
      }
      Coro::State::_exit(0);
   } else {
      die;
   }
}

sub server_hostport {
   $_[0]{server_port} == 80
      ? $_[0]{server_name}
      : "$_[0]{server_name}:$_[0]{server_port}";
}

sub respond {
   my $self = shift;
   my $path = $self->{path};

   if ($self->{name} =~ s%^/internal/([^/]+)%%) {
      if ($::internal{$1}) {
         $::internal{$1}->($self);
      } else {
         $self->err (404, "not found");
      }
   } else {

      stat $path
         or $self->err (404, "not found");

      $self->{stat} = [stat _];

      # idiotic netscape sends idiotic headers AGAIN
      my $ims = $self->{h}{"if-modified-since"} =~ /^([^;]+)/
                ? str2time $1 : 0;

      if (-d _ && -r _) {
         # directory
         if ($path !~ /\/$/) {
            # create a redirect to get the trailing "/"
            # we don't try to avoid the :80
            $self->err (301, "moved permanently", { Location =>  "http://".$self->server_hostport."$self->{uri}/" });
         } else {
            $ims < $self->{stat}[9]
               or $self->err (304, "not modified");

            if (-r "$path/index.html") {
               # replace directory "size" by index.html filesize
               $self->{stat} = [stat ($self->{path} .= "/index.html")];
               $self->handle_file ($queue_index, $tbf_top);
            } else {
               $self->handle_dir;
            }
         }
      } elsif (-f _ && -r _) {
         -x _ and $self->err (403, "forbidden");

         if (keys %{$conn{$self->{remote_id}}} > $::MAX_TRANSFERS_IP) {
            my $timeout = $::NOW + 10;
            while (keys %{$conn{$self->{remote_id}}} > $::MAX_TRANSFERS_IP) {
               if ($timeout < $::NOW) {
                  $self->block($::BLOCKTIME, "too many connections");
               } else {
                  $httpevent->wait;
               }
            }
         }

         $self->handle_file ($queue_file, $tbf_top);
      } else {
         $self->err (404, "not found");
      }
   }
}

sub handle_dir {
   my $self = shift;
   my $idx = $self->diridx;

   $self->response (200, "ok",
         {
            "Content-Type"   => "text/html; charset=utf-8",
            "Content-Length" => length $idx,
            "Last-Modified"  => time2str ($self->{stat}[9]),
         },
         $idx);
}

sub handle_file {
   my ($self, $queue, $tbf) = @_;
   my $length = $self->{stat}[7];
   my $hdr = {
      "Last-Modified" => time2str ((stat _)[9]),
      "Accept-Ranges" => "bytes",
   };

   my @code = (200, "ok");
   my ($l, $h);

   if ($self->{h}{range} =~ /^bytes=(.*)$/) {
      for (split /,/, $1) {
         if (/^-(\d+)$/) {
            ($l, $h) = ($length - $1, $length - 1);
         } elsif (/^(\d+)-(\d*)$/) {
            ($l, $h) = ($1, ($2 ne "" || $2 >= $length) ? $2 : $length - 1);
         } else {
            ($l, $h) = (0, $length - 1);
            goto ignore;
         }
         goto satisfiable if $l >= 0 && $l < $length && $h >= 0 && $h >= $l;
      }
      $hdr->{"Content-Range"} = "bytes */$length";
      $hdr->{"Content-Length"} = $length;
      $self->err (416, "not satisfiable", $hdr, "");

satisfiable:
      # check for segmented downloads
      if ($l && $::NO_SEGMENTED) {
         my $timeout = $::NOW + 15;
         while (keys %{$uri{$self->{remote_id}}{$self->{uri}}} > 1) {
            if ($timeout <= $::NOW) {
               $self->block ($::BLOCKTIME, "segmented downloads are forbidden");
               #$self->err_segmented_download;
            } else {
               $httpevent->wait;
            }
         }
      }

      $hdr->{"Content-Range"} = "bytes $l-$h/$length";
      @code = (206, "partial content");
      $length = $h - $l + 1;

ignore:
   } else {
      ($l, $h) = (0, $length - 1);
   }

   $self->{path} =~ /\.([^.]+)$/;
   $hdr->{"Content-Type"} = $mimetype{lc $1} || "application/octet-stream";
   $hdr->{"Content-Length"} = $length;

   $self->response (@code, $hdr, "");

   if ($self->{method} eq "GET") {
      $self->{time} = $::NOW;
      $self->{written} = 0;

      open my $fh, "<", $self->{path}
         or die "$self->{path}: late open failure ($!)";

      $h -= $l - 1;

      my $transfer = $queue->start_transfer ($h);
      my $locked;
      my $bufsize = $::WAIT_BUFSIZE; # initial buffer size

      while ($h > 0) {
         unless ($locked) {
            if ($locked ||= $transfer->try ($::WAIT_INTERVAL)) {
               $bufsize = $::BUFSIZE;
               $self->{time} = $::NOW;
               $self->{written} = 0;
            }
         }

         if ($blocked{$self->{remote_id}}) {
            $self->{h}{connection} = "close";
            die bless {}, err::;
         }

         Coro::AIO::aio_read $fh, $l, ($h > $bufsize ? $bufsize : $h), my $buf, 0
            or last;

         $tbf->request (length $buf);
         my $w = syswrite $self->{fh}, $buf
            or last;
         $::written += $w;
         $self->{written} += $w;
         $l += $w;
      }

      close $fh;
   }
}

1

Revision:	1.84
Committed:	Sat Dec 8 21:01:16 2007 UTC (16 years, 7 months ago) by root
Content type:	text/plain
Branch:	MAIN
CVS Tags:	rel-4_4, rel-4_32, rel-4_33, rel-4_34, rel-4_35, rel-4_36, rel-4_37
Changes since 1.83:	+6 -7 lines
Log Message:	convert from Event to EV
#	Content
1	use Coro;
2	use Coro::Semaphore;
3	use Coro::EV;
4	use Coro::Socket;
5	use Coro::Signal;
6	use Coro::AIO ();
7
8	use HTTP::Date;
9	use POSIX ();
10
11	use Compress::Zlib ();
12
13	no utf8;
14	use bytes;
15
16	# at least on my machine, this thingy serves files
17	# quite a bit faster than apache, ;)
18	# and quite a bit slower than thttpd :(
19
20	$SIG{PIPE} = 'IGNORE';
21
22	our $accesslog;
23	our $errorlog;
24
25	our $NOW;
26	our $HTTP_NOW;
27
28	our $ERROR_LOG;
29	our $ACCESS_LOG;
30
31	our $update_time = EV::periodic 0, 1, undef, sub {
32	$NOW = time;
33	$HTTP_NOW = time2str $NOW;
34	};
35	$update_time->invoke;
36
37	if ($ERROR_LOG) {
38	use IO::Handle;
39	open $errorlog, ">>$ERROR_LOG"
40	or die "$ERROR_LOG: $!";
41	$errorlog->autoflush(1);
42	}
43
44	if ($ACCESS_LOG) {
45	use IO::Handle;
46	open $accesslog, ">>$ACCESS_LOG"
47	or die "$ACCESS_LOG: $!";
48	$accesslog->autoflush(1);
49	}
50
51	sub slog {
52	my $level = shift;
53	my $format = shift;
54	my $NOW = (POSIX::strftime "%Y-%m-%d %H:%M:%S", gmtime $::NOW);
55	printf "$NOW: $format\n", @_;
56	printf $errorlog "$NOW: $format\n", @_ if $errorlog;
57	}
58
59	our $connections = new Coro::Semaphore $MAX_CONNECTS \|\| 250;
60	our $httpevent = new Coro::Signal;
61
62	our $queue_file = new transferqueue $MAX_TRANSFERS;
63	our $queue_index = new transferqueue 10;
64
65	our $tbf_top = new tbf rate => $TBF_RATE \|\| 100000;
66
67	my $unused_bytes = 0;
68	my $unused_last = time;
69
70	sub unused_bandwidth {
71	$unused_bytes += $_[0];
72	if ($unused_last < $NOW - 30 && $unused_bytes / ($NOW - $unused_last) > 50000) {
73	$unused_last = $NOW;
74	$unused_bytes = 0;
75	$queue_file->force_wake_next;
76	slog 1, "forced filetransfer due to unused bandwidth";
77	}
78	}
79
80	my @newcons;
81	my @pool;
82
83	# one "execution thread"
84	sub handler {
85	while () {
86	if (@newcons) {
87	eval {
88	conn->new (@{pop @newcons})->handle;
89	};
90	slog 1, "$@" if $@ && !ref $@;
91
92	$httpevent->broadcast; # only for testing, but doesn't matter much
93
94	$connections->up;
95	} else {
96	last if @pool >= $MAX_POOL;
97	push @pool, $Coro::current;
98	schedule;
99	}
100	}
101	}
102
103	sub listen_on {
104	my $listen = $_[0];
105
106	push @listen_sockets, $listen;
107
108	# the "main thread"
109	async {
110	slog 1, "accepting connections";
111	while () {
112	$connections->down;
113	push @newcons, [$listen->accept];
114	#slog 3, "accepted @$connections ".scalar(@pool);
115	if (@pool) {
116	(pop @pool)->ready;
117	} else {
118	async \&handler;
119	}
120	}
121	};
122	}
123
124	my $http_port = new Coro::Socket
125	LocalAddr => $SERVER_HOST,
126	LocalPort => $SERVER_PORT,
127	ReuseAddr => 1,
128	Listen => 50,
129	or die "unable to start server";
130
131	listen_on $http_port;
132
133	if ($SERVER_PORT2) {
134	my $http_port = new Coro::Socket
135	LocalAddr => $SERVER_HOST,
136	LocalPort => $SERVER_PORT2,
137	ReuseAddr => 1,
138	Listen => 50,
139	or die "unable to start server";
140
141	listen_on $http_port;
142	}
143
144	package conn;
145
146	use strict;
147	use bytes;
148
149	use Socket;
150	use HTTP::Date;
151	use Convert::Scalar 'weaken';
152	use IO::AIO;
153
154	IO::AIO::min_parallel $::AIO_PARALLEL;
155
156	our $AIO_WATCHER = EV::io IO::AIO::poll_fileno, EV::READ, \&IO::AIO::poll_cb;
157
158	our %conn; # $conn{ip}{self} => connobj
159	our %uri; # $uri{ip}{uri}{self}
160	our %blocked;
161	our %mimetype;
162
163	sub read_mimetypes {
164	if (open my $fh, "<mime_types") {
165	while (<$fh>) {
166	if (/^([^#]\S+)\t+(\S+)$/) {
167	$mimetype{lc $1} = $2;
168	}
169	}
170	} else {
171	print "cannot open mime_types\n";
172	}
173	}
174
175	read_mimetypes;
176
177	sub new {
178	my $class = shift;
179	my $fh = shift;
180	my $peername = shift;
181	my $self = bless { fh => $fh }, $class;
182	my (undef, $iaddr) = unpack_sockaddr_in $peername
183	or $self->err (500, "unable to decode peername");
184
185	$self->{remote_addr} =
186	$self->{remote_id} = inet_ntoa $iaddr;
187
188	$self->{time} = $::NOW;
189
190	weaken ($Coro::current->{conn} = $self);
191
192	++$::conns;
193	$::maxconns = $::conns if $::conns > $::maxconns;
194
195	$self
196	}
197
198	sub DESTROY {
199	my $self = shift;
200
201	--$::conns;
202	}
203
204	sub prune_cache {
205	my $hash = $_[0];
206
207	for (keys %$hash) {
208	if (ref $hash->{$_} eq HASH::) {
209	prune_cache($hash->{$_});
210	unless (scalar keys %{$hash->{$_}}) {
211	delete $hash->{$_};
212	}
213	}
214	}
215	}
216
217	sub prune_caches {
218	prune_cache \%conn;
219	prune_cache \%uri;
220
221	for (keys %blocked) {
222	delete $blocked{$_} unless $blocked{$_}[0] > $::NOW;
223	}
224	}
225
226	our $PRUNE_WATCHER = EV::timer 60, 60, \&prune_caches;
227
228	sub slog {
229	my $self = shift;
230	main::slog($_[0], "$self->{remote_id}> $_[1]");
231	}
232
233	sub response {
234	my ($self, $code, $msg, $hdr, $content) = @_;
235	my $res = "HTTP/1.1 $code $msg\015\012";
236	my $GZ = "";
237
238	if (exists $hdr->{Connection}) {
239	if ($hdr->{Connection} =~ /close/) {
240	$self->{h}{connection} = "close"
241	}
242	} else {
243	if ($self->{version} < 1.1) {
244	if ($self->{h}{connection} =~ /keep-alive/i) {
245	$hdr->{Connection} = "Keep-Alive";
246	} else {
247	$self->{h}{connection} = "close"
248	}
249	}
250	}
251
252	if ($self->{method} ne "HEAD"
253	&& $self->{h}{"accept-encoding"} =~ /\bgzip\b/
254	&& 400 < length $content
255	&& $hdr->{"Content-Length"} == length $content
256	&& !exists $hdr->{"Content-Encoding"}
257	) {
258	my $orig = length $content;
259	$hdr->{"Content-Encoding"} = "gzip";
260	$content = Compress::Zlib::memGzip(\$content);
261	$hdr->{"Content-Length"} = length $content;
262	$GZ = sprintf "GZ%02d", 100 - 100*((length $content) / $orig);
263	}
264
265	$res .= "Date: $HTTP_NOW\015\012";
266	$res .= "Server: $::NAME\015\012";
267
268	while (my ($h, $v) = each %$hdr) {
269	$res .= "$h: $v\015\012"
270	}
271	$res .= "\015\012";
272
273	$res .= $content if defined $content and $self->{method} ne "HEAD";
274
275	my $log = (POSIX::strftime "%Y-%m-%d %H:%M:%S", gmtime $::NOW).
276	" $self->{remote_id} \"$self->{uri}\" $code ".$hdr->{"Content-Length"}.$GZ.
277	" \"$self->{h}{referer}\"\n";
278
279	print $::accesslog $log if $::accesslog;
280	print STDERR $log;
281
282	$tbf_top->request(length $res, 1e6);
283	$self->{written} += print {$self->{fh}} $res;
284	}
285
286	sub err {
287	my $self = shift;
288	my ($code, $msg, $hdr, $content) = @_;
289
290	unless (defined $content) {
291	$content = "$code $msg\n";
292	$hdr->{"Content-Type"} = "text/plain";
293	$hdr->{"Content-Length"} = length $content;
294	}
295	$hdr->{"Connection"} = "close";
296
297	$self->response ($code, $msg, $hdr, $content);
298
299	die bless {}, err::
300	}
301
302	sub handle {
303	my $self = shift;
304	my $fh = $self->{fh};
305
306	my $host;
307
308	$fh->timeout($::REQ_TIMEOUT);
309	while () {
310	$self->{reqs}++;
311
312	# read request and parse first line
313	my $req = $fh->readline("\015\012\015\012");
314
315	unless (defined $req) {
316	if (exists $self->{version}) {
317	last;
318	} else {
319	$self->err(408, "request timeout");
320	}
321	}
322
323	$self->{h} = {};
324
325	$fh->timeout($::RES_TIMEOUT);
326
327	$req =~ /^(?:\015\012)?
328	(GET\|HEAD) \040+
329	([^\040]+) \040+
330	HTTP\/([0-9]+\.[0-9]+)
331	\015\012/gx
332	or $self->err(405, "method not allowed", { Allow => "GET,HEAD" });
333
334	$self->{method} = $1;
335	$self->{uri} = $2;
336	$self->{version} = $3;
337
338	$3 =~ /^1\./
339	or $self->err(506, "http protocol version $3 not supported");
340
341	# parse headers
342	{
343	my (%hdr, $h, $v);
344
345	$hdr{lc $1} .= ",$2"
346	while $req =~ /\G
347	([^:\000-\040]+):
348	[\011\040]*
349	((?: [^\015\012]+ \| \015\012[\011\040] )*)
350	\015\012
351	/gxc;
352
353	$req =~ /\G\015\012$/
354	or $self->err(400, "bad request");
355
356	$self->{h}{$h} = substr $v, 1
357	while ($h, $v) = each %hdr;
358	}
359
360	# remote id should be unique per user
361	my $id = $self->{remote_addr};
362
363	if (exists $self->{h}{"client-ip"}) {
364	$id .= "[".$self->{h}{"client-ip"}."]";
365	} elsif (exists $self->{h}{"x-forwarded-for"}) {
366	$id .= "[".$self->{h}{"x-forwarded-for"}."]";
367	}
368
369	$self->{remote_id} = $id;
370
371	weaken (local $conn{$id}{$self*1} = $self);
372
373	if ($blocked{$id}) {
374	$self->err_blocked
375	if $blocked{$id}[0] > $::NOW;
376
377	delete $blocked{$id};
378	}
379
380	# find out server name and port
381	if ($self->{uri} =~ s/^http:\/\/([^\/?#]*)//i) {
382	$host = $1;
383	} else {
384	$host = $self->{h}{host};
385	}
386
387	if (defined $host) {
388	$self->{server_port} = $host =~ s/:([0-9]+)$// ? $1 : 80;
389	} else {
390	($self->{server_port}, $host)
391	= unpack_sockaddr_in $self->{fh}->sockname
392	or $self->err(500, "unable to get socket name");
393	$host = inet_ntoa $host;
394	}
395
396	$self->{server_name} = $host;
397
398	weaken (local $uri{$id}{$self->{uri}}{$self*1} = $self);
399
400	eval {
401	$self->map_uri;
402	$self->respond;
403	};
404
405	die if $@ && !ref $@;
406
407	last if $self->{h}{connection} =~ /close/i;
408
409	$httpevent->broadcast;
410
411	$fh->timeout($::PER_TIMEOUT);
412	}
413	}
414
415	sub block {
416	my $self = shift;
417
418	$blocked{$self->{remote_id}} = [$::NOW + $_[0], $_[1]];
419	$self->slog(2, "blocked ip $self->{remote_id}");
420	$self->err_blocked;
421	}
422
423	# uri => path mapping
424	sub map_uri {
425	my $self = shift;
426	my $host = $self->{server_name};
427	my $uri = $self->{uri};
428
429	# some massaging, also makes it more secure
430	$uri =~ s/%([0-9a-fA-F][0-9a-fA-F])/chr hex $1/ge;
431	$uri =~ s%//+%/%g;
432	$uri =~ s%/\.(?=/\|$)%%g;
433	1 while $uri =~ s%/[^/]+/\.\.(?=/\|$)%%;
434
435	$uri =~ m%^/?\.\.(?=/\|$)%
436	and $self->err(400, "bad request");
437
438	$self->{name} = $uri;
439
440	# now do the path mapping
441	$self->{path} = "$::DOCROOT/$host$uri";
442
443	$self->access_check;
444	}
445
446	sub _cgi {
447	my $self = shift;
448	my $path = shift;
449	my $fh;
450
451	# no two-way xxx supported
452	if (0 == fork) {
453	open STDOUT, ">&".fileno($self->{fh});
454	if (chdir $::DOCROOT) {
455	$ENV{SERVER_SOFTWARE} = "thttpd-myhttpd"; # we are thttpd-alike
456	$ENV{HTTP_HOST} = $self->{server_name};
457	$ENV{HTTP_PORT} = $self->{server_port};
458	$ENV{SCRIPT_NAME} = $self->{name};
459	exec $path;
460	}
461	Coro::State::_exit(0);
462	} else {
463	die;
464	}
465	}
466
467	sub server_hostport {
468	$_[0]{server_port} == 80
469	? $_[0]{server_name}
470	: "$_[0]{server_name}:$_[0]{server_port}";
471	}
472
473	sub respond {
474	my $self = shift;
475	my $path = $self->{path};
476
477	if ($self->{name} =~ s%^/internal/([^/]+)%%) {
478	if ($::internal{$1}) {
479	$::internal{$1}->($self);
480	} else {
481	$self->err (404, "not found");
482	}
483	} else {
484
485	stat $path
486	or $self->err (404, "not found");
487
488	$self->{stat} = [stat _];
489
490	# idiotic netscape sends idiotic headers AGAIN
491	my $ims = $self->{h}{"if-modified-since"} =~ /^([^;]+)/
492	? str2time $1 : 0;
493
494	if (-d _ && -r _) {
495	# directory
496	if ($path !~ /\/$/) {
497	# create a redirect to get the trailing "/"
498	# we don't try to avoid the :80
499	$self->err (301, "moved permanently", { Location => "http://".$self->server_hostport."$self->{uri}/" });
500	} else {
501	$ims < $self->{stat}[9]
502	or $self->err (304, "not modified");
503
504	if (-r "$path/index.html") {
505	# replace directory "size" by index.html filesize
506	$self->{stat} = [stat ($self->{path} .= "/index.html")];
507	$self->handle_file ($queue_index, $tbf_top);
508	} else {
509	$self->handle_dir;
510	}
511	}
512	} elsif (-f _ && -r _) {
513	-x _ and $self->err (403, "forbidden");
514
515	if (keys %{$conn{$self->{remote_id}}} > $::MAX_TRANSFERS_IP) {
516	my $timeout = $::NOW + 10;
517	while (keys %{$conn{$self->{remote_id}}} > $::MAX_TRANSFERS_IP) {
518	if ($timeout < $::NOW) {
519	$self->block($::BLOCKTIME, "too many connections");
520	} else {
521	$httpevent->wait;
522	}
523	}
524	}
525
526	$self->handle_file ($queue_file, $tbf_top);
527	} else {
528	$self->err (404, "not found");
529	}
530	}
531	}
532
533	sub handle_dir {
534	my $self = shift;
535	my $idx = $self->diridx;
536
537	$self->response (200, "ok",
538	{
539	"Content-Type" => "text/html; charset=utf-8",
540	"Content-Length" => length $idx,
541	"Last-Modified" => time2str ($self->{stat}[9]),
542	},
543	$idx);
544	}
545
546	sub handle_file {
547	my ($self, $queue, $tbf) = @_;
548	my $length = $self->{stat}[7];
549	my $hdr = {
550	"Last-Modified" => time2str ((stat _)[9]),
551	"Accept-Ranges" => "bytes",
552	};
553
554	my @code = (200, "ok");
555	my ($l, $h);
556
557	if ($self->{h}{range} =~ /^bytes=(.*)$/) {
558	for (split /,/, $1) {
559	if (/^-(\d+)$/) {
560	($l, $h) = ($length - $1, $length - 1);
561	} elsif (/^(\d+)-(\d*)$/) {
562	($l, $h) = ($1, ($2 ne "" \|\| $2 >= $length) ? $2 : $length - 1);
563	} else {
564	($l, $h) = (0, $length - 1);
565	goto ignore;
566	}
567	goto satisfiable if $l >= 0 && $l < $length && $h >= 0 && $h >= $l;
568	}
569	$hdr->{"Content-Range"} = "bytes */$length";
570	$hdr->{"Content-Length"} = $length;
571	$self->err (416, "not satisfiable", $hdr, "");
572
573	satisfiable:
574	# check for segmented downloads
575	if ($l && $::NO_SEGMENTED) {
576	my $timeout = $::NOW + 15;
577	while (keys %{$uri{$self->{remote_id}}{$self->{uri}}} > 1) {
578	if ($timeout <= $::NOW) {
579	$self->block ($::BLOCKTIME, "segmented downloads are forbidden");
580	#$self->err_segmented_download;
581	} else {
582	$httpevent->wait;
583	}
584	}
585	}
586
587	$hdr->{"Content-Range"} = "bytes $l-$h/$length";
588	@code = (206, "partial content");
589	$length = $h - $l + 1;
590
591	ignore:
592	} else {
593	($l, $h) = (0, $length - 1);
594	}
595
596	$self->{path} =~ /\.([^.]+)$/;
597	$hdr->{"Content-Type"} = $mimetype{lc $1} \|\| "application/octet-stream";
598	$hdr->{"Content-Length"} = $length;
599
600	$self->response (@code, $hdr, "");
601
602	if ($self->{method} eq "GET") {
603	$self->{time} = $::NOW;
604	$self->{written} = 0;
605
606	open my $fh, "<", $self->{path}
607	or die "$self->{path}: late open failure ($!)";
608
609	$h -= $l - 1;
610
611	my $transfer = $queue->start_transfer ($h);
612	my $locked;
613	my $bufsize = $::WAIT_BUFSIZE; # initial buffer size
614
615	while ($h > 0) {
616	unless ($locked) {
617	if ($locked \|\|= $transfer->try ($::WAIT_INTERVAL)) {
618	$bufsize = $::BUFSIZE;
619	$self->{time} = $::NOW;
620	$self->{written} = 0;
621	}
622	}
623
624	if ($blocked{$self->{remote_id}}) {
625	$self->{h}{connection} = "close";
626	die bless {}, err::;
627	}
628
629	Coro::AIO::aio_read $fh, $l, ($h > $bufsize ? $bufsize : $h), my $buf, 0
630	or last;
631
632	$tbf->request (length $buf);
633	my $w = syswrite $self->{fh}, $buf
634	or last;
635	$::written += $w;
636	$self->{written} += $w;
637	$l += $w;
638	}
639
640	close $fh;
641	}
642	}
643
644	1
645