Annotation of /trunk/bin/gedafed

#!/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

# 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 = ();

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;
}

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";

        # 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(/^\s$/) {
                ;
        }
        else {
                print STDERR "Protocol Error: $_";
                myprint $conn, "ERROR\n";
        }
        print "\n" if $DEBUG;
        $conn->close;
}
1	dpavlin	1	#!/usr/bin/perl -w
2
3			use strict;
4			use IO::Socket;
5
6			# gedafed 1.5, dws@ee.ethz.ch, 2001/02/17
7
8			# Protocol definition:
9			#
10			# 0) from client: SITE url
11			# to client: OK\n
12			# (mandatory before each of the following requests)
13			#
14			# 1) from client: SET user pass\n
15			# to client: ticket\n
16			#
17			# 2) from client: GET ticket\n
18			# to client: OK user pass\n
19			# or to client: FAIL\n
20			#
21			# 3) from client: CLEAR ticket\n
22			# to client: OK\n
23			#
24			# 4) from client: GETUNIQUE\n
25			# to client: unique-id\n
26			#
27			# 5) from client: DROPUNIQUE unique-id\n
28			# to client: (OK\|FALSE)\n
29
30			# TODO: cleanup expired tickets
31
32			my $DEBUG=0;
33			my $socket_path = '/tmp/.gedafed.sock';
34			my $tickets_validity = 7200; # in seconds, delete ticket after that delay of non-use
35			#my $tickets_validity = 10;
36
37			my %tickets_cache = ();
38			my %uniques_cache = ();
39
40			if($> == 0) {
41			# we don't need root privileges
42			$> = getpwnam('nobody');
43			}
44
45			$SIG{PIPE}='IGNORE';
46
47			if(grep /-d/, @ARGV) {
48			print "Debug mode.\n";
49			$DEBUG=1
50			}
51
52			sub rand_ascii_32
53			{
54			return sprintf "%04x%04x", rand()(1<<16), rand()(1<<16);
55			}
56
57			sub gen_ticket
58			{
59			return sprintf("%08x", time) . '-' . rand_ascii_32 . '-' . rand_ascii_32 . '-' . rand_ascii_32;
60			}
61
62			sub myprint($$)
63			{
64			my $conn = shift;
65			my $str = shift;
66			print $conn $str;
67			print "> $str" if $DEBUG;
68			}
69
70			unlink $socket_path;
71			my $socket = IO::Socket::UNIX->new(Local => $socket_path,
72			Listen => 5 )
73			or die "Couldn't setup unix-domain socket ($socket_path): $!\n";
74
75			chmod 0666, $socket_path;
76
77			while(defined (my $conn = $socket->accept)) {
78			# SITE
79			$_ = <$conn>;
80			if(/^\s*$/) { next; }
81			print "< $_" if $DEBUG;
82			chomp;
83			if(!/^SITE (.+)$/) {
84			myprint $conn, "FAIL\n";
85			$conn->close;
86			next;
87			}
88			my $site = "$1";
89			myprint $conn, "OK\n";
90
91			# REQUEST
92			$_ = <$conn>;
93			if(/^\s*$/) { next; }
94			print "< $_" if $DEBUG;
95			chomp;
96			if(/^SET ([^ ]+) (.+)$/) {
97			my $ticket = gen_ticket;
98			my $exp = time + $tickets_validity;
99			$tickets_cache{$site}{$ticket} = [ $1, $2, $exp ];
100			myprint $conn, "$ticket\n";
101			}
102			elsif(/^GET ([\w-]+)$/) {
103			my $data = $tickets_cache{$site}{$1};
104			if(!$data or $data->[2]<time) {
105			myprint $conn, "FAIL\n";
106			}
107			else {
108			# refresh
109			$data->[2] = time + $tickets_validity;
110			# send user/pass
111			myprint $conn, "OK $data->[0] $data->[1]\n";
112			}
113			}
114			elsif(/^CLEAR ([\w-]+)$/) {
115			delete $tickets_cache{$site}{$1};
116			myprint $conn, "OK\n";
117			}
118			elsif(/^GETUNIQUE$/) {
119			my $id = gen_ticket;
120			$uniques_cache{$site}{$id}=1;
121			myprint $conn, "$id\n";
122			}
123			elsif(/^DROPUNIQUE ([\w-]+)$/) {
124			if(exists $uniques_cache{$site}{$1}) {
125			delete $uniques_cache{$site}{$1};
126			myprint $conn, "OK\n";
127			}
128			else {
129			myprint $conn, "FAIL\n";
130			}
131			}
132			elsif(/^\s$/) {
133			;
134			}
135			else {
136			print STDERR "Protocol Error: $_";
137			myprint $conn, "ERROR\n";
138			}
139			print "\n" if $DEBUG;
140			$conn->close;
141			}