#!/usr/bin/perl -w
# sperlderman.pl
# (C) 2007 Julian Albo.
# Revision 19-jun-2007

# Options:
#   --auth       --> Authorization file to use.
#   --browser    --> browser to launch, firefox by default.
#   --debug      --> show debug info
#   --file       --> Use data file.
#   --host       --> host address to bind, localhost by default.
#                    Pass empty string to bind to any address.
#   --port       --> Port number for server.
#   --serveronly --> Do not launch browser.


use strict;

use Getopt::Long;

use URI::Escape;

use HTML::Entities ();

use HTTP::Daemon;
use HTTP::Status;
use HTTP::Response;

use MIME::Base64;

#***********************************************************************
#        Constants
#***********************************************************************

my $title= 'The Amazing Sperlderman';

my $field_cmd= 'cmd';
my $field_persistent= 'persistent';
my $field_code= 'code';
my $field_varname= 'varname';
my $field_vartype= 'vartype';
my $field_varvalue= 'varvalue';
my $field_blockname= 'blockname';

my $location_base= '/';
my $location_exit= '/exit';
my $location_css= '/sperlderman.css';
my $location_script= '/sperlderman.js';
my $location_icon= '/favicon.ico';

my $cmd_send= 'send';
my $cmd_setvar= 'set var';
my $cmd_getblock= 'get block';

#***********************************************************************
#        Global variables
#***********************************************************************

my $debug;
my $user;
my $password;

#***********************************************************************
#          HTML & HTTP helper functions.
#***********************************************************************

sub initialize_response
{
    my $r= HTTP::Response->new (RC_OK);
    $r->header (Content_Type => 'text/html');
    return $r;
}

sub cssfile
{
    return <<END
body
{
  background-color: #D0D0D0;
}
h1
{
  color: red;
}
button
{
  font-family: Helvetica,Arial,sans-serif;
  color: white;
  background-color: blue;
  font-size: 110%;
  font-weight: bold;
  text-decoration: none;
  margin-right: 4pt;
  margin-left: 4pt;
  border-style: outset;
  border-color: blue;
  border-width: 2pt;
  padding-left: 6pt;
  padding-right: 6pt;
}
button:hover
{
  color: yellow;
}
button:active
{
  color: yellow;
  border-style: inset;
}
END
;
}

sub scriptfile
{
    return <<END
function getById (id)
{
  return document.getElementById (id);
}
function visualizeElement (elem)
{
  elem.style.visibility= 'visible';
}
function hideElement (elem)
{
  elem.style.visibility= 'hidden';
}
function dispnoneElement (elem)
{
  elem.style.display= 'none';
}
function dispblockElement (elem)
{
  elem.style.display= 'block';
}
function initialize ()
{
  persistent= getById ('$field_persistent');
  code= getById ('$field_code');
  codebox= getById ('codebox');
  buttonshowcode= getById ('buttonshowcode');
  buttonhidecode= getById ('buttonhidecode');
  buttonclear= getById ('buttonclear');
  formcode= getById ('formcode');
  hiddencode= getById ('hiddencode');
  varname= getById ('$field_varname');
  vartype= getById ('$field_vartype');
  varvalue= getById ('$field_varvalue');
  blockname= getById ('$field_blockname');
}
function getXmlHttpRequestObject ()
{
  if (window.XMLHttpRequest)
  {
    return new XMLHttpRequest ();
  }
  else if (window.ActiveXObject)
  {
    return new ActiveXObject ('Microsoft.XMLHTTP');
  }
  else
  {
    alert ('Oh, my godness!');
  }
}
function clear_response ()
{
  codebox.innerHTML= '';
  hideElement (buttonclear);
}
var request= getXmlHttpRequestObject ();
function initRequest ()
{
  request.open ('POST', document.location);
  request.setRequestHeader ('Content-Type',
  	'application/x-www-form-urlencoded');
}
function handleCode ()
{
  if (request.readyState == 4)
  {
    codebox.innerHTML= request.responseText;
    visualizeElement (buttonclear);
  }
}
function sendcode ()
{
  codebox.innerHTML= 'Espere...';
  initRequest ();
  var param= '$field_cmd=$cmd_send&$field_persistent=' +
    encodeURIComponent (persistent.checked) +
    '&$field_code=' +
    encodeURIComponent (code.value);
  request.onreadystatechange= handleCode;
  request.send (param);
}
function handlesetvar ()
{
  if (request.readyState == 4)
  {
  }
}
function setvar ()
{
  initRequest ();
  var param= '$field_cmd=$cmd_setvar&$field_varname=' +
    encodeURIComponent (varname.value) +
    '&$field_vartype=' +
    encodeURIComponent (vartype.value) +
    '&$field_varvalue=' +
    encodeURIComponent (varvalue.value);
  request.onreadystatechange= handlesetvar;
  request.send (param);
}
function handlegetblock ()
{
  if (request.readyState == 4)
  {
    code.value= request.responseText;
  }
}
function getblock ()
{
  initRequest ();
  var param= '$field_cmd=$cmd_getblock&$field_blockname=' +
  	encodeURIComponent (blockname.value);
  request.onreadystatechange= handlegetblock;
  request.send (param);
}
function hidecode ()
{
    visualizeElement (buttonshowcode);
    hideElement (buttonhidecode);
    dispnoneElement (formcode);
    dispblockElement (hiddencode);
}
function showcode ()
{
    hideElement (buttonshowcode);
    visualizeElement (buttonhidecode);
    dispblockElement (formcode);
    dispnoneElement (hiddencode);
}
function handleExit ()
{
  if (request.readyState == 4)
  {
    getById ('status').innerHTML= ' has been closed.';
  }
}
function exit ()
{
  getById ('status').innerHTML= ' is closing...';
  getById ('mainblock').innerHTML= '';

  request.open ('GET', '$location_exit');
  request.setRequestHeader ('Content-Type', 'text/plain');
  request.onreadystatechange= handleExit;
  request.send ();
}
END
;
}

sub html_head
{
    return <<END
<http>
<head>
<meta http-equiv='Content-Script-Type' content='text/javascript' />
<link rel='stylesheet' type='text/css' href='$location_css' />
<title>$title</title>
<script type='text/javascript' src='$location_script'></script>
</head>
END
    ;
}

sub html_header
{
    return html_head () . <<END2
<body onload='initialize ();'>
<h1 id='doctitle'>$title<span id='status'></span></h1>
<div id='mainblock'>
<div>
  <button type='button' onclick='exit ()'>exit</button>
  <button type='button' id='buttonclear' onclick='clear_response ();' style='visibility: hidden;'>clear results</button>
</div>
END2
;
}

sub html_end
{
    return <<END
</div>
</body>
</http>
END
;
}

sub form
{
    return <<END
<form style='position: relative'>
  <button id='buttonshowcode' type='button' onclick='showcode ()' style='visibility:hidden;'>show code</button>
  <button id='buttonhidecode' type='button' onclick='hidecode ()' style='position: absolute; left: 0px;'>hide code</button>
</form>
<p>
<form id='formvar' action='javascript:setvar ();' method='post' enctype='application/x-www-form-urlencoded'>
  <label for='$field_varname'>Var name:</label>
  <input type='text' id='$field_varname' name='$field_varname' />
  <select id='$field_vartype' name='$field_vartype'>
  <option selected value='scalar'>scalar</option>
  <option value='array'>array</option>
  <option value='hash'>hash</option>
  </select>
  <label for='$field_varvalue'>Value:</label>
  <input type='text' id='$field_varvalue' name='$field_varvalue' />
  <button type='submit' name='$field_cmd' value='$cmd_setvar'>$cmd_setvar</button>
</form>
<form action='javascript:sendcode ();' method='post' enctype='application/x-www-form-urlencoded'>
  <div id='formcode'>
  <label for='$field_code'>
  Write perl code here:
  </label>
  <br />
  <textarea id='code' rows='20' cols='80' name='$field_code'></textarea>
  </div>
  <div id='hiddencode' style='display:none;'>
  (code is hidden)
  </div>
  <label for='$field_persistent'>Persistent:</label>
  <input type='checkbox' id='$field_persistent' name='$field_persistent' />
  <button type='submit' name='$field_cmd' value='$cmd_send'>$cmd_send</button>
</form>
</p>
<div id='codebox'></div>
END
;
}

#*********************************************************************
#        Redirect standard output to text insertion.
#*********************************************************************

{
    package RedirectOutput;

    sub TIEHANDLE
    {
        my $class= shift;
        my $self= {};
        bless $self, $class;
    }
    sub PRINT
    {
        my $self= shift;
        #$self->{'text'}.= join ('', @_);
	foreach my $i (@_)
	{
          $self->{'text'}.= $i if defined $i;
	}
	return 1;
    }
    sub PRINTF
    {
        my $self= shift;
        my $fmt= shift;
        $self->{'text'}.= (sprintf $fmt, @_);
	return 1;
    }
    sub get
    {
        my $self= shift;
        return $self->{'text'};
    }
}

#*********************************************************************

{
  package runner;

  sub helloworld
  {
      print "Hello, world\n";
  }

#*********************************************************************
# evaluate a perl expression redirecting all output to a string.
# Return value: the output sring, or the value returned by
# eval if none.
#*********************************************************************

sub inner_eval
{
    my $expression= shift;

    my $out= tie ( *OUTPUT, 'RedirectOutput') or die "Failed!\n";
    open (OLDSTDERR, ">&STDERR");
    open (STDERR, ">&OUTPUT");
    select OUTPUT;

    my $retval;
    {
        local $SIG{'__WARN__'}=
            sub { print 'WARNING: ', @_; };
        local $SIG{'__DIE__'}=
            sub { print 'ERROR: ', @_; };
        $retval= eval $expression;
	warn $@ if $@;
    }

    open (STDERR, ">&OLDSTDERR");
    close OLDSTDERR;
    select STDOUT;

    my $output= $out->get;
    undef $out;
    untie *OUTPUT;

    my $result= '';
    $result.= "<p>Return value:\n";
    if (defined $retval)
    {
        $result.= "</p>\n<pre>\n";
        if (length ($retval) > 0)
        {
            $result.= HTML::Entities::encode ($retval);
        }
        $result.= "\n</pre>\n";
    }
    else
    {
        $result.= " (undef)</p>\n";
    }
    if (defined $output)
    {
        $result.= "<p>Output:</p>\n<textarea rows='40' cols='80' readonly='yes'>";
        if (length ($output) > 0)
        {
            $result.= HTML::Entities::encode ($output);
        }
        $result.= "</textarea>\n";
    }

    return $result;
}

} # package runner

#***********************************************************************
#                  CgiSimple
#           A mini CGI or something
#***********************************************************************

{
    package CgiSimple;

    sub new
    {
        my ($class, $cod)= @_;

        my $self= {};
        bless $self, $class;

        foreach my $i (split (/&/, $cod) )
        {
            my ($name, $value)= split (/=/, $i, 2);
            $self->{$name}= $value;
        }

        return $self;
    }

    sub param
    {
        my $self= shift;
        my $name= shift;

        return $self->{$name};
    }

}

#***********************************************************************
#                  Process requests
#***********************************************************************

{
  package Request;

  sub new
  {
    my $class= shift;
    my $connect= shift;
    my $progname= shift;

    my $request= $connect->get_request;

    print STDERR join ("\n", $request->header_field_names () ) if $debug;
    print STDERR "\n", $request->header ('Host') if $debug;

    my $self= {};
    $self->{'connect'}= $connect;
    $self->{'request'}= $request;
    $self->{'progname'}= $progname;
    bless $self, $class;
    return $self;
  }
  sub header
  {
    my ($self, $field)= @_;
    return $self->{request}->header ($field);
  }
  sub host
  {
    my $self= shift;
    #return $self->{'request'}->header ('Host');;
    return $self->header ('Host');
  }
  sub uri
  {
    my $self= shift;
    return $self->{'request'}->uri;
  }
  sub url
  {
    my $self= shift;
    return $self->{'request'}->url;
  }
  sub path
  {
    my $self= shift;
    return $self->{'request'}->url->path;
  }
  sub progname
  {
    my $self= shift;
    return $self->{'progname'};
  }
  sub method
  {
    my $self= shift;
    return $self->{'request'}->method;
  }
  sub content
  {
    my $self= shift;
    return $self->{'request'}->content;
  }
  sub send_response
  {
    my $self= shift;
    return $self->{'connect'}->send_response (@_);
  }
  sub send_error
  {
    my $self= shift;
    return $self->{'connect'}->send_error (@_);
  }
  sub notfound
  {
    my $self= shift;
    $self->send_error (::RC_NOT_FOUND);
  }
  sub forbidden
  {
    my $self= shift;
    $self->send_error (::RC_FORBIDDEN, 'Acces denied!');
  }
}

sub process_get_base
{
    my $request= shift;
    my $refvalues= shift;

    my $content= html_header;

    #my %aux= $refvalues;
    if (%$refvalues)
    {
      $content.= "<div>\n<form>\n";
      $content.= "<label for='$field_blockname'>Blocks:</label>\n";
      $content.= "<select id='$field_blockname' name='$field_blockname'>\n";
      foreach my $k (keys (%{$refvalues} ) )
      {
        $content.= "<option value='$k'>$k</option>\n";
      }
      $content.= "</select>\n";
      $content.= "<button type='button' onclick='getblock ();'  name='$field_cmd' value='$cmd_getblock'>$cmd_getblock</button>\n";
      $content.= "</form>\n</div>\n";
    }

    $content.= form ($request->url);

    $content.= html_end;

    my $r= initialize_response;
    $r->content ($content);
    $request->send_response ($r);
}

sub process_get_exit
{
    my $request= shift;

    my $r= HTTP::Response->new (RC_OK);
    $r->header (Content_Type => 'text/plain');
    $r->content ('');
    $request->send_response ($r);

    print STDERR "Close message send, exiting...\n" if $debug;
 
    exit 0;
}

sub process_get_icon
{
  my $request= shift;

  $request->notfound ();
}

sub process_get_script
{
    my $request= shift;

    my $r= HTTP::Response->new (RC_OK);
    $r->header (Content_Type => 'text/javascript');

    $r->content (scriptfile () );
    $request->send_response ($r);
}

sub process_get_css
{
    my $request= shift;

    my $r= HTTP::Response->new (RC_OK);
    $r->header (Content_Type => 'text/css');

    $r->content (cssfile () );
    $request->send_response ($r);
}

my %get_table= (
  $location_icon => \&process_get_icon,
  $location_script => \&process_get_script,
  $location_css => \&process_get_css,
  $location_exit => \&process_get_exit,
  $location_base => \&process_get_base
);

sub process_get
{
    my $request= shift;
    my $refvalues= shift;

    my $path= $request->path;
    print STDERR "$path\n" if $debug;

    my $func= $get_table {$path};
    if (defined $func)
    {
      $func->($request, $refvalues);
    }
    else
    {
        $request->forbidden ();
    }
}

sub process_setvar
{
    my $request= shift;
    my $cgi= shift;

    my $varname= uri_unescape ($cgi->param ($field_varname) );
    my $vartype= uri_unescape ($cgi->param ($field_vartype) );
    my $varvalue= uri_unescape ($cgi->param ($field_varvalue) );

    print STDERR "${varname} [${vartype}]- ${varvalue}\n" if $debug;

    no strict;
    if ($vartype eq 'scalar')
    {
      *{"runner\::$varname"}= \$varvalue;
    }
    elsif ($vartype eq 'array')
    {
      my @vararray= eval $varvalue;
      *{"runner\::$varname"}= \@vararray;
    }
    elsif ($vartype eq 'hash')
    {
      my %varhash= eval $varvalue;
      *{"runner\::$varname"}= \%varhash;
    }
}

sub process_post_getblock
{
    my $request= shift;
    my $cgi= shift;
    my $refvalues= shift;

    my $blockname= $cgi->param ($field_blockname);

    print STDERR "block: $blockname\n" if $debug;

    my $block= ${$refvalues}{$blockname};

    # my $result.= HTML::Entities::encode ($block);
    my $result.= $block;

    my $r= HTTP::Response->new (RC_OK);
    $r->header (Content_Type => 'text/plain');
    $r->content ($result);
    $request->send_response ($r);
}

sub process_post_send
{
    my $request= shift;
    my $cgi= shift;

    my $persistent= $cgi->param ($field_persistent);
    if ($persistent ne 'true')
    {
      if (fork () )
      {
          return;
      }
    }

    my $cod= $cgi->param ($field_code);
    $cod =~ s/\+/ /g if $cod;
    $cod= uri_unescape ($cod);

    my $content= runner::inner_eval ($cod);

    my $r= HTTP::Response->new (RC_OK);
    $r->header (Content_Type => 'text/plain');
    $r->content ($content);
    $request->send_response ($r);

    if ($persistent ne 'true')
    {
      exit 0;
    }
}

my %post_table= (
  $cmd_setvar => \&process_setvar,
  $cmd_getblock => \&process_post_getblock,
  $cmd_send => \&process_post_send
);

sub process_post_code
{
    my $request= shift;
    my $refvalues= shift;


    my $cgi= new CgiSimple ($request->content);
    my $cmd= $cgi->param ($field_cmd);

    print STDERR "$cmd\n" if $debug;

    my $func= $post_table {$cmd};
    if (defined $func)
    {
      $func->($request, $cgi, $refvalues);
    }
    else
    {
        $request->forbidden ();
    }
}

sub process_post
{
    my $request= shift;
    my $refvalues= shift;

    my $path= $request->path;
    print STDERR "$path\n" if $debug;
    if ($path eq "/")
    {
      process_post_code ($request, $refvalues);
    }
    else
    {
      $request->forbidden ();
    }
}

sub auth_failed
{
  my $request= shift;
  my $r= HTTP::Response->new (RC_UNAUTHORIZED);
  $r->header (
    Content_Type => 'text/plain',
    'WWW-Authenticate' => 'Basic realm="sperlderman"'
  );
  $r->content ("Authentication required\n");
  $request->send_response ($r);
}

sub authorized
{
  my $request= shift;

  if (defined $user)
  {
    my $aux= $request->header ('Authorization');
    if (! defined $aux)
    {
      return 0;
    }
    else
    {
      if (substr ($aux, 0, 6) ne 'Basic ')
      {
        return 0;
      }
      else
      {
        print STDERR "$aux\n" if $debug;
        $aux= decode_base64 (substr ($aux, 6) );
        print STDERR "$aux\n" if $debug;
        my ($u, $p)= split (/:/, $aux, 2);
        print STDERR "$u-$p-\n" if $debug;
        if ( ($u ne $user) or ($p ne $password) )
        {
          return 0;
        }
        else
        {
          return 1;
        }
      }
    }
  }
  else
  {
    return 1;
  }
}

sub process_request
{
    my $connect= shift;
    my $selfname= shift;
    my $refvalues= shift;

    #my $request= $connect->get_request;
    my $request= new Request ($connect, $selfname);

    if (! defined $request)
    {
      $connect->send_error (RC_FORBIDDEN, 'Acces denied!');
      return;
    }

    if (! authorized ($request) )
    {
      auth_failed ($request);
    }
    else
    {
      my $method= $request->method;
      if ($method eq 'GET')
      {
          process_get ($request, $refvalues);
      }
      elsif ($method eq 'POST')
      {
          process_post ($request, $refvalues);
      }
      else
      {
          $connect->send_error (RC_METHOD_NOT_ALLOWED);
      }
    }
}

#***********************************************************************
#               Server loop
#***********************************************************************

sub run_server
{
    my $server= shift;
    my $selfname= shift;
    my %values= @_;

    while (my $connect = $server->accept)
    {
        process_request ($connect, $selfname, \%values);
        $connect->close;
        undef($connect);
    }
}

#***********************************************************************
#              Start
#***********************************************************************

sub load_file
{
  my $filename= shift;

  my %values;
  print STDERR "Loading '$filename'...\n" if $debug;
  open FILE, "<$filename" or die "Can't open $filename";
  while (<FILE>)
  {
    chomp;
    my $name= $_;
    print STDERR ":$name\n" if $debug;
    my $value= '';
    my $line;
    LINE: while ($line= <FILE>)
    {
      last LINE if $line eq "\\$name\n";
      $value.= $line;
    }
    print STDERR "> $value" if $debug;
    $values {$name}= $value;
  }
  print STDERR "End of '$filename'...\n" if $debug;
  close FILE;

  if (defined $values {'~AUTOEXEC'} )
  {
    runner::inner_eval ($values {'~AUTOEXEC'} );
  }

  return %values;
}

sub load_auth
{
  my $filename= shift;
  open FILE, "<$filename" or die "Can't open auth file $filename";
  my $user= <FILE>;
  chomp $user;
  my $password= <FILE>;
  chomp $password;
  close FILE;
  return ($user, $password);
}

# Options

my $authfile;
my $browser= 'firefox';
my $filename;
my $host= 'localhost';
my $port= 0;
my $serveronly= 0;

GetOptions (
  'auth=s' => \$authfile,
  'browser=s' => \$browser,
  'debug' => \$debug,
  'file=s' => \$filename,
  'host=s' => \$host,
  'port=i' => \$port,
  'serveronly' => \$serveronly
);

my $selfname= $0;

my %values;
%values= load_file ($filename) if $filename;

($user, $password)= load_auth ($authfile) if $authfile;

# Create server

my %daemonopts= (
    ReuseAddr => SO_REUSEADDR,
    LocalPort => $port
);

$daemonopts {'LocalAddr'}= $host if $host;

my $server= new HTTP::Daemon (%daemonopts) || die;

print STDERR "Using port: " . $server->sockport . "\n";
print STDERR "URL:", $server->url, "\n";

# To avoid zombi childs.
$SIG {CHLD}= 'IGNORE';

if (fork)
{
    # Run the HTTP server in parent process
    run_server ($server, $selfname, %values);
}
else
{
    # Launch the web browser in child process
    if (! $serveronly)
    {
      my $hostname= $host;
      $hostname= 'localhost' unless $hostname;
      exec ($browser . ' http://' . $hostname . ':' . $server->sockport);
    }
}

#***********************************************************************
# End of sperlderman.pl