#
# Trivial multiplex server, blatantly ripped from IO::Socket documenta
+tion
#
#
# The protocol is now a bastardized HTTP/1.2 with a lot of redefined r
+esult codes
# This makes it possible to access the server using an off-the-shelf H
+TTP/1.1 browser
# (even Lynx with HTTP/1.0 works).
#
# All items get a CR/LF appended, which is also counted in the Content
+-Length. Such is life
# (currently). If an item is unset (status 202 - Removed), the Content
+-Length will be 0.
#
use IO::Select;
use IO::Socket;
use Net::hostent;
$Protocol = "HTTP/1.2"; # Yeah baby - push HTTP
+ :)
$Version = "Eventserver 1.0 $Protocol";
$Port = shift || 9000; # unused port
$Initfile = shift;
$lsn = new IO::Socket::INET(Listen => 1, LocalPort => $Port, Reuse =>
+1);
$sel = new IO::Select( $lsn );
$Newline = "\x0D\x0A";
$Me = $0;
print "Listening on port $Port\n";
%Messages = (
200 => "OK",
201 => "Update",
202 => "Removed",
203 => "Server shutdown",
204 => "Server restart",
205 => "Server status",
# 205 is not (yet) used, later maybe for maintenance
# messages and announcements like "This server will go
# down in 5 minutes"
400 => "Client Error",
401 => "Unknown command",
402 => "Malformed argument",
404 => "No Status Available",
405 => "Cannot set item",
500 => "Internal Error",
);
%Commands = (
"GET" => \&ReturnItem,
"SET" => \&SetItem,
"UNSET" => \&UnsetItem,
"BYE" => \&ReturnBye,
"DIE" => \&DieNow,
"RESTART" => \&Restart,
"CLONE" => \&Clone,
"SOURCE" => \&Source,
);
%Status = (
"VERSION" => $Version,
"HELP" => join( " ", ( sort keys %Commands )),
"KEYS" => \&ItemKeys,
"WHO" => \&ReturnWho,
);
# %Readonly contains the items that cannot be set by the user
%Readonly = (
"VERSION" => undef,
"HELP" => undef,
"KEYS" => undef,
"WHO" => undef,
);
if ($Initfile && -f $Initfile) {
$opt_Init = 1;
&InitFromSaveFile( $Initfile );
undef $opt_Init;
};
%ClientBuffers = ();
@UpdateClients = ();
while(@ready = $sel->can_read) {
foreach $fh (@ready) {
if($fh == $lsn) {
my ($Newsocket, $hostinfo, $hostname );
# Create a new socket
$Newsocket = $lsn->accept;
$Newsocket->autoflush( 1 );
autoflush $Newsocket, 1;
$hostinfo = gethostbyaddr($Newsocket->peeraddr);
$hostname = $hostinfo->name || $Newsocket->peerinfo;
print "New connection from $hostname\n";
$sel->add($Newsocket);
} else {
# Process socket
if (!defined( $fh )) {
print "Client disconnected\n";
$sel->remove($fh);
} else {
my $Request;
if (!sysread( $fh, $Request, 1 )) {
disconnect( $fh );
next;
};
if (defined($ClientBuffers{ $fh })) {
$ClientBuffers{ $fh } .= $Request;
} else {
$ClientBuffers{ $fh } = $Request;
};
if ($Request eq "\x0A" && ($ClientBuffers{ $fh } =~ /$Newline$
+Newline/o)) {
my @Lines = split( /$Newline/o, $ClientBuffers{ $fh } );
$Request = $Lines[0];
undef $ClientBuffers{ $fh };
$Request =~ s/\s+$//g;
$Request =~ s/^([^ ]+)(?: (.+))?//;
$Request = uc( $1 );
my( $Arg ) = $2;
# Remove the request command line
shift @Lines;
# Split up the remaining header into a hash
my %RequestHeader = map { /(\S+)\s*:\s*(\S*)\s*/; if ($1) {
+uc( $1 ) => $2 } } @Lines;
#my ($Key, $Item);
#while (($Key, $Item) = each %RequestHeader) {
# print "$Key => $Item\n";
#};
&HandleCommand( $fh, $Request, $Arg, \%RequestHeader );
}
};
};
# Now see if we have to notify any clients
if (( @UpdateClients ) && !$opt_Init) {
while ( @UpdateClients ) {
my $Item = pop @UpdateClients;
my $Message = "";
my %Header = ("Item" => $Item );
if (defined( $Status{$Item})) {
$Message = $Status{$Item};
};
#$Message .= $Newline;
my @ready = $sel->can_write;
foreach $Client (@ready) {
if (($Client != $fh) && ($Client != $lsn)) {
if ( exists( $Status{$Item} )) {
SendReply( $Client, 201, \%Header, $Message );
} else {
SendReply( $Client, 202, \%Header, "" );
};
};
};
};
};
};
};
sub HandleCommand {
my $fh = shift;
my $Command = shift;
my $Arg = shift;
my $RequestHeader = shift;
my ($Status, $Headers, $Message);
$$Headers{"Connection"} = "Keep-Alive";
if ( $Command ) {
my $Handler = $Commands{ $Command };
if (defined( $Handler )) {
($Status, $Headers, $Message) = &$Handler( $Command, $Arg, $Head
+ers, $fh, $RequestHeader );
if (defined($Status)) {
SendReply( $fh, $Status, $Headers, $Message );
} else {
disconnect( $fh );
};
} else {
SendReply( $fh, 401, $Headers, "Unknown command : $Command" );
};
} else {
SendReply( $fh, 401, $Headers, "Missing command" );
};
if ((defined( ${$Headers}{"Connection"} ) && uc( ${$Headers}{"Connec
+tion"}) eq "CLOSE") ||
(defined( ${$RequestHeaders}{"Connection"} ) && uc( ${$RequestHe
+aders}{"Connection"}) eq "CLOSE")) {
disconnect( $fh );
};
};
sub ReturnWho {
my $Who = "";
my $Handle;
foreach $Handle ($sel->handles) {
if ( $Handle != $lsn ) {
my $hostinfo = gethostbyaddr($Handle->peeraddr);
$Who .= ( $hostinfo->name || $Handle->peerhost ) . $Newline;
};
};
return $Who;
};
sub ReturnItem {
my $Command = shift;
my $Item = shift;
my $Headers = shift;
shift;
my $RequestHeader = shift;
$Item =~ s!^/(.*) HTTP/1.([0-9])+$!$1!; # htt
+p compatibility
&PrepareForHTTP11( $RequestHeader, $Headers, $2 );
${$Headers}{"Item"} = $Item;
if (!defined($Item)) {
return ( 402, $Headers, "Status item missing" );
} else {
if ( defined( $Status{$Item} )) {
my $Result = $Status{$Item};
if (ref($Result)) {
$Result = &$Result( $RequestHeader );
};
return ( 200, $Headers, $Result );
} else {
return ( 404, $Headers, "Status for \"$Item\" not set" );
};
};
};
sub SetItem {
my $Command = shift;
my $Arg = shift;
my $Headers = shift;
my $Client = shift;
my $RequestHeader = shift;
my ($Item, $Value);
if (exists $$RequestHeader{"CONTENT-LENGTH"}) {
my $ReadLength = $$RequestHeader{"CONTENT-LENGTH"};
$Item = $Arg;
print "Reading $ReadLength bytes" unless $opt_Init;
read( $Client, $Value, $ReadLength );
print ", done.\n" unless $opt_Init;
} else {
# Old-style value specified on the command line
($Item, $Value) = ($Arg =~ /^([^ ]+) (.*)/);
};
${$Headers}{"Item"} = $Item;
if (!defined($Item) || !defined($Value)) {
return ( 402, $Headers, "Status item missing" );
} elsif ( exists $Readonly{$Item} ) {
return ( 405, $Headers, "Item is read-only" );
} else {
if (!defined( $Status{ $Item }) || ($Value ne $Status{ $Item })) {
$Status{ $Item } = $Value;
push @UpdateClients, $Item;
};
return ( 200, $Headers, $Status{$Item} );
};
};
sub UnsetItem {
my $Command = shift;
my $Item = shift;
my $Headers = shift;
${$Headers}{"Item"} = $Item;
if (!defined($Item)) {
return ( 402, $Headers, "Status item missing" );
} else {
push @UpdateClients, $Item;
delete $Status{ $Item };
return ( 200, $Headers, "" );
};
};
sub ItemKeys {
my $RequestHeader = shift;
my $RE = $$RequestHeader{"RE"} || ".*";
my @tmp = sort grep( /^$RE/, keys %Status);
my $Result = join( " ", @tmp );
return $Result;
};
sub ReturnKeys {
my $Command = shift;
my $RE = shift || ".*";
my $Headers = shift;
#print "KEYS:$RE\n";
my @tmp = sort grep( /^$RE/, keys %Status);
my $Result = join( " ", @tmp );
return (200, $Headers, $Result);
};
sub ReturnBye {
my $Command = shift;
my $Arg = shift;
my $Headers = shift;
${$Headers}{"Connection"} = "Close";
return (200, $Headers, "Bye" );
};
sub DieNow {
my $Command = shift;
my $Arg = shift;
my $Headers = shift;
# I can't hear you !
$lsn->close;
${$Headers}{"Connection"} = "Close";
my @Clients = $sel->handles;
foreach $Client ( @Clients ) {
if ($Client != $lsn) {
SendReply( $Client, 203, $Headers, "Server shutdown" );
};
disconnect( $Client );
};
die("Server shutdown\n");
# Cannot return since we've effectively disconnected our master alre
+ady
#return ( 500, $Headers, "Shutdown failed");
};
sub Restart {
my $Command = shift;
my $Arg = shift;
my $Headers = shift;
my $fh = shift;
${$Headers}{"Connection"} = "Close";
my @Clients = $sel->handles;
foreach $Client ( @Clients ) {
if ($Client != $lsn) {
SendReply( $Client, 204, $Headers, "Server restart" );
};
disconnect( $Client );
};
print "Server restart, ";
exec( $Me ) or print "Can't restart : $?\n";
# Should never return
return ( 500, $Headers, "Restart failed");
};
sub Clone {
my $Command = shift;
my $Arg = shift;
my $Headers = shift;
my $fh = shift;
${$Headers}{"Connection"} = "Close";
my @Clients = $sel->handles;
foreach $Client ( @Clients ) {
if ($Client != $lsn) {
SendReply( $Client, 204, $Headers, "Server restart" );
};
disconnect( $Client );
};
print "Cloning server, ";
open SAVEFILE, ">" . "dialout.save" || die "opening dialout.save : $
+!\n";
binmode SAVEFILE;
while ((($Key, $Value) = each %Status) ) {
print SAVEFILE "SET $Key\nContent-Length:" . length( $Value ). "\n
+\n" . $Value
unless exists($Readonly{$Key}) || ref($Value);
};
close SAVEFILE;
exec( $Me . " $Port dialout.save" ) or print "Can't clone : $?\n";
# Should never return
return ( 500, $Headers, "Clone failed" );
};
sub Source {
my $Command = shift;
my $Arg = shift;
my $Headers = shift;
my( $Code )= $Status{$Arg};
my $Result = 404;
my $Message = "Item not found";
if ($Code) {
$Message = eval( $Code );
if ($@) {
$Message = $@ if $@;
$Result = 405;
} else { $Result = 200 };
};
return ( $Result, $Headers, $Message );
};
sub SendReply {
my $fh = shift;
my $Number = shift;
my $Human = $Messages{ $Number };
my $Headers = shift || \();
my $Message = shift;
if (!defined( $Message )) { $Message = "<no message>" };
my $HeaderMsg;
${$Headers}{"Content-Length"} = length($Message);
#print "(" . length( $Message ) . ")";
my ($Key, $Value);
while (($Key, $Value) = each %$Headers) {
$HeaderMsg .= $Key . ":" . $Value . $Newline;
};
unless ($opt_Init) {
print $fh $Protocol . " " . $Number . " " . $Human . $Newline;
print $fh $HeaderMsg;
print $fh $Newline;
print $fh $Message;
print $fh $Newline;
};
};
sub disconnect {
my $fh = shift;
print "Client disconnected\n";
$sel->remove($fh);
if ($fh->opened) {
$fh->close;
};
undef $fh;
};
# Fix up the header if a HTTP 1.1 browser has connected
sub PrepareForHTTP11 {
my $RequestHeader = shift;
my $Headers = shift;
my $HTTPMinor = shift;
# If a 1.1 browser comes along, we don't want persistent connections
if (defined( $HTTPMinor ) && ($HTTPMinor lt "2")) {
${$Headers}{"Connection"} = "Close";
};
# If a HTML browser comes along, we want it to interpret this stuff
+as text and not html
if (${$RequestHeader}{"USER-AGENT"} && ${$RequestHeader}{"USER-AGENT
+"} =~ /^Mozilla|^Lynx/i ) {
# but only if the content type has not yet been defined
if (!${$Headers}{"Content-Type"}) {
${$Headers}{"Content-Type"} = "text/plain";
};
};
};
sub InitFromSaveFile {
my $Initfile = shift;
print "Reading settings from \"$Initfile\"";
open HANDLE, "<" . $Initfile or die "opening \"$Initfile\" : $!\n";
binmode HANDLE;
my $Chunk = "";
while (<HANDLE>) {
my $Request = $_;
$Chunk .= $Request;
if ($Request eq "\n") {
my @Lines = split( "\n", $Chunk );
$Request = $Lines[0];
$Chunk = "";
$Request =~ s/\s+$//g;
$Request =~ s/^([^ ]+)(?: (.+))?//;
$Request = uc( $1 );
my( $Arg )= $2;
#print "$Request\n";
# Remove the request command line
shift @Lines;
# Split up the remaining header into a hash
my %RequestHeader = map { /(.+):(.*)\s*/; if ($1) { uc( $1 ) =>
+$2 } } @Lines;
&HandleCommand( HANDLE, $Request, $Arg, \%RequestHeader );
};
};
close HANDLE;
print "\n";
};
|