http://www.perlmonks.org?node_id=17553
Category: Networking Code; Server
Author/Contact Info Max Maischein aka Corion corion@informatik.uni-frankfurt.de
Description:

This is a non-blocking HTTP-based server for a database which contains temporary highly volatile data. It was written as a proof-of-concept and was designed for stuff like the current status of the dial-up connection or the telephone number of the calling party. It has no access control and no security, but it works with both, specialized clients that keep a connection to the server open and HTTP clients like Internet Explorer. Information can be polled but updated data can also be sent to connected clients. Some documentation is attached as a comment.

#
# 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";
};
Replies are listed 'Best First'.
Push HTTP server documentation
by Corion (Patriarch) on Jun 10, 2000 at 20:47 UTC

    mdillon gave this source code a deeper look and complained about the documentation or, more exact, the lack thereof. So I write this node to document the features of the above server a bit, that all of you might play with it.

    Purpose

    This httpd server saw light as a proof-of-concept server for a database with highly volatile data. Such data was mostly read-only access from for example the status of the dial-up connection or the calling-party number. It was assumed that no locking of entries would be necessary as there would be only one defined writer for each node and rapid updating would be always possible.

    Command set

    The command set was more or less oriented at what http 1.1 provided, but also allows for server-side notification of clients so that constant polling would be unnecessary.

    GET itemname
    Gets an item. This format allows even a normal HTML browser to view the data.
    Example
    GET HELP
    or, if you want a list of all available items, use

    GET KEYS
    

    SET itemname
    Sets data for an item. You must supply the Content-Length: in the request and then send the data after it Example
    SET TEST 123456
    or, if you want to store multi-line data

    SET TEST
    Content-Length:10
    abc
    defgh
    

    UNSET itemname
    Erases an item. Pooof. Some items, notably those whose name is in the %Readonly hash, cannot be erased except through a direct Perl statement.
    Example
    UNSET TEST

    BYE
    Closes the connection.

    DIE
    Causes the server to die, losing all data.

    RESTART
    Causes the server to exec itself, losing all data.

    CLONE
    Causes the server to save all data to a file and then restart itself from that file, thus preserving all data.

    SOURCE itemname
    Executes the Perl code stored in itemname and returns what the code returned. This is a major security hole but very convenient if you want to add highly dynamic items to the server on the fly.
    Example (courtesy of mdillon)

    SET passwd `cat /etc/passwd`
    SOURCE passwd
    

    The purpose of this command was to faciliate populating the %Status hash with new code, like the code for the KEYS item or the WHO item. Example

    SET code
    Content-Length: ??? <-- fix this
    sub return_test{
      return join(" ", keys %SpecialHash );
    };
    $Status{test} = \&return_test;
    
    This would add a new item, test, that executes the code stored in &return_test every time the item is requested.

      Cool program. I recently reviewed some code to do similar stuff with java. The interesting part was that they had a tiny applet client hidden in a webpage that held persistant connections to their server. This client had the abilty to 'instruct' the host browser to reload a page (via some java-javascript browser calls) every time the server instructed it to do so. It occurs to me that maybe you could develop a similar client to retrofit the functionality you want to existing browsers. Also, do you have a client to demonstrate the persistant connections that you could show us?

        The "official" position is, that the only such client is telnet, and telnet localhost 9000 in several windows lets you test the multi-user "features" (and bugs) quite well.

        I'm not really fit with Java, in fact, I haven't programmed a single line in it, but I'm interested in that persistent connection feature - do you have any pointers where I could look for the right classes to use ? I imagine a remote control/remote panel for a mp3 player that also has status, progress etc. for multiple computers (wired home).

        After talking to some Java wizard who told me that Java vs. Javascript interaction was not as easy as I thought, I'm thinking of actually writing a specialized client (in Perl), that embeds IE to render the HTML - maybe easier than doing it backwards by using IE to download non-http data ;).

        'telnet localhost 9000' should work on almost any platform.

        just type in the commands manually, since they're pretty simple and there aren't too many of them.

        there is also a utility called netcat that is available for most operating systems that will let you do stuff like this:

        echo "GET HELP" | nc localhost 9000

        netcat is available here.

RE: Push HTTP Server
by mdillon (Priest) on Jun 10, 2000 at 20:22 UTC
    in general, i think this is good stuff. here are some small suggestions that might make is slightly more Perlish.

    Suggestions:

    • you might want to use to check whether or not there are items in @UpdateClients: if (@UpdateClients) instead of: if ($#UpdateClients >= 0)

    • change 'if (!defined ...' to 'unless (defined ...'
    more to come, possibly...