#!/usr/bin/perl -w
# a small http daemon that implements netscapes PUT, MOVE and DELETE methods
# so it can be used to store roaming user access properties
# see http://www.snark.de/tools/
# LICENSE: public domain! no warranties whatsoever!

use IO::Socket ;

# defaults:
my $port = 4444 ;
my $nofork = 1 ;
my $verbose = 0 ;
my $detach = 1 ;
my $interface = "0.0.0.0" ;
my $dir = "." ;
my $logfile = "" ;

# the biggest potential vulnerability ist, that other people might use
# this server to store loads of data... so we implement a per-user maximum...
my $maxsize = 2000000 ; # Bytes

# limit the allowed peer hosts by ip-address matching pattern:
# example: $peers = "^192\.168\.1\..+" 
my $peers = ".+" ;

# limit the peers that are allowed to 'create new accounts' by providing
# a previously unknown username/password pair:
my $createPeers = ".+" ;


my $usage = qq{roamie 1.0: a simple server for storing netscape roaming user profiles
\(c\) 2001, Heiko Hellweg (hellweg\@snark.de) [see http://www.snark.de/tools/]
LICENSE: public domain! no warranties whatsoever!
usage: 
roamie [-p port] [-i interface] [-b basedir] [-a allowedPeers] [-c createPeers]
       [-m maxspace] [-l log] [-f] [-v] [-d]
-p port: listen on this local port (default $port)
-i interface: listen on this interface (default $interface)
-b basedir: read/store everything in subdirs of basedir (default: $dir)
-a regex: matched to peers ip-addr. to allow connect at all (default: $peers)
-c regex: matched to peers ip-addr. to allow creating new accounts (def: $createPeers)
-m maxspace: maximum disk usage per account (in Bytes, default: $maxsize)
-l log: store info in this logfile (default: <none>)
-f: fork upon new requests (enable handling multiple requests at once)
-v: verbose (some informational messages...)
-d: debug (verbose, nofork, not detached to daemon mode)
} ;


# this should avoid Zombies in fork mode (-f) (at least on linux):
$SIG{CHLD} ='IGNORE' ; 

# print the verbose output immeadietly
$|=1 ;


#################### main ##################

# get commandline options: 
while(defined($par = shift)) {
    $port = shift || die "-p" if($par eq "-p") ;
    $interface = shift || die "-i" if($par eq "-i") ;
    $dir = shift || die "-b" if($par eq "-b") ;
    $maxsize = shift || die "-m" if($par eq "-m") ;
    $peers = shift || die "-a" if($par eq "-a") ;
    $createPeers = shift || die "-c" if($par eq "-c") ;
    $logfile = shift || die "-l" if($par eq "-l") ;
    $nofork = 0 if($par eq "-f") ;
    $verbose++ if($par eq "-v") ;
    if($par eq "-d") { $verbose++; $nofork = 1; $detach = 0 ;}
    if($par =~ /^--?[hV]/) {
	print $usage ;
	exit 0 ;
    }
}


open (LOGHANDLE, ">>$logfile") || die "can not write $logfile" if $logfile ;

$dir =~ s/\/$// ; # eliminate trailing /
if($dir !~ /^\//) { # relative to "here"
    my $cwd = `pwd` ; chomp $cwd ;
    $dir =~ s/^(\.\/?)?/$cwd\// ;
    logmsg ("dir set to $dir") ;
} 

if($detach) {
    chdir '/' ;
    open STDIN, '/dev/null' || die ;
    open STDOUT, '>/dev/null' || die ;
    open STDERR, '>&STDOUT' || die ;
    # double fork to detach from parent process
    fork && exit ;
    fork && exit ;
}

my $listener = IO::Socket::INET->new(Listen => 5, 
				     LocalAddr => "$interface:$port",
				     Proto => "tcp",
				     Reuse => SO_REUSEADDR) ;

logmsg("roamie up and listening on port $interface:$port using dir $dir\n") ;

 ACCEPTLOOP: 

    while(1) {
	my $con ;
	if(!defined($con = $listener->accept())) {
	    logmsg(scalar(localtime(time)), " Accept failed...\n") ;
	    sleep(2) ;
	    next ACCEPTLOOP ;
	}
	$child = 0 ;
	$child = fork() unless $nofork ;
    
	if($child == 0) {
	    # this is the child proc.. or noforkMode: handle the request
	    my $req = <$con> || "-- empty request --" ; 
	    handleRequest($con, $req) ;
	    $con->flush(); $con->close() ;
	    exit 0 unless $nofork ;
	}
    }

#################### endOfMain ######################


sub handleRequest {
    my ($con, $req) = (@_) ;
    my ($method, $path, $hdrs, $user) = () ;

    $req =~ s/(\d)\s*$/$1/ ; # remove some trailing CR/LF combinations
    logmsg(scalar(localtime), "\t", $con->peerhost(), "\t$req") ;

    if($req =~ /^([A-Z]+)\s+(\/.*)\sHTTP\/\d\.\d/) {
	$method = $1 ;
	$path = $2 ;

	$hdrs = getHeaders($con) || return ; # if allowed peers check fails
	$user = checkAuth($hdrs) ;
	unless ($user) {
	    $con->print(error(401, "Unauthorized", "no authentication", 
			      "WWW-Authenticate: Basic realm=\"roamie\""));
	    return ;
	}
    }
    else {
	$con->print(error(500, "error", 
			  "what kind of request is<pre>$req</pre>???"));
	return ;
    }

    # clean up the path
    while($path =~ s/[^\/]+\/\.\.\///) { ; } ;
    $path =~ tr/A-Za-z0-9\.\-\+\_\//_/c ; # eliminate non standard chars

    if($path =~ /\.\./) {
	$con->print(error(500, "error", "where do you think, you are going?"));
	return ;
    }

    # handle GET requests
    if(($method eq "GET") || ($method eq "HEAD")) {
	if((-f "$dir/$user$path") && (-r "$dir/$user$path")){
	    $con->print("HTTP/1.1 200 OK\n") ;
	    $con->print("Content-Length: ", 
			(stat("$dir/$user$path"))[7], "\n") ;
	    $con->print("Connection: Close\n") ;
	    $con->print("ContentType: ", getContentType($path), "\n") ;
	    $con->print("Last-Modified: ", 
			scalar(localtime((stat("$dir/$user$path"))[9])),
			"\n") ;
	    $con->print("\n") ;
	    if($method eq "GET") { # no content for HEAD
		if(open(RH, "<$dir/$user$path")) {
		    my $content = join("", <RH>) ;
		    $con->print("$content") ;
		}
		else { # hey - i checked -r !!! should never happen
		    $con->close() ;
		}
	    }
	    return ;
	}

	$con->print(error(404, "not found", 
			  "$path could not be found - sorry"));
	return ;
    } # end GET || HEAD

    # handle PUT
    if($method eq "PUT") { # should PUT set the files date according to header?
	my $status = 201 ; my $msg = "Created" ;
	if(-e "$dir/$user$path") {
	    $status = 200 ; $msg = "OK" ;
	}
	if(makepath("$dir/$user", $path)) {
	    if(open(WH, ">$dir/$user$path")) {
		# write $length bytes, read from $con
		my $buf ;
		my $remain = $hdrs->{'Content-Length'}->[0] || 0 ;
		if($maxsize) {
		    my $du = &du("$dir/$user") ;
		    $du =~ s/^(\d+).+/$1/ ;
		    if($du+$remain > $maxsize) {
			logmsg("diskspace $du k + $remain > $maxsize k") ;
			$con->print(error(404, "dir space exceeded", "")) ;
			return ;
		    }
		}
		if($remain) {
		    logmsg("try to read $remain bytes") ;
		    $con->read($buf, $remain) ;
		    print WH $buf ;
		    $con->print(error($status, $msg, "written")) ; # no error
		    logmsg("successfully wrote $dir/$user$path") ;
		    close(WH) ;
		    return ;
		}
		else {
		    logHeaders($hdrs, "Write: no content length") ;
		}
	    }
	    else {
		logHeaders($hdrs, "Write: failed open on $dir/$user$path") ;
	    }
	}
	else {
	    logHeaders($hdrs, "failed makepath $dir/$user$path") ;
	}
	$con->print(error(404, "not writable", 
			  "$path could not be written to - sorry"));
	return ;
    } # end PUT ;

    if($method eq "DELETE") {
	if(-e "$dir/$user$path") {
	    if(unlink "$dir/$user/$path") {
		$con->print(error(200, "OK", "deleted")) ; # not an error...
		logmsg("successfully deleted $dir/$user$path") ;
		return ;
	    }
	}
	$con->print(error(500, "Failed", "can not delete")) ; 
	return ;
    }

    if($method eq "MOVE") { # aka rename
	my $newu = $hdrs->{'New-uri'}->[0] || 0;
	if(-e "$dir/$user$path") {
	    if($hdrs->{'New-uri'}->[0]) {
		while($newu =~ s/[^\/]+\/\.\.\///) { ; } ;
		$newu =~ tr/A-Za-z0-9\.\-\+\_\//_/c ; # eliminate non std chars
		logmsg("Move to: $newu") ;
		if(makepath("$dir/$user", $newu)) { 
		    if(rename "$dir/$user$path", "$dir/$user$newu") {
			$con->print(error(200, "OK", "moved")) ; # not an error
			logmsg("moved $dir/$user$path to $dir/$user$newu") ;
			return ;
		    }
		}
	    }
	}
	$con->print(error(500, "Failed", "can not move $path to $newu")) ; 
	logHeaders($hdrs) ;
	return ;
    } # end MOVE

    # unsupported method like "POST":
    $con->print(error(500, "error", 
		      "what kind of method and request is<pre>$req</pre>???"));
    return ;

}



sub makepath {
    my ($st, $p) = (@_) ;
    my @path = split(/\//, $p) ;
    pop @path ; # dont mkdir the file
    foreach(@path) {
	my $st .= "/$_" ;
	mkdir $st, 0700 || return 0 unless (-d $st) ;
    }
    return 1 ;
}



sub error {
    my ($code, $msg, $content, @moreheaders) = (@_) ;
    logmsg("RES: $code $msg - $content") ;
    return "HTTP/1.1 $code $msg\r\nContent-Type: text/html\r\n"
	. join("\r\n", @moreheaders)
	    .qq{

<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">
<HTML><HEAD>
<TITLE>$code $msg</TITLE>
</HEAD><BODY>
<H1>$code $msg</H1>
$content
</BODY></HTML>
} ;
}


sub logmsg {
    print(join("",  @_), "\n") if $verbose ;
    if($logfile) {
	print(LOGHANDLE join("",  @_), "\n") ;
	flush LOGHANDLE 
    }
    return 0 ;
}


sub getHeaders {
    my ($con) = (@_) ;

    if($peers && ($con->peerhost() !~ /$peers/)) {
	$con->print(error(500, "not allowed", 
			  "daddy says i am not allowed to talk to strangers"));
	return 0 ;
    }

    my $hdrs = { PEER => [ $con->peerhost()] } ;

  HDRLOOP:
    while(<$con>) {
	last HDRLOOP if(/^\s*$/) ;
	if(/^([^\:]+)\:\s+(.*\S)\s*/) {
	    if($hdrs->{$1}) {
		push @{$hdrs->{$1}}, $2 ;
	    }
	    else {
		$hdrs->{$1} = [$2] ;
	    }
	}
    }
    return $hdrs ;
}

sub logHeaders {
    my $hdrs = shift ;
    my $comment = shift || 0 ;
    logmsg($comment) if ($comment);
    my $a ;
    foreach $a (sort keys %{$hdrs}) {
	foreach (@{$hdrs->{$a}}) { logmsg("... $a => $_") ;}    
    }
}


sub checkAuth { 
    # we don't really check authentication - simply make a dir for each 
    # new username/password combo

    my $hdrs = shift ;
    return 0 if(! $hdrs->{'Authorization'}) ;
    foreach (@{$hdrs->{'Authorization'}}){
	if(/Basic (.*\S)\s*/) {
	    my $auth = $1 ;
	    chomp $auth ;
	    my $usr = unmime($auth) ;
	    $usr =~ s/\:.+// ;
	    $auth =~ tr/A-Za-z0-9\-\_\./\_/c ; # make this a safe string 
#	    logmsg("$usr : $auth") ;

	    if(! (-d "$dir/$auth")) {
		if($createPeers && ($hdrs->{'PEER'}->[0] !~ /$createPeers/)) {
		    logmsg("$hdrs->{PEER}->[0]: ",
			   "$usr nonexistant and not allowed to create") ;
		    
		    return 0 ; # we won't let you!<
		}
		else {
		    mkdir "$dir/$auth", 0700 || return logmsg("can not mkdir");
		    return $auth ;
		}
	    }
	    else {
		return $auth ;
	    }
	}
    }
    # none with "Basic" and a matching directory found
    logHeaders($hdrs, "no basic auth") ;
    return 0 ;
}


# unmime (string): decode a mime string - adapted from the perl faq
sub unmime {
    my $mim = shift ;
    $mim =~ tr#A-Za-z0-9+/##cd ;             # remove non-base64 chars
    $mim =~ tr#A-Za-z0-9+/# -_#;             # convert to uuencoded format
    my $len = pack("c", 32 + 0.75*length($mim)); # compute length byte
    return unpack("u", $len . $mim);         # uudecode and return 
}

my %mimetypes = ( htm => "text/html",
		  html => "text/html",
		  txt => "text/plain",
		  gif => "image/gif",
		  jpg => "image/jpeg",
		  jpeg => "image/jpeg") ;
		  

sub getContentType {
    my $url = shift ;
    if($url =~ /\.([^\.\/]+)$/) {
	my $ext = $1 ;
	$ext =~ tr/A-Z/a-z/ ;
	return $mimetypes{$ext} || "application/octetstream" ;
    }
    return "application/octetstream" ;
}


sub du { # calc the disk usage of a subdir
    my $dir = shift ;
    my $size = 0 ;

    $dir =~ s/\/$// ; # remove trailing slash

    opendir(DIRHND, $dir) || die "can not opendir $dir" ; # shouldn't die...
    my @content = readdir(DIRHND) ;
    closedir DIRHND ;

  DIRLOOP:
    foreach (@content) {
	next DIRLOOP if(/^\.\.?$/) ;
	if(-f "$dir/$_") {
	    $size += (stat("$dir/$_"))[7] ;
	}
	elsif(-d "$dir/$_") {
	    # recurse into ... should we exlude symlinks here? nah!
	    $size += du("$dir/$_") ;
	}
	else {
	    # what else ?? die?
	}
    }
    return $size ;
}