#!/usr/bin/perl -w

use strict;
use IO::Socket;

# gedafed 1.5, dws@ee.ethz.ch, 2001/02/17

# Protocol definition:
#
# 0) from client: SITE url
#      to client: OK\n
#    (mandatory before each of the following requests)
#
# 1) from client: SET user pass\n
#      to client: ticket\n
#
# 2) from client: GET ticket\n
#      to client: OK user pass\n
# or   to client: FAIL\n
#
# 3) from client: CLEAR ticket\n
#      to client: OK\n
#
# 4) from client: GETUNIQUE\n
#      to client: unique-id\n
#
# 5) from client: DROPUNIQUE unique-id\n
#      to client: (OK|FALSE)\n
#
# 6) from client: FILE identifier filename mimetype bytecount\n
#      to client: OK
#    from client: |bytecount bytes|
#      to client: FILE OK bytecount
#
# 7) from client: GETFILE identifier
#      to client: (FILE NOT FOUND|OK mimetype bytecount\n |bytecount bytes|)
#
#
# TODO: cleanup expired tickets

my $DEBUG=0;
my $socket_path = '/tmp/.gedafed.sock';
my $tickets_validity = 7200; # in seconds, delete ticket after that delay of non-use
#my $tickets_validity = 10;

my %tickets_cache = ();
my %uniques_cache = ();

my %files_cache = ();

if($> == 0) {
	# we don't need root privileges
	$> = getpwnam('nobody');
}

$SIG{PIPE}='IGNORE';

if(grep /-d/, @ARGV) {
	print "Debug mode.\n";
	$DEBUG=1
}

sub rand_ascii_32
{
	return sprintf "%04x%04x", rand()*(1<<16), rand()*(1<<16);
}

sub gen_ticket
{
	return sprintf("%08x", time) . '-' . rand_ascii_32 . '-' . rand_ascii_32 . '-' . rand_ascii_32;
}

sub myprint($$)
{
	my $conn = shift;
	my $str = shift;
	print $conn $str;
	print "> $str" if $DEBUG;
}

sub clearfiles(){
    my $exp = time - $tickets_validity;
    for my $id (keys %files_cache){
	for(keys %{$files_cache{$id}}){
	    #2 is the timestamp
	    if($files_cache{$id}{$_}[2] < $exp){
		delete $files_cache{$_};
	    }
	}
    }
}

unlink $socket_path;
my $socket = IO::Socket::UNIX->new(Local  => $socket_path,
                                   Listen => 5 )
	or die "Couldn't setup unix-domain socket ($socket_path): $!\n";

chmod 0666, $socket_path;



while(defined (my $conn = $socket->accept)) {
	# SITE
	$_ = <$conn>;
	if(/^\s*$/) { next; }
	print "< $_" if $DEBUG;
	chomp;
	if(!/^SITE (.+)$/) {
		myprint $conn, "FAIL\n";
		$conn->close;
		next;
	}
	my $site = "$1";
	myprint $conn, "OK\n";

	#clear old files in the buffer;
	#since files can be large but few in number we want
	#to do this every chance we get.
        clearfiles();


	# REQUEST
	$_ = <$conn>;
	if(/^\s*$/) { next; }
	print "< $_" if $DEBUG;
	chomp;
	if(/^SET ([^ ]+) (.+)$/) {
		my $ticket = gen_ticket;
		my $exp = time + $tickets_validity;
		$tickets_cache{$site}{$ticket} = [ $1, $2, $exp ];
		myprint $conn, "$ticket\n";
	}
	elsif(/^GET ([\w-]+)$/) {
		my $data = $tickets_cache{$site}{$1};
		if(!$data or $data->[2]<time) {
			myprint $conn, "FAIL\n"; 
		}
		else {
			# refresh
			$data->[2] = time + $tickets_validity;
			# send user/pass
			myprint $conn, "OK $data->[0] $data->[1]\n";
		}
	}
	elsif(/^CLEAR ([\w-]+)$/) {
		delete $tickets_cache{$site}{$1};
		myprint $conn, "OK\n";
	}
	elsif(/^GETUNIQUE$/) {
		my $id = gen_ticket;
		$uniques_cache{$site}{$id}=1;
		myprint $conn, "$id\n";
	}
	elsif(/^DROPUNIQUE ([\w-]+)$/) {
		if(exists $uniques_cache{$site}{$1}) {
			delete $uniques_cache{$site}{$1};
			myprint $conn, "OK\n";
		}
		else {
			myprint $conn, "FAIL\n";
		}
	}
	elsif(/^FILE ([\w-]+) (\S+) ([-\w\/]+) (\d+)$/) {
	        my $id     = $1;
	        my $name   = $2;
	        my $type   = $3;
	        my $length = $4;
		myprint $conn, "OK\n";
		my $blob;
		read($conn,$blob,$length);
		$files_cache{$id}{$name}=[$blob,$type,time];
		$length = length $blob;
		myprint $conn, "FILE OK $length\n";
	}
	elsif(/^GETFILE ([\w-]+) (\S+)$/) {
	        my $id     = $1;
	        my $name   = $2;
		if(!$files_cache{$id}{$name}){
		    myprint($conn, "FILE NOT FOUND\n")
		}else{
		    my $blob = $files_cache{$id}{$name}[0];
		    my $type = $files_cache{$id}{$name}[1];
		    $files_cache{$id}{$name}[2] = time;
		    my $length = length $blob;
		    myprint $conn, "OK $type $length\n";
		    myprint $conn, $blob;
		}
	}
	elsif(/^\s$/) {
		;
	}
	else {
		print STDERR "Protocol Error: $_";
		myprint $conn, "ERROR\n";
	}
	print "\n" if $DEBUG;
	$conn->close;
}
