1: #!/usr/bin/perl -wT 2: use strict; 3: use IO::File; 4: use Cwd; 5: use HTTP::Daemon; 6: use HTTP::Status; 7: 8: $| = 1; 9: 10: # We are quite explicit about where we listen 11: my $d = new HTTP::Daemon 12: Reuse => 1, 13: LocalAddr => '192.168.1.100', 14: LocalPort => 8889; 15: 16: my $nofork = $^O =~ /Win32/i; # For easy testing under Win32 17: 18: $SIG{__WARN__} = sub { warn __stamp(shift) }; 19: $SIG{__DIE__} = sub { die __stamp(shift) }; 20: $SIG{CHLD} = 'IGNORE'; 21: 22: warn "Please contact me at: <URL:" . $d->url . ">\n"; 23: 24: $ENV{PATH} = '/bin:/usr/bin'; # Set our path to something secure 25: my $root = $ARGV[0] || cwd; 26: $root = $1 if $root =~ /^(.*)$/; # untaint document root 27: $root .= "/" unless $root =~ m!/$!; 28: 29: # This sub Copyright (c) 1996,97,98,99,2000,01 by Randal L. Schwartz 30: sub __stamp { 31: my ($message) = @_; 32: my $stamp = sprintf "[$$] [%02d@%02d:%02d:%02d] ", (localtime)[3,2,1,0]; 33: $message =~ s/^/$stamp/gm; 34: $message; 35: } 36: 37: sub handleConnection { 38: local $SIG{PIPE} = 'IGNORE'; 39: my ($connection) = @_; 40: while (my $r = $connection->get_request()) { 41: warn $r->as_string; # Yes, that's verbose. 42: 43: my $url = $r->url->path; 44: $url = "/$url" unless $url =~ m!^/!; # Remove all suspicious paths 45: $url =~ s!/.?.(?=/|$)!/!g; 46: $url =~ tr!\x00-\x1F!!d; 47: 48: my $response = new HTTP::Response( 404,undef,undef,"404 - Not found." ); 49: if (-d "$root$url") { 50: $url = "$url/" unless $url =~ m!/$!; 51: opendir DIR, "$root$url"; 52: $response->code(200); 53: $response->content( 54: "<html><head><title>$url</title></head><body><h1>$url</h1><tt>" 55: . join( "<br>", 56: map { my ($cmt,$link) = ((-s "$root$url$_")." bytes",$_); 57: -d _ and $cmt = "directory"; 58: $link =~ s/([ '"?%&:])/{'%'.unpack("H2",$1)}/eg; 59: "<A href='$url$link'>$_</A> $cmt" 60: } sort grep { /^[^.]/ } readdir DIR ) 61: . "</tt></body></html>" ); 62: closedir DIR; 63: } else { 64: my $file = new IO::File "< $root$url"; 65: if (defined $file) { 66: $response->code( 200 ); 67: binmode $file; 68: my $size = -s $file; 69: 70: my ($startrange, $endrange) = (0,$size-1); 71: if (defined $r->header("Range") 72: and $r->header("Range") =~ /bytes\s*=\s*(\d+)-(\d+)?/) { 73: $response->code( 206 ); 74: ($startrange,$endrange) = ($1,$2 || $endrange); 75: }; 76: $file->seek($startrange,0); 77: 78: $response->header(Content_Length => $endrange-$startrange); 79: $response->header(Content_Range => "bytes $startrange-$endrange/$size"); 80: $response->content( sub { 81: sysread($file, my ($buf), 16*1024); # No error checking ??? 82: return $buf; 83: }); 84: }; 85: }; 86: warn "Response :",$response->code; 87: $connection->send_response($response); 88: }; 89: warn "Handled connection (closed, " . $connection->reason . ")"; 90: $connection->close; 91: }; 92: 93: while (my $connection = $d->accept) { 94: # Really condensed fork/nofork handler code 95: next unless $nofork || ! fork(); 96: warn "Forked child" unless $nofork; 97: handleConnection( $connection ); 98: die "Child quit." unless $nofork; 99: }
|
---|
Replies are listed 'Best First'. | |
---|---|
Documentation for the Simple HTTP server in under 100 lines
by Corion (Patriarch) on Oct 04, 2001 at 21:16 UTC | |
Re: Simple HTTP in under 100 lines
by BrowserUk (Patriarch) on Jul 11, 2004 at 00:08 UTC | |
Re: Simple HTTP in under 100 lines
by GeneralElektrix (Acolyte) on Jul 22, 2013 at 14:25 UTC | |
Re: Simple HTTP in under 100 lines
by mattr (Curate) on Nov 13, 2001 at 20:00 UTC | |
by Corion (Patriarch) on Nov 13, 2001 at 20:17 UTC | |
Re: Simple HTTP in under 100 lines
by mischief (Hermit) on Oct 05, 2001 at 21:52 UTC | |
by impossiblerobot (Deacon) on Oct 10, 2001 at 17:25 UTC | |
|
Back to
Craft