#! /usr/local/bin/perl -w

# (Set the above path as appropriate to the host machine)

# Version:       1.00
# Last modified: 07 April 2003

# CGI interface script for the 2003 Loebner Prize Contest

# This script is provided as freeware and comes with absolutely no guarantees
# whatsoever. If you use it in whole or in part you do so entirely at your
# own risk.

# This script assumes that a single conversation is taking place at any one
# time. Therefore there is no file locking, session control, etc.
# The script has been developed under Linux but should easily port to other
# Unix operating systems. It should also be portable to Windows.
# All communication with the bot itself (here, demobot.pl) is via files.
# This is a lot easier than using command line arguments, pipes, sockets, or
# whatever, and should port easily to Windows.

#------------------------------------------------------------------------------

require 5.004;  # need Perl v5.004 or better
use strict;     # helps catch any bugs

#------------------------------------------------------------------------------

# Global constants that will need to be modified:

# The logging directory (must have rwxrwxrwx permissions):
$main::LOG_DIR = "/home/myhome/botfiles";

# The location of the HTML page template:
$main::TEMPLATE = "/home/myhome/botfiles/template.html";

# The URL of this script:
$main::SCRIPT_URL = "http://www.maybot.com/cgi-bin/loebner/chat.cgi";

# A bot identification string:
$main::BOT_ID = "DemoBot";

# The command line call for the bot program itself:
$main::BOT_PROGRAM_CALL = "/home/myhome/botfiles/demobot.pl";

# The files for communicating with the bot program:
$main::JUDGE_INPUT_FILE  = "/home/myhome/botfiles/judge_input.txt";
$main::RESPONSE_FILE     = "/home/myhome/botfiles/response.txt";
$main::STATE_FILE        = "/home/myhome/botfiles/state.txt";
$main::JUDGE_NUMBER_FILE = "/home/myhome/botfiles/judge_number.txt";
$main::SCRIPT_MODE_FILE  = "/home/myhome/botfilesscript_mode.txt";

#------------------------------------------------------------------------------

{
  # The "main" program routine, which should be fairly easy to understand.
  # All the hard work is done in subroutines.

  # Get the contents of the HTML form submitted by the browser:

  my %form = &get_html_form();

  # Work out which mode the script has been called in:
  # F: first time load
  # N: new conversation
  # C: continuing conversation

  my $script_mode = &decide_script_mode(%form);

  # Retrieve the conversation ID, or assign one to a new conversation:

  my $conv_id = &get_conv_id($script_mode, %form);

  my $judge_input = $form{"judge_input"};
  my $state = $form{"state"};
  my $judge_number = $form{"judge_number"};
  my $response;

  unless ($script_mode eq "F")
  {
    # Call the bot program:

    ($response, $state) = &run_bot_program($judge_input, $state, $judge_number,
                                           $script_mode);

    # Obligatory delay of five seconds minimum:

    my $min_delay = 5;
    my $time_elapsed = time - $^T;  # from start time of script to now

    sleep($min_delay - $time_elapsed) if $time_elapsed < $min_delay;
  }

  # Send an HTML page back to the browser:

  &send_html_page($script_mode, $conv_id, $response, $state);

  # Log the exchange:

  unless ($script_mode eq "F")
  {
    &log_exchange($conv_id, $judge_number, $judge_input, $response,
                  $script_mode);
  }

  exit;  # all done!
}

#------------------------------------------------------------------------------

sub get_html_form
{
  # Return the contents of the HTML form submitted by the browser
  # as a hash containing name-value pairs

  # (This is a very standard piece of CGI code and variants can be found in
  # numerous places. The POST method is assumed.)

  my $length = $ENV{'CONTENT_LENGTH'} || 0;
  die "CONTENT_LENGTH too long ($length)" if $length > 100_000;

  my $buffer;
  read(STDIN, $buffer, $length);    # get the input from stdin
  my @pairs = split(/&/, $buffer);  # split name-value pairs

  my %form = ();  # the hash to be returned

  foreach my $p (@pairs)
  {
    my ($name, $value) = split(/=/, $p);  # split each name-value pair

    # Change '+' back to ' ' and undo the %-encoding:

    $name  =~ tr/+/ /;
    $value =~ tr/+/ /;
    $name  =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
    $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;

    $form{$name} = $value;
  }

  return %form;
}

#------------------------------------------------------------------------------

sub decide_script_mode
{
  # Determine which mode the script was called in

  # F: first time load (script called without parameters)
  # N: new conversation ("judge_number" defined)
  # C: continuing conversation

  my %form = @_;

  if (defined $form{"conv_id"})
    { return "C"; }
  elsif (defined $form{"judge_number"})
    { return "N"; }
  else
    { return "F"; }
}

#------------------------------------------------------------------------------

sub get_conv_id()
{
  # Set the conversation ID as appropriate to the script mode

  my ($script_mode, %form) = @_;

  my $conv_id;

  if ($script_mode eq "F")
  {
    # First time page load, no ID needed:

    $conv_id = "";
  }

  elsif ($script_mode eq "N")
  {
    # New conversation; assign an ID to it,
    # e.g. "2003-10-18-14-34-05-Superbot-Judge05":

    $conv_id =   &get_time_string($^T)
               . "-"
               . $main::BOT_ID
               . "-Judge"
               . sprintf("%02d", $form{"judge_number"});
  }

  elsif ($script_mode eq "C")
  {
    # Continuing conversation, restore the previous ID:

    $conv_id = $form{"conv_id"};
  }

  else
  {
    die "Invalid script mode '$script_mode'";
  }

  return $conv_id;
}

#------------------------------------------------------------------------------

sub run_bot_program
{
  # Call the bot program itself

  # (All communication is via files for simplicity)

  my ($judge_input, $state, $judge_number, $script_mode) = @_;

  # Write the input, state, judge number and script mode to files:

  open(OUT, ">$main::JUDGE_INPUT_FILE") or die;
  print OUT $judge_input;
  close OUT;

  open(OUT, ">$main::STATE_FILE") or die;
  print OUT $state;
  close OUT;

  open(OUT, ">$main::JUDGE_NUMBER_FILE") or die;
  print OUT $judge_number;
  close OUT;

  open(OUT, ">$main::SCRIPT_MODE_FILE") or die;
  print OUT $script_mode;
  close OUT;

  # Run the bot program:

  system($main::BOT_PROGRAM_CALL);

  # Read the response and the new state from files:

  open(IN, "<$main::RESPONSE_FILE") or die;
  my $response = <IN>;
  close IN;

  open(IN, "<$main::STATE_FILE") or die;
  $state = <IN>;
  close IN;

  return ($response, $state);
}

#------------------------------------------------------------------------------

sub log_exchange
{
  # Log the conversational exchange in the specified format

  my ($conv_id, $judge_number, $judge_input, $response, $script_mode) = @_;

  # Append mode is used; if the file does not yet exist (new conversation), it
  # is created automatically:

  my $logfile = "$main::LOG_DIR/$conv_id.log";

  open(LOG, ">>$logfile") or die "Can't open $logfile";

  if ($script_mode eq "N")
  {
    # New conversation:

    print LOG "Copyright (C) 2003 Cambridge Center for Behavioral Studies. ";
    print LOG "All rights reserved.\n";
    printf(LOG "%s conversing with Judge %02d\n\n",
           $main::BOT_ID, $judge_number);

    print LOG &get_time_string(time), " PROGRAM: $response\n";
  }

  else
  {
    # Continuing conversation:

    print LOG &get_time_string($^T), " JUDGE: $judge_input\n";
    print LOG &get_time_string(time), " PROGRAM: $response\n";
  }

  close LOG;

  chmod(0666, $logfile);  # set access permissions to rw-rw-rw-
}

#------------------------------------------------------------------------------

sub send_html_page
{
  # Returns a HTML page to the browser using the template provided

  my ($script_mode, $conv_id, $response, $state) = @_;

  # Send MIME headers:

  print STDOUT "Content-type: text/html\n";
  print STDOUT "Pragma: no-cache\n\n";

  # Load the HTML template:

  my $template;
  {
    open(TPT, $main::TEMPLATE) or die;
    undef local $/;  # slurp mode: get the file in one go
    $template = <TPT>;
    close TPT;
  }

  # Substitute actual values for placeholders in the template:

  $template =~ s/%%RESPONSE%%/$response/g;
  $template =~ s/%%CONV_ID%%/$conv_id/g;
  $template =~ s/%%STATE%%/$state/g;
  $template =~ s/%%SCRIPT_URL%%/$main::SCRIPT_URL/g;

  # Send HTML page back to the browser:

  print STDOUT $template;
}

#------------------------------------------------------------------------------

sub get_time_string
{
  # Return a timestamp string in the specified format
  # E.g. 5 seconds after 2:34pm on 18 October 2003 gives "2003-10-18-14-34-05"

  # See Perl's localtime() documentation to understand what's going on here.

  my ($sec,$min,$hour,$mday,$mon,$year) = localtime(shift);

  return sprintf("%04d-%02d-%02d-%02d-%02d-%02d",
                 $year + 1900, $mon + 1, $mday, $hour, $min, $sec);
}

#------------------------------------------------------------------------------

__END__