#!/usr/bin/perl -w
use strict;
use IO::Socket;
use IO::Select;
$|++;  # always flush

=head1 Title


   BURP - Barely Usable Remote Protocol
   v1.0

   
   BURP is a remotely-accessible hashtable.  Or, put another way,
   it's a TCP text protocol wrapped around a hashtable.
   
   Why use a hashtable?  Why not just send actual perl code to the
   server and return the result?  Well, I don't want the system to
   be *that* open, so maybe this is the next best thing.
   
   
   To use the BURP protocol, simply point your TCP client at BURP's 
   port and send one of the following messages:
   
   
   Commands:
   
      quit!             Close connection
      
   
   
   Gets:
   
   The first two getters return data in an URL-style string, like
   this: key1=val1&key2=val2&key3=val3.  The last getter simply
   returns the value (or the empty string, if there is no value).
   

      *                 Get everything

      /pattern/         Get everything matching a pattern

      key               Get $state{key}



   Sets:
   
      k=v               Set one key/value pair
      
      k=v&k=v&k=v...    Set multiple key/value pairs
   


=cut


my $port  = 8080;
my $lsn   = new IO::Socket::INET(Listen => 1, LocalPort => $port);
my $sel   = new IO::Select( $lsn );
my %state = ();

print "BURP/1.0 listening on port $port.\n";

#####################################################################
#
#   Main Loop
#
#####################################################################
while( my @ready = $sel->can_read ) 
{
   foreach my $fh (@ready)
   {
      if ($fh == $lsn) # Add a new connection
      {
         $sel->add($lsn->accept); 
      }
      else             # Process existing connection
      {
         my $in = '';
         $fh->recv( $in, 4096 );
         $in =~ s/[\r\n]//g;
         
         $_ = $in;
         
         m|\*|      && ( $fh->write( &allQuery() )    &&  next ); # all
         m|/(.*)/|  && ( $fh->write( &grepQuery($1) ) &&  next ); # pattern
         m|=|       && ( $fh->write( &set( $_ ) )     &&  next ); # set
         m|^quit!$| && ( &done( $fh )                 &&  next ); # quit
         m|[^/]|    && ( $fh->write( &oneQuery( $_ ) )   &&  next ); # get 1
      }
   }
}

#####################################################################
#
#   Kill a connection
#
#####################################################################
sub done
{
   my $fh = shift;
   $sel->remove( $fh );
   $fh->close;
}

#####################################################################
#
#   Put values into the hashtable
#
#####################################################################
sub set
{
   my ($text) = @_;
   
   my @pairs = split( '&', $text );
   
   #
   #  Update state
   #
   foreach (@pairs)
   {
      my ($k,$v) = split( '=' );
      $state{ $k } = $v   if $k &&  $v;  # update value
      delete $state{ $k } if $k && !$v;  # remove key
   }
   
   return "status=ok\n";
}

#####################################################################
#
#   Get values from the hashtable
#
#####################################################################
sub allQuery
{
   return query( keys %state );
}

sub grepQuery
{
   my $pattern = shift;
   return query( grep( /$pattern/, keys %state ) );
}

sub query
{
   my @out = ();
   
   foreach my $key (@_)
   {
      my $val = $state{$key} || '';
      push @out, "$key=$val";
   }
   
   return join( '&', @out ) . "\n";
}

sub oneQuery
{
   my $key = shift;
   
   return $state{ $key } . "\n";
}