Beefy Boxes and Bandwidth Generously Provided by pair Networks
"be consistent"
 
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
  • Outside of code tags, you may need to use entities for some characters:
            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 lurking in the Monastery: (7)
    As of 2014-12-23 02:21 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      Is guessing a good strategy for surviving in the IT business?





      Results (133 votes), past polls