#! /usr/bin/perl use Socket; socket (S,PF_INET,SOCK_STREAM,getprotobyname("tcp")) || die "Socket $!"; setsockopt(S,SOL_SOCKET,SO_REUSEADDR,1); use MIME::Base64 qw(encode_base64); $ip=INADDR_ANY; $port=1024; $root=""; # no trailing "/" $debug=1; $ru="sesame"; # comment out to disable $rp="secret"; # change euid/egid to nobody when root $asuser="nobody" if ($>==0); if ($asuser) { ($dummy,$dummy,$nouid,$nogid)=getpwnam($asuser); $)="$nogid $nogid"; # egid first $>=$nouid; #$(=$); $<=$>; } bind S,pack('S n a4 x8',AF_INET,$port,$ip) || die "Bind $!"; listen S,1; %guess=("gif"=>"image/gif","jpg"=>"image/jpeg","jpeg"=>"image/jpeg","png"=>"image/png", "htm"=>"text/html","html"=>"text/html", "mp3"=>"audio/mpeg", "pdf"=>"application/pdf","zip"=>"application/x-zip-encoded"); sub human_size { my $size=shift; if ($size>1024) { $size/=1024; if ($size>1024) { $size/=1024; return sprintf("%.1fM",$size); } return sprintf("%.1fK",$size); } return $size; } sub urlencode { # special: does not escape '/' my $str=shift; # $str=~tr/ /+/ if ($nonraw); # TODO: also in following pattern $str=~s/([^a-zA-Z0-9_~.\/-])/"%".uc(sprintf "%lx",unpack("C",$1))/eg; return $str; } sub safe { my $str=shift,$quote=shift; my %ent=qw(& amp < lt > gt " quot); if ($quote) { $str=~s/([&<>"])/"&".$ent{$1}.";"/eg; } else { $str=~s/([&<>])/"&".$ent{$1}.";"/eg; } # $str=~s/([^\x20-\x7f])/"&#".ord($1).";"/eg; # or whatever return $str; } # prefork: 4 instances # TODO?! $SIG{CHLD}=IGNORE; fork(); fork(); while (1) { accept T,S; my $range=''; my $auth=0; while () { print $_ if ($debug>1); chop;chop; if (/^GET (.*) HTTP\/1\../) { $req=$1; if ($req =~ /^(.*)\?logout$/) { $auth=-1; $req=$1; } } elsif (/^Range: bytes=([0-9]+)-/i) { $range=$1; } elsif ( (/^Authorization: basic (.*)$/i)&&($auth!=-1) ) { if ($1 eq encode_base64($ru.':'.$rp,'')) { $auth=1; } else { # print MIME::Base64::decode_base64($1)."\n"; } } if (length($_)==0) { if ($auth==-1) { print T "HTTP/1.1 401 Authorization Required\nLocation: $req\nContent-Type: text/html\n\n\nAuthorization required\n"; # $req still urlencoded! last; } elsif ( (!$auth)&&($ru) ) { print T "HTTP/1.1 401 Authorization Required\nWWW-Authenticate: Basic realm=\"Access Control\"\n\nAuthorization required\n"; last; } $req=~s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; $req=~/([^?]*)[?]?(.*)/; $req=$1; $qus=$2?($2):("text/plain"); $req=~s/[.][.]\/?//g; $fn="$root$req"; # if (!-x $fn) ... if (-d $fn) { if ($fn=~/[^\/]$/) { print T "HTTP/1.1 301 Moved Permanently\nLocation: ".urlencode($req)."/\n\n"; last; } # print T "HTTP/1.1 200 OK\n\n\n".safe($req)."\n\n

DIR: ".safe($req)."

\n"; @da=split("/",$req); $reqa=""; $b=""; $c=pop @da; foreach $a (@da) { $b.="$a/"; $reqa.=''.safe($a).'/'; } $reqa.=safe($c).'/'; print T "HTTP/1.1 200 OK\n\n\n".safe($req)."\n\n

DIR: $reqa"; print T ' [logout]' if ($auth); print T "

\n"; opendir D, $fn; if ($req=~/[^\/]/) { $req=~/(.*\/)[^\/]*\/$/; print T ''."^-Up
\n"; } # while ($a=readdir D) { } @da=sort(readdir D); foreach $a (@da) { if (-d "$fn$a") { if ($a=~/[^.]/) { # print T ''."".safe($a)."
\n"; print T ''.safe($a).' -- tgz -- zip'."
\n"; } } else { my $size=human_size(-s "$fn$a"); $a=~/^[.]?.+[.]([^.]*)$/; if ($guess{lc($1)}) { # print T ''.safe($a).' -- '.safe($1)."
\n"; print T ''.safe($a).' ['.$size.'] -- raw'; } else { print T ''.safe($a).' ['.$size.']'; } print T ' -- gz -- zip'."
\n"; } } closedir D; print T "\n\n"; print "DIR: $fn\n" if $debug; } elsif (!-r $fn) { $req=~/(.*\/)[^\/]*$/; print T "HTTP/1.1 403 Permission denied\n\n\n".safe($req)."\n

Permission denied

^-Up
\n\n\n"; last; } elsif ($qus=~/fly/) { $req=~/(.*\/)[^\/]*$/; $prev=$1; $req=~s/$prev(.*)[.]([^.]*)$/$1/; $end=$2; if ($end eq "tgz") { print T "HTTP/1.1 200 OK\nContent-Type: application/x-gtar\n\n"; open F,"tar cz -C $prev $req |"; print T ; close F; print "TGZ: $fn\n" if $debug; last; } elsif ($end eq "zip") { print T "HTTP/1.1 200 OK\nContent-Type: application/zip\n\n"; open F,"cd $prev; zip -qr - $req |"; print T ; close F; print "ZIP: $fn\n" if $debug; last; } elsif ( ($end eq "gz")&&(-f "$prev$req") ) { print T "HTTP/1.1 200 OK\nContent-Type: application/x-gzip\n\n"; open F,"gzip -c $prev$req |"; print T ; close F; print "GZ: $fn\n" if $debug; last; } else { print T "HTTP/1.1 404 Not Supported\n\n\n".safe($req.$end)." not supported\n

".safe($req).".".safe($end)." not supported

\n\n\n"; print "CompressError: $fn\n" if $debug; } } elsif (-f $fn) { my $size=-s $fn; open F, "$fn"; if ($range) { # TODO(MUST): Date: if ( ($range>=0)&&($range<$size) ) { seek F,$range,0; print T "HTTP/1.1 206 OK\nContent-Type: $qus\nContent-Range: bytes $range-".($size-1)."/$size\nContent-Length: ".($size-$range)."\nAccept-Ranges: bytes\n\n"; } else { print T "HTTP/1.1 416 Requested Range Not Satisfiable\nContent-Range: 0-".($size-1)."/$size\n\n"; last; } } else { print T "HTTP/1.1 200 OK\nContent-Type: $qus\nContent-Length: $size\nAccept-Ranges: bytes\n\n"; } print T ; close F; print "$fn\n" if $debug; } else { print T "HTTP/1.1 404 Not Found\n\n\n".safe($req)." not found\n

".safe($req)." not here

\n\n\n"; print "Error: $fn\n" if $debug; } last; } } shutdown T,0; close T; } shutdown S,2; close S;