Beefy Boxes and Bandwidth Generously Provided by pair Networks
good chemistry is complicated,
and a little bit messy -LW
 
PerlMonks  

Comment on

( #3333=superdoc: print w/ replies, xml ) Need Help??
# # 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"; };

In reply to Push HTTP server by Corion

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others scrutinizing the Monastery: (10)
    As of 2015-07-31 11:35 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









      Results (276 votes), past polls