#
# Trivial multiplex server, blatantly ripped from IO::Socket documentation
#

#
# The protocol is now a bastardized HTTP/1.2 with a lot of redefined result codes
# This makes it possible to access the server using an off-the-shelf HTTP/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, $Headers, $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}{"Connection"}) eq "CLOSE") ||
      (defined( ${$RequestHeaders}{"Connection"} ) && uc( ${$RequestHeaders}{"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!;                        # http 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 already
  #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";
};