#!/usr/bin/perl

# Copyright (C) 2006 John J. Chew, III <jjchew@math.utoronto.ca>
# All Rights Reserved

package HTTP::Server;

use strict;
use warnings;

use Fcntl qw(:seek);
use IO::Socket;
# use UNIVERSAL qw(isa);
use HTTP::Message;

our $VERSION = '1.000';

=pod

=head1 NAME

HTTP::Server - HTTP Server Class

=head1 SYNOPSIS

  my $server = new HTTP::Server(
    port => 7777,
    content => 
      sub { my $message = shift;
        my $url = $message->URL(); # as per our HTTP::Message
	return new HTTP::Message(
	  'status-code' => 200,
	  'body' => "You asked for: $url"
	  );
	},
    ) or die;
  $server->Start() or die;
  while ($server->Run()) {}
  $server->Stop();
  
=head1 ABSTRACT

This Perl module implements a minimal HTTP server.

=head1 DESCRIPTION

=over 4

=cut

sub new ($@);
sub AcceptConnection ($);
sub CheckTimeouts ($);
sub CloseClient ($$);
sub CloseStaleClient ($$);
sub FillClient ($$);
sub FlushClient ($$);
sub ProcessRequest ($$);
sub ReadClientLine ($$);
sub Run ($);
sub SetCloseOnFlush ($$$);
sub Start ($);
sub StaticContent ($$);
sub Stop ($);
sub WriteClient ($$$);
sub WriteResponse ($$$);

=item $server = new HTTP::Server({$key1 => $value1, ...});

Create a new HTTP::Server object.  
All keys are optional.

C<port>: port to listen on for new connections, defaults to 7777.

C<content>: reference to sub that generates content, defaults to generating
an error message complaining of the lack of such a sub.

=cut

sub new ($@) {
  my $proto = shift;
  my $class = ref($proto) || $proto;
# my $this = $class->SUPER::new();
  my $this = {
    'clients' => {}, # see below
      # clients{$fileno} => {
      #   close_on_flush => $flag, # see SetCloseOnFlush
      #   handle => $handle,
      #   ibuf => $input_handle, # in-memory,
      #   obuf => $output_buffer,
      #   time => $time_created,
      #   }
    'content' => sub { { 'code' => 500, 'body' => '<html><head><title>No content code</title></head><body><h1>Server Error</h1><p>No content code has been configured.</p><hr><p>This message was generated by John Chew\'s HTTP::Server Perl module.</p></body></html>' } },
    'log_handle' => *STDERR,
    'port' => 7777,
    'request' => {}, # hash mapping client fn to HTTP::Message
    'select_mask' => {
      'input' => '',
      'output' => '',
      'error' => '',
      },
    'server_fn' => undef,
    'server_handle' => undef,
    'version' => "HTTP::Server/poslfit-$VERSION",
    };
  my %param = @_;
  # required parameters
  for my $key (qw(content port version)) {
    if (exists $param{$key}) { $this->{$key} = $param{$key}; }
    elsif (!exists $this->{$key}) {
      die "Missing required parameter ($key).";
      }
    }
  # optional parameters
  for my $key (qw(log_handle event_queue)) {
    if (exists $param{$key}) { $this->{$key} = $param{$key}; }
    }
  bless($this, $class);
  return $this;
  }

=item $server->AcceptConnection();

Called internally when an incoming connection has been detected.

=cut

sub AcceptConnection ($) {
  my $this = shift;
  my $ch = $this->{'server_handle'}->accept();
  $ch->autoflush(1);
  my $cfn = $ch->fileno;
  my $ifh;
  my $buffer;
  unless (open $ifh, "+<", \$buffer) {
    $this->Die("Cannot allocate input file handle: $!");
    return undef;
    }
# else { warn "opened new in-memory file handle\n"; }
  $this->{'clients'}{$cfn} = {
    'handle' => $ch,
    'ibuf' => $ifh,
    'obuf' => '',
    'time' => time,
    };
  vec($this->{'select_mask'}{'input'}, $cfn, 1) = 1;
  print { $this->{'log_handle'} }  "conn $cfn " . $ch->peerhost() . "\n";
  $ch->blocking(0);
  $ch->autoflush(1);
  # an older version set SO_KEEPALIVE, we don't bother
  }

=item $server->CheckTimeouts();

Called internally to clean up connections that get left open.

=cut

sub CheckTimeouts ($) {
  my $this = shift;
  my $best_after = time - 60;
  while (my ($cfn, $cdatap) = each %{$this->{'clients'}}) {
    if ($cdatap->{'time'} < $best_after) {
      warn "$cdatap->{'time'} < $best_after";
      $this->CloseStaleClient($cfn);
      }
    }
  }

=item $ip_address = ClientHost($client_data);

May be used externally to find a client's IP address.

=cut

sub ClientHost ($) {
  my $cdatap = shift;
  return $cdatap->{'handle'}->peerhost();
  }

=item $server->CloseClient($fn);

Called internally to close a connection.

=cut

sub CloseClient ($$) {
  my $this = shift;
  my $cfn = shift;
  my $cdatap = $this->{'clients'}{$cfn};
  return unless defined $cdatap;
  print { $this->{'log_handle'} }  "disc $cfn\n";
  $cdatap->{'handle'}->close();
  vec($this->{'select_mask'}{'input'}, $cfn, 1) = 0;
  vec($this->{'select_mask'}{'output'}, $cfn, 1) = 0;
  delete $this->{'clients'}{$cfn};
  delete $this->{'request'}{$cfn};
  }

=item $server->CloseStaleClient($fn);

Called internally to close a stale connection.

=cut

sub CloseStaleClient ($$) {
  my $this = shift;
  my $cfn = shift;
  my $cdatap = $this->{'clients'}{$cfn};
  return unless defined $cdatap;
  $cdatap->{'handle'}->print("500 Timeout\015\012\015\012");
  $this->CloseClient($cfn);
  }

=item $server->FillClient($fn);

Called internally to fill a client's input buffer.

=cut

sub FillClient ($$) {
  my $this = shift;
  my $cfn = shift;
  my $cdatap = $this->{'clients'}{$cfn};
  return undef unless defined $cdatap;
  my $buffer = '';
  my $count = $cdatap->{'handle'}->sysread($buffer, 16384);
  if (!defined $count) {
    print { $this->{'log_handle'} }  "oops $cfn sysread failed: $!\n";
    return undef;
    }
  elsif ($count) {
    if ($this->{'request'}{$cfn}) {
      print { $this->{'log_handle'} }  "Data received after completed request:\n$buffer\n";
      }
    else {
      my $ifh = $cdatap->{'ibuf'};
      my $ptr = tell($ifh);
      seek($ifh, 0, SEEK_END);
      print $ifh $buffer;
#     seek($ifh, 0, SEEK_SET); print "<BUF>\n", <$ifh>, "</BUF>\n";
      seek($ifh, $ptr, SEEK_SET);
#     warn "seek $cfn $ptr\n";
#     print "<RCV>\n$buffer\n</RCV>\n";
      my $request = new HTTP::Message('handle' => $ifh);
      if (!defined $request) {
	print { $this->{'log_handle'} }  "Can't create request object?!\n";
	}
      elsif (my $error = $request->Error()) {
	print { $this->{'log_handle'} }  "part $cfn can't parse request (yet): $error\n";
	if ($error =~ /^Incomplete/) {
	  seek($ifh, $ptr, SEEK_SET); # try again later
	  }
	}
      else {
#	warn "pars $cfn\n";
	$this->{'request'}{$cfn} = $request;
	}
      }
    return $count;
    }
  }

=item $server->FlushClient($fn);

Called internally to flush output to a client.

=cut

sub FlushClient ($$) {
  my $this = shift;
  my $cfn = shift;
  my $cdatap = $this->{'clients'}{$cfn};
  return unless defined $cdatap;
  my $count = $cdatap->{'handle'}->syswrite($cdatap->{'obuf'});
  if (defined $count) {
    substr($cdatap->{'obuf'}, 0, $count) = '';
    my $count = length($cdatap->{'obuf'});
    if (0 == $count) {
      vec($this->{'select_mask'}{'output'}, $cfn, 1) = 0;
      if ($cdatap->{'close_on_flush'}) {
	$this->CloseClient($cfn);
	}
      }
    return $count;
    }
  else {
    print { $this->{'log_handle'} }  "oops $cfn syswrite failed: $!\n";
    return undef;
    }
  }

=item $server->ProcessRequest($cfn);

Process a request waiting in the input buffer for client $cfn.

=cut

sub ProcessRequest ($$) {
  my $this = shift;
  my $cfn = shift;
  my $cdatap = $this->{'clients'}{$cfn};
  return unless defined $cdatap;
  my $request = $this->{'request'}{$cfn};
  delete $this->{'request'}{$cfn};
  $cdatap->{'time'} = time;
  my $http_version = $request->HTTPVersion();
  my $host = $request->Header('host') || '';
  my $url = $request->URL();
  print { $this->{'log_handle'} }  "proc $cfn $host $url $http_version\n";
  my $sub = $this->{'content'};
  my $response;
  eval { $response = &$sub($request, $cdatap); };
  if ($@) {
    $response = new HTTP::Message();
    $response->StatusCode(500);
    $response->Body("<h1>Internal Server Error</h1><p>Content handler aborted: $@</p>");
    warn "500\t$url\t$@\n";
    }
  elsif (!UNIVERSAL::isa($response, 'HTTP::Message')) {
    $response = new HTTP::Message();
    $response->StatusCode(500);
    $response->Body("Content handler did not return HTTP::Message");
#   warn "not a message\n";
    }
  # supply default values for mandatory data
  elsif (!defined $response->StatusCode()) { 
    $response->StatusCode(500); 
#   warn "no code\n";
    }
  if (!defined $response->Body()) { $response->Body(''); }
  if (!defined $response->Header('content-type')) { 
#   warn "setting to text/html: ".join(',', do { my $x = substr($response->Body(), 0, 100); $x =~ s/[\n\r]/\\n/g; $x }. %{$response->{'headers'}});
    $response->Header('content-type', 'text/html'); 
    }
  # redirections require a Location:
  if ($response->StatusCode() =~ /^3/ && 
    !defined $response->Header('location')) {
#   warn "no location\n";
    $response->StatusCode(500);
    $response->Body("Content handler did not specify Location:.");
    }
  if ($http_version !~ /^(?:0\.9|1\.0|1\.1)$/) { $http_version = '1.1'; }
  # HTTP/1.1 requires Host:
  if ($http_version eq '1.1' && !defined $request->Header('Host')) {
    $response->StatusCode(400);
    $response->Body("HTTP 1.1 request did not include Host:");
    }
  $response->HTTPVersion($http_version);
  $this->WriteResponse($cfn, $response);
  my $connection = $request->Header('Connection') || '';
  if ($connection =~ /\bclose\b/ || $http_version ne '1.1') 
    { $this->SetCloseOnFlush($cfn, 1); }
  }

=item return Redirect($url);

Generates appropriate data for a content handler to respond in 
redirecting the browser to $url.

=cut

sub Redirect ($) {
  my $url = shift;
  return new HTTP::Message(
    'status-code' => 301,
    'headers' => { 'location' => $url },
  );
  }

=item $line = $server->ReadClientLine($cfn);

Return a line of text read from the specified client.
Newlines are stripped.

=cut

sub ReadClientLine ($$) {
  my $this = shift;
  my $cfn = shift;
  my $cdatap = $this->{'clients'}{$cfn};
  return undef unless defined $cdatap;
  my $ifh = $cdatap->{'ibuf'};
  local($/) = "\012";
# print "<CL>\n", <$ifh>, "</CL>\n";
  my $line = scalar(<$ifh>);
  $line =~ s/\015?\012$//;
  return $line;
  }

=item while ($server->Run()) { }

Checks to see if an HTTP request has been received.
If one has, it is processed.

=cut

sub Run ($) {
  my $this = shift;
  my $nports;
  my ($inp, $out, $err);

# print "listening ($this->{'exiting'})\n";
  my $timeout = 1;
  my $busy = 0;
  my $was_exiting = $this->{'exiting'};
  my $event_queue = $this->{'event_queue'};
  $inp = $this->{'select_mask'}{'input'};
  $inp = '' if $this->{'exiting'};
  $nports = select(
    $inp,
    ($out = $this->{'select_mask'}{'output'}),
    ($err = $this->{'select_mask'}{'error'}),
    $timeout,
    );
# printf { $this->{'log_handle'} }  "nports=$nports inp=%s out=%s err=%s\n", unpack('b*', $inp), unpack('b*', $out), unpack('b*', $err);
  if ($nports < 0) { 
    print { $this->{'log_handle'} } "select() failed: $!\n"; 
    return 0; 
    }
  if (my $event = $event_queue && $event_queue->dequeue_nb()) {
    if ($event eq 'shutdown') {
      print "Shutdown event received by server.\n";
      return 0;
      }
    else {
      die "Unknown event: $event";
      }
    }
  # timeout
  if ($nports == 0) {
#   print { $this->{'log_handle'} } "timeout\n";
    return (!$was_exiting) || (!$this->{'exiting'});
    }
  # check for new connections
  if (vec($inp, $this->{'server_fn'}, 1)) {
#   warn "accepting connection.\n";
    $this->AcceptConnection();
    vec($inp, $this->{'server_fn'}, 1) = 0;
    $nports--;
    }
  # check for activity on old connections
  if ($nports > 0) { #   warn "looking for I/O.\n";
    for my $cfn (keys %{$this->{'clients'}}) {
#     warn "checking port $cfn.\n";
      if (vec($out, $cfn, 1)) {
	$busy++;
	vec($out, $cfn, 1) = 0;
	if (0 == $this->FlushClient($cfn)) {
#	  $this->CloseClient($cfn);
	  }
	last unless --$nports;
	}
      if (vec($inp, $cfn, 1)) {
	vec($inp, $cfn, 1) = 0;
        if (0 == ($this->FillClient($cfn)||0)) {
	  $this->CloseClient($cfn);
	  }
	last unless --$nports;
        }
      }
    print { $this->{'log_handle'} }  "unknown activity" unless $nports <= 0;
    }
  # check for newly available requests to process
  for my $cfn (keys %{$this->{'request'}}) {
    $this->ProcessRequest($cfn);
    }
  # check for expired old connections
  $this->CheckTimeouts();
# warn "$busy $was_exiting $this->{'exiting'}";
  return $busy || (!$was_exiting) || (!$this->{'exiting'});
  }

=item $server->SetCloseOnFlush($cfn, $boolean);

Specify whether or not a client socket should be closed when its
output buffer is fully flushed.

=cut

sub SetCloseOnFlush ($$$) {
  my $this = shift;
  my $cfn = shift;
  my $cof = shift;
  my $cdatap = $this->{'clients'}{$cfn};
  return unless defined $cdatap;
  $cdatap->{'close_on_flush'} = $cof;
  }

=item $server->SetContentHandler($sub);

Sets the content handler for the server.

=cut

sub SetContentHandler ($$) {
  my $this = shift;
  my $sub = shift;
  $this->{'content'} = $sub;
  }

=item $server->Start() or die;

Prepares the server to accept new connections, returns boolean indicating success.

=cut

sub Start ($) {
  my $this = shift;
  my $sh = $this->{'server_handle'} = IO::Socket::INET->new(
    Proto => 'tcp',
    Listen => SOMAXCONN,
    LocalPort => $this->{'port'},
    Reuse => 1,
    ) or die "Cannot set up server socket: $!";
  # some old systems hang on accept() if a connecting client drops
  # a half-open connection, so don't ever block
  $sh->blocking(0);
  # update the select(1) mask
  $this->{'server_fn'} = $sh->fileno;
  $this->{'exiting'} = 0;
  vec($this->{'select_mask'}{'input'}, $this->{'server_fn'}, 1) = 1;
  return 1;
  }

=item return StaticContent($base, $ext);

Generates appropriate data for a content handler to respond in serving
the file "$base.$ext".

=cut

sub StaticContent ($$) {
  my $base = shift;
  my $ext = shift;
  my $fn = "$base.$ext";
  my $fh;
  # TODO: should check for if-modified-since
  # TODO: what encoding is this in?
  if (!open $fh, "<", $fn) { 
    return new HTTP::Message(
      'status-code' => '404',
      'body' => "File not found: $fn"
      ); 
    }
  local($/) = undef;
  my $data = <$fh>;
  close($fh);
  my $type = {
    'css' => 'text/css',
    'gif' => 'image/gif',
    'jpeg' => 'image/jpeg',
    'jpg' => 'image/jpeg',
    'js' => 'text/javascript',
    'htm' => 'text/html',
    'html' => 'text/html',
    'ico' => 'image/x-icon',
    }->{$ext};
#   warn "$fn: $type";
  return new HTTP::Message(
    'status-code' => 200,
    'body' => $data,
    'headers' => { 'content-type' => $type },
    );
  }

=item $server->Shutdown();

Tell the server to shut down the next time it returns from Run().

=cut

sub Shutdown ($) {
  my $this = shift;
  $this->{'exiting'} = 1;
  }

=item $server->Stop();

Shuts down the server and stops it from accepting new connections.

=cut

sub Stop ($) {
  my $this = shift;
  $this->{'server_handle'}->close();
  delete $this->{'server_handle'};
  while (my ($cfn, $cdatap) = each %{$this->{'clients'}}) {
    $cdatap->{'handle'}->close();
    }
  }

=item $server->WriteClient($cfn, $s);

Writes $s to the client identified by $cfn.

=cut

sub WriteClient ($$$) {
  my $this = shift;
  my $cfn = shift;
  my $s = shift;
  my $cdatap = $this->{'clients'}{$cfn};
  return undef unless defined $cdatap;
# print "Write($cfn): $s\n";
  $cdatap->{'obuf'} .= $s;
  vec($this->{'select_mask'}{'output'}, $cfn, 1) = 1;
  }

=item $server->WriteResponse($cfn, $response);

Returns the HTTP response message $response to the client identified by $cfn.

=cut

sub WriteResponse ($$$) {
  my $this = shift;
  my $cfn = shift;
  my $response = shift;
  $response->Header('server', $this->{'version'});
  $response->Date(time) unless $response->Header('date');
  $this->WriteClient($cfn, $response->ToString());
  }

=back

=cut

1;
