#!/usr/local/bin/perl

# listen v.200503171012-perl
#  A standalone HTTP Wiki server.
#  Released without warranty and without restriction, except that the author(s) should
#  receive appropriate credit for any derivative products.
#
#  Doesn't use a database, isn't multithreaded, isn't documented, is written in perl.
#
#  Revision history:
#    200503122337       Created 2005.03.11-03.12 by rjmccall@gmail.com
#
#    200503132359       Incorporated patch from jcreed@andrew.cmu.edu.
#                       Added actions, cleaned up APIs, allow for a configuration file.
#
#    200503171012       Incorporated patch from jcreed.
#                       Support hosting binaries, sidebars.
#
#    200503190156       Sidebar jiggering, again based on research by jcreed.

# The configuration file is a series of key/value pairs, one per line (though
# values may be arbitrarily complex.  Here are the currently-supported commands:
#  Directory path
#   Provides the root database directory.
#  Alias alias_path true_path
#   States that the resource 'alias_path' can actually be found at 'true_path'.
#  Edit.editbox.dimensions COLS x ROWS
#   Provides explicit dimensions for the edit box.
#  Title title string here
#   Titles the wiki.
#  Edit.links
#  Fetch.links
#  List.links
#   Provide a list of the automatic links to make available on each of these pages.
#   Supportered link generators are:
#     edit   - edit the current resource
#     list   - list the contents of the directory containing the current resource
#     main   - jump to the root page
#  StyleSheet file
#   Use the given stylesheet file instead of the default inclusion.  The file must
#   be given in remote form (as in, a file that the browser could reasonably fetch).
#  LinksAtTop true|false
#  LinksAtBottom true|false
#   States whether link sections should be created at the top/bottom of the page.
# Configuration files are processed at the moment they are encountered on the command
# line; they override earlier arguments and may be themselves overriden by later
# arguments.

use Fcntl ':flock';
use Socket;
use strict;

# default configuration details

my $listen_port = 80;                   # TCP port on which to listen
my $database_directory = ".";           # root directory of the data repository
my $server_title = "listen";            # title of the server, used in the HTML title
my $main_page_link = "Main page";       # text for the link to the main page
my $list_link = "List other pages here";# text for the link to the directory list
my $edit_link = "Edit this page";       # text for the link to the editor
my $edit_box_width = undef;             # width of the edit box, in columns
my $edit_box_height = undef;            # height of the edit box, in lines (if these aren't both defined, uses a proportional scheme)
my $directory_page = "Main";            # page to display when fetching a directory
my $style_file = undef;                 # style file to reference; if not defined, directly insert $default_style
my $html_links_on_top = 0;              # display standard links on the top of the page
my $html_links_on_bottom = 1;           # display standard links on the bottom of the page
my $html_insert_page_title = 1;         # display the page title at the top of the page

my $default_style = "";                 # the default style text; initialized in init()

# content_fetch_filter: (resource -> string) option
my $content_fetch_filter = \&content_fetch_filter;

# init: unit -> unit
sub init
{
  set_handler( "get", \&handle_get );
  set_handler( "head", \&handle_get );
  set_handler( "post", \&handle_post );

  my $submit_action = create_action( "submit" );
  set_content_handler( $submit_action, \&handle_content_submit );
  set_resource_path_processor( $submit_action, \&get_true_path_to_resource );

  my $edit_action = create_action( "edit" );
  set_content_handler( $edit_action, \&handle_content_edit );
  set_link_generator_names( $edit_action, "main", "list" );
  set_resource_path_processor( $edit_action, \&get_true_path_to_resource );

  my $list_action = create_action( "list" );
  set_content_handler( $list_action, \&handle_content_list );
  set_link_generator_names( $list_action, "main", "list" );
  set_resource_path_processor( $list_action, \&get_true_path );

  my $fetch_action = create_action( "fetch" );
  set_content_handler( $fetch_action, \&handle_content_fetch );
  set_link_generator_names( $fetch_action, "edit", "main", "list" );
  set_resource_path_processor( $fetch_action, \&get_true_path_to_resource );

  set_default_action( $fetch_action );

  $default_style = << 'EOF';
  <style type="text/css">
    a {
      text-decoration: none
    }
    a.absent {
      color: #ff3300
    }
    h1.pagetitle {
      margin-left: 10em;
      font-size: 1.5em;
      font-weight: bolder
    }
    div.body {
      margin-left: 15em;
      margin-top: 1em
    }
    div.links {
      text-align: center
    }
    span.note-body {
      font-size: smaller;
      position: absolute;
      left: 2em;
      width: 13em;
      padding: 5px;
	    border-width: 1px;
	    border-style: solid;
	  }
    span.note-anchor {
      border-width: thin;
      border-style: solid;
      padding: 1px;
    }
  </style>
EOF

  my $text_html_type = create_content_type( "text/html" );
  set_content_type_editor( $text_html_type, \&entry_editor );
  set_content_type_exporter( $text_html_type, \&entry_exporter );
  set_content_type_importer( $text_html_type, \&entry_importer );

  create_binary_content_type( "text/css", "css" );
  create_binary_content_type( "image/jpeg", "jpg", "jpeg" );
  create_binary_content_type( "image/png", "png" );

  set_default_content_type( $text_html_type );
}

my $jitter_script = << 'EOF';
<script>
  function findPosX(obj)
  {
    var curleft = 0;
    if (obj.offsetParent)
    {
      while (obj.offsetParent)
      {
        curleft += obj.offsetLeft
        obj = obj.offsetParent;
      }
    }
    else if (obj.x)
      curleft += obj.x;
    return curleft;
  }

  function findPosY(obj)
  {
    var curtop = 0;
    if (obj.offsetParent)
    {
      while (obj.offsetParent)
      {
        curtop += obj.offsetTop
        obj = obj.offsetParent;
      }
    }
    else if (obj.y)
      curtop += obj.y;
    return curtop;
  }

  function sidebar_sorter( a, b ) {
    return a.y_position - b.y_position
  }

  function Sidebar( element ) {
    this.element = element;
    this.y_position = findPosY( element );
    this.height = element.offsetHeight;
  }

  function rejigger() {
    elements = document.getElementsByName("sidebar");
    var length = elements.length;
    sidebars = new Array( length );
    for (var i = 0; i < length; ++i)
      sidebars[i] = new Sidebar( elements[i] );

    sidebars.sort( sidebar_sorter );

    var min_y = 0;
    for (var i = 0; i < length; ++i) {
      var y = sidebars[i].y_position;
      if (y < min_y) y = min_y;
      sidebars[i].element.style.top = y + 'px';
      min_y = y + sidebars[i].height + 5;
    }
  }

  onResize = rejigger;
  rejigger();
</script>
EOF

# create_html_response: http_request * string -> string
#  Takes a resource path and a body and produces an HTML message
sub create_html_response
{
  my ($http_request, $body) = @_;

  my $semantics = $http_request->{request_semantics};
  my $action = $semantics->{action};
  my $resource_path = $semantics->{resource_path};

  my $style;
  if (defined $style_file)
  {
    $style = '<link rel="stylesheet" type="text/css" href="' . $style_file . '"/>';
  }
  else
  {
    $style = $default_style;
  }

  my $buffer = "<html><head><title>";
  my $links;

  $buffer .= $server_title . ': ' if $server_title;
  $buffer .= $resource_path . "</title>" . $style . "</head>";

  my $link_generators = get_link_generators( $action );
  if ($link_generators)
  {
    my $cnt = 0;
    $links .= '<div class="links">';
    foreach my $link_generator (@$link_generators)
    {
      $links .= ' | ' if $cnt++ > 0;
      $links .= $link_generator->( $resource_path );
    }
    $links .= '</div>';
  }

  $buffer .= "<body>";
  if ($html_links_on_top)
  {
    $buffer .= $links;
  }
  if ($html_insert_page_title)
  {
    $buffer .= '<h1 class="pagetitle">' . decode_urlencoding( $resource_path ) . '</h1>';
  }
  $buffer .= '<div class="body">' . $body . '</div>';
  if ($html_links_on_bottom)
  {
    $buffer .= $links;
  }
  $buffer .= "</body>" . $jitter_script . "</html>";
  return $buffer;
}

# entry_exporter: http_request * resource -> string
sub entry_exporter
{
  my ($http_request, $resource) = @_;
  my $text;
  if (defined $content_fetch_filter)
  {
    $text = $content_fetch_filter->( $resource );
  }
  else
  {
    $text = $resource->{text};
  }
  return create_html_response( $http_request, $text );
}

# entry_editor: http_request -> string
sub entry_editor
{
  my ($http_request) = @_;
  my $semantics = $http_request->{request_semantics};
  my $resource_path = $semantics->{resource_path};
  my $resource = read_semantic_resource( $resource_path );

  if (not defined $resource)
  {
    $resource = {};
    $resource->{path} = $resource_path;
    $resource->{text} = "";
  }

  my $body = '<form action="'
           . create_resource_submit_path( $resource_path )
           . '" method="post"><textarea name="text" ';
  if ($edit_box_height > 0 and $edit_box_width > 0)
  {
    $body .= 'rows="' . $edit_box_height . '" cols="' . $edit_box_width . '">'
  }
  else
  {
    $body .= 'style="width: 80%; height: 70%">';
  }
  $body .= $resource->{text} . '</textarea><br/><input type="submit" value="Submit"/></form>';
  return $body;
}

# entry_importer: http_request * string * (string ref) -> string
sub entry_importer
{
  my ($http_request, $content, $error_ref) = @_;
  my $values = parse_urlencoded_parameters( $content );
  my $text = $values->{text};
  return $text;
}

my %link_generators = ( main=>\&go_to_main_page, list=>\&list_pages_here, edit=>\&edit_this_page );

# set_link_generator_names: action * (string...) -> unit
#  Note that this function silently ignores invalid producers
sub set_link_generator_names
{
  my $action = shift;
  my @link_generators = ();
  foreach my $linkname (@_)
  {
    my $link_generator = $link_generators{ $linkname };
    if ($link_generator)
    {
      push @link_generators, $link_generator;
    }
  }
  set_link_generators( $action, \@link_generators );
}

# go_to_main_page: string -> string
sub go_to_main_page
{
  return "<a href='/'>" . $main_page_link . "</a>";
}

# list_pages_here: string -> string
sub list_pages_here
{
  my ($resource_path) = @_;
  return '<a href="'
         . create_resource_list_path( $resource_path )
         . '">' . $list_link . '</a>';
}

# edit_this_page: string -> string
sub edit_this_page
{
  my ($resource_path) = @_;
  return '<a href="'
         . create_resource_edit_path( $resource_path )
         . '">' . $edit_link . '</a>';
}

# should_list_resource: string * string -> boolean
#  (path, filename)
sub should_list_resource
{
  my ($path, $filename) = @_;
  return $filename !~ /^\./;
}

# create_local_path: string -> string
sub create_local_path
{
  my ($resource_path) = @_;
  $resource_path = local_path_encode($resource_path);
  return $database_directory . $resource_path;
}

# create_resource_list_path: string -> string
sub create_resource_list_path
{
  my ($resource_path) = @_;
  $resource_path =~ s@/[^/]*$@@;
  return $resource_path . '/list';
}

# create_resource_edit_path: string -> string
sub create_resource_edit_path
{
  my ($resource_path) = @_;
  return $resource_path . '/edit';
}

# create_resource_submit_path: string -> string
sub create_resource_submit_path
{
  my ($resource_path) = @_;
  return $resource_path . '/submit';
}

# parse_resource_path: string -> string list ref
sub parse_resource_path
{
  my ($resource) = @_;
  my @elements = split /\//, $resource;
  my @path = ();
  foreach my $element (@elements)
  {
    next if $element eq "" or $element eq ".";
    if ($element eq "..")
    {
      pop @path;    # silently fail if we're at the beginning
    }
    else
    {
      push @path, $element;
    }
  }
  foreach my $pathelement (@path) {
    $pathelement = decode_urlencoding($pathelement);
  }
  return \@path;
}

# decode_urlencoding: string -> string
sub decode_urlencoding
{
  my ($value) = @_;
  $value =~ s/\+/ /g;
  $value =~ s/%([0-9A-Fa-f]{2})/chr hex $1/eg;
  return $value;
}

# encode_urlencoding: string -> string
sub encode_urlencoding
{
  my ($x) = @_;
  $x =~ s/([^a-zA-Z0-9.\/])/"%" . sprintf("%02x", ord($1))/eg;
  return $x;
}


# parse_urlencoded_parameters: string -> (string, string) hash ref
sub parse_urlencoded_parameters
{
  my ($message) = @_;

  my %values;
  my @pairs = split /&/, $message;
  foreach my $pair (@pairs)
  {
    if ($pair =~ /^([^=]*)=(.*)$/)
    {
      my $key = $1;
      my $value = $2;
      $value = decode_urlencoding( $value );
# ???
#      $value =~ s/\+/ /g;
#      $value =~ s/%([0-9A-Fa-f]{2})/chr hex $1/eg;
      $values{$key} = $value;
    }
  }
  return \%values;
}

# parse_uri: string -> unit
sub parse_uri
{
  my ($http_request) = @_;

  my $uri = $http_request->{uri};

  my %request_semantics;

  my $resource_path_elements = [];
  my $parameters = {};

  $uri =~ s!^[a-zA-Z]+://[^/]+!!;
  if ($uri =~ /^([^?]*)(?:\?(.*))?$/)
  {
    my $resource = $1;
    my $parameters_string = $2;
    $resource_path_elements = parse_resource_path $resource;
    $parameters = parse_urlencoded_parameters $parameters_string;
  }
  $request_semantics{resource_path_elements} = $resource_path_elements;
  $request_semantics{parameters} = $parameters;

  $http_request->{request_semantics} = \%request_semantics;
  classify_request_semantics( $http_request );
}

# parse_multipart_form_data: http_request * string -> string
#  This is ridiculously fragile.
sub parse_multipart_form_data
{
  my ($http_request, $content) = @_;
  my $content_type_string = $http_request->{request_headers}->{"Content-Type"};
  my ($divider) = ($content_type_string =~ /boundary=([^;]+)(?:;|$)/);
  my @parts = split $divider, $content;
  my $part = $parts[1];
  $part =~ s/^\s+//;
  $part =~ s/\015\012+--$//;

  my $section_name;
  while (1)
  {
    if ($part =~ s/^(.*?)\015\012//)
    {
      my $line = $1;
      $line =~ s/^\s+//;
      if ($line)
      {
        if ($line =~ /^Content-Disposition:.*\s+name=(?:"([^"]*)"|([^"\s]+))(?:\s|;|$)/)
        {
          $section_name = $1 ? $1 : $2;
        }
      }
      else
      {
        last;
      }
    }
    else
    {
      last;
    }
  }
  my $sections = {};
  $sections->{$section_name} = $part;
  return $sections;
}

{
  my %content_types;
  my %content_types_by_extension;
  my $default_content_type;

  # binary_exporter: http_request * resource -> string
  sub binary_exporter
  {
    my ($http_request, $resource) = @_;
    return $resource->{text};
  }

  # binary_editor: http_request -> string
  sub binary_editor
  {
    my ($http_request) = @_;
    my $semantics = $http_request->{request_semantics};
    my $resource_path = $semantics->{resource_path};
    my $body = '<form enctype="multipart/form-data" action="'
               . create_resource_submit_path( $resource_path )
               . '" method="post"><input name="text" type="file">'
               . '<input type="submit" value="Submit"/></form>';
    return $body;
  }

  # binary_importer: http_request * string * (string ref) -> string
  sub binary_importer
  {
    my ($http_request, $content, $error_ref) = @_;
    my $sections = parse_multipart_form_data( $http_request, $content );
    return $sections->{text};
#    my $values = parse_urlencoded_parameters( $content );
#    my $text = $values->{text};
#    print "$text\n";
#    return $text;
  }

  # create_content_type: string -> content_type
  #  The content type is initialized with binary transformations.
  sub create_content_type
  {
    my ($mime_type) = @_;

    my $type = {};
    $type->{mime_type} = $mime_type;
    set_content_type_exporter( $type, \&binary_exporter );
    set_content_type_editor( $type, \&binary_editor );
    set_content_type_importer( $type, \&binary_importer );
    return $content_types{$mime_type} = $type;
  }

  # create_binary_content_type: string * string... -> content_type;
  #  Just a convenience wrapper.
  sub create_binary_content_type
  {
    my $mime_type = shift;
    my $type = create_content_type( $mime_type );
    foreach my $extension (@_)
    {
      set_resource_extension_content_type( $extension, $type );
    }
    return $type;
  }

  # set_content_type_exporter: content_type * (http_request * resource -> string) -> unit
  #  Exporters turn local resources into transmitted resources.
  sub set_content_type_exporter
  {
    my ($type, $exporter) = @_;
    $type->{exporter} = $exporter;
  }

  # get_content_type_exporter: content_type -> (http_request * resource -> string)
  #  Exporters turn local resources into transmitted resources.
  sub get_content_type_exporter
  {
    my ($type) = @_;
    return $type->{exporter};
  }

  # set_content_type_editor: content_type * (http_request -> string) -> unit
  #  Editors produce HTML forms for editing resources.
  sub set_content_type_editor
  {
    my ($type, $editor) = @_;
    $type->{editor} = $editor;
  }

  # get_content_type_editor: content_type -> (http_request -> string)
  #  Editors produce HTML forms for editing resources.
  sub get_content_type_editor
  {
    my ($type) = @_;
    return $type->{editor};
  }

  # set_content_type_importer: content_type * (http_request * string * (string ref) -> string) -> unit
  #  Importers turn content received into local resources.
  #    importer: http_request * string * (string ref) -> string
  #     The string is the request content; the reference is to an error message
  #     (return undef to signal semantic error)
  sub set_content_type_importer
  {
    my ($type, $editor) = @_;
    $type->{importer} = $editor;
  }

  # get_content_type_importer: content_type -> (http_request -> string)
  #  Importers turn content received into local resources.
  sub get_content_type_importer
  {
    my ($type) = @_;
    return $type->{importer};
  }

  # get_mime_type: content_type -> string
  sub get_mime_type
  {
    my ($content_type) = @_;
    return $content_type->{mime_type};
  }

  # set_resource_extension_content_type: string * content_type -> unit
  sub set_resource_extension_content_type
  {
    my ($extension, $content_type) = @_;
    $content_types_by_extension{lc $extension} = $content_type;
  }

  # get_content_type: string -> (content_type option)
  sub get_content_type
  {
    my ($mime_type) = @_;
    return $content_types{$mime_type};
  }

  # get_resource_content_type: string -> content_type
  sub get_resource_content_type
  {
    my ($resource_path) = @_;
    my $content_type;
    if ($resource_path =~ /\.([a-zA-Z]+)$/)
    {
      my $extension = lc $1;
      $content_type = $content_types_by_extension{ $extension };
    }
    $content_type = $default_content_type if not $content_type;
    return $content_type;
  }

  # set_default_content_type: content_type -> unit
  sub set_default_content_type
  {
    my ($type) = @_;
    $default_content_type = $type;
  }
}

{
  my %actions;
  my $default_action;

  # add_action_alias: string * action -> unit
  sub add_action_alias
  {
    my ($name, $action) = @_;
    $actions{$name} = $action;
  }

  # create_action: string -> action
  sub create_action
  {
    my ($name) = @_;

    my %action;
    $action{name} = $name;
    return $actions{$name} = \%action;
  }

  # get_action: string -> action option
  sub get_action
  {
    my ($action_name) = @_;
    return $actions{$action_name};
  }

  # set_content_handler: action * (http_request -> unit) -> unit
  sub set_content_handler
  {
    my ($action, $handler) = @_;
    $action->{content_handler} = $handler;
  }

  # set_default_action: action -> unit
  sub set_default_action
  {
    my ($action) = @_;
    $default_action = $action;
  }

  # set_link_generators: action * ((string -> string) list ref) -> unit
  sub set_link_generators
  {
    my ($action, $link_generators) = @_;
    $action->{link_generators} = $link_generators;
  }

  # get_link_generators: action -> ((string -> string) list ref)
  sub get_link_generators
  {
    my ($action) = @_;
    return $action->{link_generators};
  }

  # set_resource_path_processor: action * (string -> string) -> unit
  sub set_resource_path_processor
  {
    my ($action, $processor) = @_;
    $action->{pathfinder} = $processor;
  }

  # create_content_response: http_request * resource -> string
  sub create_content_response
  {
    my ($http_request, $content) = @_;
    my $content_type = $http_request->{request_semantics}->{content_type};
    set_response_content_type( $http_request, $content_type );
    my $exporter = get_content_type_exporter( $content_type );
    $exporter->( $http_request, $content );
  }

  # classify_request_semantics: http_request -> unit
  sub classify_request_semantics
  {
    my ($http_request) = @_;
    my $semantics = $http_request->{request_semantics};
    my $path = $semantics->{resource_path_elements};

    my $length = scalar @$path;

    my $action = $default_action;

    if ($length > 0)
    {
      my $action_candidate = lc $path->[$length - 1];
      if (defined $actions{$action_candidate})
      {
        $action = $actions{$action_candidate};
        pop @$path;
        $length--;
      }
    }
    $semantics->{action} = $action;

    my $resource_path = '/' . (join '/', map {encode_urlencoding($_)} @$path);
    $resource_path = $action->{pathfinder}->( $resource_path );
    $semantics->{resource_path} = $resource_path;

    my $content_type = get_resource_content_type( $resource_path );
    $semantics->{content_type} = $content_type;

#    print "content type: ", get_mime_type( $content_type ), "\n";
#    print "resource path: ", $resource_path, "\n";
#    print "action: ", $action->{name}, "\n";
#    print "semantics: ", $semantics, "\n";
  }
}

# set_response_content_type: http_request * content_type -> unit
sub set_response_content_type
{
  my ($http_request, $type) = @_;
  set_response_content_mime_type( $http_request, get_mime_type( $type ) );
}

# set_response_content_mime_type: http_request * string -> unit
sub set_response_content_mime_type
{
  my ($http_request, $type) = @_;
  set_response_header( $http_request, "Content-Type", $type );
}

# set_response_header: http_request * string * string -> unit
sub set_response_header
{
  my ($http_request, $header, $type) = @_;
  $http_request->{response_headers}->{$header} = $type;
}

{
  my %path_aliases;

  # add_path_alias: string * string -> unit
  #  (alias_path, true_path)
  sub add_path_alias
  {
    my ($alias_path, $true_path) = @_;
    $alias_path = "/$alias_path" if $alias_path !~ m@^/@;
    $true_path = "/$true_path" if $true_path !~ m@^/@;
    $path_aliases{$alias_path} = $true_path;
  }

  # get_true_path: string -> string
  sub get_true_path
  {
    my ($path) = @_;
    my $true_path = $path_aliases{$path};
    return $true_path if defined $true_path;
    return $path;
  }

  # get_true_path_to_resource: string -> string
  sub get_true_path_to_resource
  {
    my ($path) = @_;
    $path = get_true_path( $path );
    my $local_path = create_local_path( $path );
    if (-d $local_path)
    {
      if ($path =~ /\/$/)
      {
        $path .= $directory_page;
      }
      else
      {
        $path .= '/' . $directory_page;
      }
    }
    return $path;
  }
}

# handle_content_request: http_request -> unit
sub handle_content_request
{
  my ($http_request) = @_;

  parse_uri $http_request;

  my $action = $http_request->{request_semantics}->{action};
  my $length = $http_request->{request_headers}->{"Content-Length"};

  if ($length > 0)
  {
    $http_request->{request_content} = recv_nbytes( $http_request, $length );
  }

  my $handler = $action->{content_handler};
  if (not $handler)
  {
    send_error( $http_request, 500, "Internal Server Error", "Couldn't find a content handler for the semantic action '" . $action->{name} . "'." );
  }
  else
  {
    $handler->( $http_request );
  }
}

# handle_content_fetch: http_request -> unit
sub handle_content_fetch
{
  my ($http_request) = @_;
  my $semantics = $http_request->{request_semantics};
  my $resource_path = $semantics->{resource_path};
  my $resource = read_semantic_resource( $resource_path );
  if (not defined $resource)
  {
    my $editpath = create_resource_edit_path( $resource_path );
    send_redirect( $http_request, $editpath );
  }
  else
  {
    my $content = create_content_response( $http_request, $resource );
    send_response( $http_request, 200, "Okay", $content );
  }
}

# handle_content_list: http_request -> unit
sub handle_content_list
{
  my ($http_request) = @_;
  my $resource_path = $http_request->{request_semantics}->{resource_path};

  if (not opendir DIR, create_local_path( $resource_path, "directory" ))
  {
    my $buffer = "Could not list the entries in the path '" . $resource_path . "': $!";
    send_error( $http_request, 400, "Not a directory", $buffer );
  }
  else
  {
    my @files = readdir DIR;
    close DIR;

    my $path = $resource_path;
    $path =~ s/\/*$//;
    $path = local_path_decode($path);

    my $cnt = 0;
    my $buffer;
    foreach my $filename (@files)
    {
      next if not should_list_resource( $resource_path, $filename );
      my $resource = local_path_decode($filename);
      my $linktext = decode_urlencoding($resource);
      $buffer .= '<a href="' . $path . '/' . $resource . '">' . $linktext . '</a><br/>';
      $cnt++;
    }
    if ($cnt == 0)
    {
      $buffer = "No entries found.";
    }
    my $html_response = create_html_response( $http_request, $buffer );
    send_html_okay_response( $http_request, $html_response );
  }
}

# handle_content_edit: http_request -> unit
sub handle_content_edit
{
  my ($http_request) = @_;
  my $semantics = $http_request->{request_semantics};
  my $editor = get_content_type_editor( $semantics->{content_type} );
  my $body = $editor->( $http_request );
  my $html_response = create_html_response( $http_request, $body );

  send_html_okay_response( $http_request, $html_response );
}

# handle_content_submit: http_request -> unit
sub handle_content_submit
{
  my ($http_request) = @_;

  my $semantics = $http_request->{request_semantics};
  my $resource_path = $semantics->{resource_path};
  my $content_type = $semantics->{content_type};

  my $content = $http_request->{request_content};
  if (not defined $content)
  {
    send_error( $http_request, 411, "Length required", "Submissions must include the form content" );
    return;
  }

  my $importer = get_content_type_importer( $content_type );
  my $error_message = "";
  my $text = $importer->( $http_request, $content, \$error_message );

  if (defined $text)
  {
    my $resource = {};
    $resource->{path} = $resource_path;
    $resource->{text} = $text;

    $error_message = write_semantic_resource( $resource );
  }

  if ($error_message)
  {
    send_error( $http_request, 409, "Submission failed", $error_message );
  }
  else
  {
    send_redirect( $http_request, $resource_path );
  }
}

# write_semantic_resource: resource -> string option
#  The return value is an error message.
sub write_semantic_resource
{
  my ($resource) = @_;

  my $path = $resource->{path};
  if (not open RESOURCE, '>', create_local_path( $path ))
  {
    return "Couldn't open the file '$path': $!";
  }
  else
  {
    flock RESOURCE, LOCK_EX;
    print RESOURCE $resource->{text};
    flock RESOURCE, LOCK_UN;
    close RESOURCE;
    return undef;
  }
}


# read_semantic_resource: string -> resource option
sub read_semantic_resource
{
  my ($resource_path) = @_;
  if (not open RESOURCE, '<', create_local_path( $resource_path ))
  {
    return undef;
  }
  else
  {
    flock RESOURCE, LOCK_SH;
    my $text = "";
    while (<RESOURCE>)
    {
      $text .= $_;
    }
    close RESOURCE;
    flock RESOURCE, LOCK_UN;
    my $resource = {};
    $resource->{path} = $resource_path;
    $resource->{text} = $text;
    return $resource;
  }
}

# recv_line: http_request -> string
sub recv_line
{
  my ($http_request) = @_;
  my $recv_cache = $http_request->{recv_cache};
  while (1)
  {
    my $index = index $recv_cache, "\012";
    if ($index >= 0)
    {
      $http_request->{recv_cache} = substr $recv_cache, $index + 1;
      return substr $recv_cache, 0, $index + 1;
    }
    else
    {
      sysread Conn, $recv_cache, 1024, (length $recv_cache);
    }
  }
}

# recv_nbytes: http_request * int -> string
sub recv_nbytes
{
  my ($http_request, $nbytes) = @_;
  my $recv_cache = $http_request->{recv_cache};
  while (1)
  {
    my $remainder = $nbytes - (length $recv_cache);
    if ($remainder <= 0)
    {
      $http_request->{recv_cache} = substr $recv_cache, $nbytes;
      return substr $recv_cache, 0, $nbytes;
    }
    else
    {
      sysread Conn, $recv_cache, $remainder, (length $recv_cache);
    }
  }
}

# send_message: http_request * string -> unit
sub send_message
{
  my ($http_request, $message) = @_;
  syswrite $http_request->{socket}, $message;
}

# send_html_okay_response: http_request * string -> unit
sub send_html_okay_response
{
  my ($http_request, $html_message) = @_;
  set_response_content_mime_type( $http_request, "text/html" );
  send_response( $http_request, 200, "Okay", $html_message );
}

# send_response: http_request * int * string * (string option) -> unit
sub send_response
{
  my ($http_request, $http_response_code, $http_response_description, $http_response) = @_;
  my $buffer = "HTTP/1.0 " . $http_response_code . " " . $http_response_description . "\015\012";
  foreach my $key (keys %{$http_request->{response_headers}})
  {
    $buffer .= $key . ": " . $http_request->{response_headers}->{$key} . "\015\012";
  }
  if ($http_response)
  {
    $buffer .= "Content-Length: " . (length $http_response) . "\015\012";
  }
  $buffer .= "\015\012";
  send_message( $http_request, $buffer );
  if ($http_response and not $http_request->{type} eq "head")
  {
    send_message( $http_request, $http_response );
  }
}

# send_error: http_request * int * string * (string option) -> unit
sub send_error
{
  my ($http_request, $http_error_code, $http_error_message, $http_message) = @_;
  my $buffer;
  if ($http_message)
  {
    $buffer = "<html><head><title>" . $http_error_code . ": " . $http_error_message .
              "</title></head><body><h2>" . $http_error_code . ": " . $http_error_message .
              "</h2><p>" . $http_message . "</p></body></html>";
    set_response_content_mime_type( $http_request, "text/html" );
  }
  send_response( $http_request, $http_error_code, $http_error_message, $buffer);
}

# send_redirect: http_request * string -> unit
sub send_redirect
{
  my ($http_request, $target) = @_;

  my $host = $http_request->{request_headers}->{Host};
  if ($host)
  {
    set_response_header( $http_request, "Location", "http://$host$target" );
    send_response( $http_request, 303, "Redirect", undef );
  }
  else
  {
    my $buffer = "<html><head><title>Redirect to " . $target .
                 "</title></head><body><a href='" . $target .
                 "'>Click here</a></body></html>";
    send_html_okay_response( $http_request, $buffer );
  }
}

# handle_get: http_request -> unit
sub handle_get
{
  handle_content_request @_;
}

# handle_post: http_request -> unit
sub handle_post
{
  handle_content_request @_;
}

{
  my %request_handlers;

  # handle_request: http_request -> unit
  sub handle_request
  {
    my ($http_request) = @_;

    my $type = $http_request->{type};           # already lc
    my $handler = $request_handlers{$type};
    if ($handler)
    {
      $handler->( $http_request );
    }
    else
    {
      send_error( $http_request, 501, 'Not supported', 'The request type "' . $type . '" is unknown or unsupported' );
    }
  }

  # set_handler: string * (http_request -> unit) -> unit
  sub set_handler
  {
    my ($http_request_type, $handler) = @_;
    $request_handlers{lc $http_request_type} = $handler;
  }
}


# classify_relative_resource: string * string -> ('present' | 'absent' | 'nonlocal')
sub classify_relative_resource
{
  my ($resource_path, $relative_path) = @_;
  my $path;
  if ($relative_path =~ /^\//)
  {
    $path = $relative_path;
  }
  elsif ($relative_path =~ /^[a-zA-Z]:/)
  {
    # non-local path
    return 'nonlocal';
  }
  else
  {
    $resource_path =~ s/[^\/]+$//;
    $path = $resource_path . $relative_path;
  }
  if (exists_resource( $path ))
  {
    return 'present';
  }
  else
  {
    return 'absent';
  }
}

# exists_resource: string -> boolean
sub exists_resource
{
  my ($resource_path) = @_;
  my $local_path = create_local_path( $resource_path );
  return -e $local_path;
}

my @sidebar_colors = ('#c16c72', '#b86cc1', '#6c9ac1', '#6cc19a', '#7cc16c', '#c0c16c', '#c1826c');
my $current_sidebar_color = 0;

# make_paler_color: color -> color
sub make_paler_color
{
  my ($color) = @_;
  if ($color =~ /^#([[:xdigit:]]{2})([[:xdigit:]]{2})([[:xdigit:]]{2})$/)
  {
    my ($r, $g, $b) = (hex $1, hex $2, hex $3);
    $r = ($r + 0xFF) / 2;
    $g = ($g + 0xFF) / 2;
    $b = ($b + 0xFF) / 2;
    $color = sprintf( "#%x%x%x", $r, $g, $b );
    return $color;
  }
  else
  {
    return $color;
  }
}

# interpret_link: string * string -> string
#  (resource_path, text)
sub interpret_link
{
  my ($resource_path, $text) = @_;
  return '[' if $text eq "lb";
  return ']' if $text eq "rb";

  if ($text =~ /^aside:\s*(.*)\s*$/i)
  {
    my $text = $1;
    $text = '<sup>&#134;</sup>' unless $text;
    my $sidebar_color = $sidebar_colors[$current_sidebar_color++];
    my $pale_color = make_paler_color( $sidebar_color );
    $current_sidebar_color %= @sidebar_colors;
    return '<span class="note-anchor" style="border-color: ' . $sidebar_color .
      '">' . $text . '</span><span name="sidebar" class="note-body" style="border-color: ' .
      $sidebar_color . '; color: black; background-color: ' . $pale_color . '">';
  }
  elsif ($text =~ /^:aside$/i)
  {
    return '</span>';
  }
  elsif ($text =~ /^([^\|]*)(?:\|([^\|]*))?$/)
  {
    my $linktext = $1;
    my $href = defined $2 ? $2 : $linktext;
    $href = encode_urlencoding( $href );
    my $class = classify_relative_resource( $resource_path, $href );
    return '<a href="' . $href . '" class="' . $class . '"> ' . $linktext . '</a>';
  }
  else
  {
    return $text;
  }
}

# content_fetch_filter: resource -> string
sub content_fetch_filter
{
  $current_sidebar_color = 0;

  my ($resource) = @_;
  my $path = $resource->{path};
  my $text = $resource->{text};
  $text =~ s/\[\[(.*?)\]\]/interpret_link($path, $1)/eg;
  $text =~ s/\r//g;
  $text =~ s/\n\n/\n<P>\n/g;
  $text =~ s/---/&mdash;/g;
  $text =~ s/--/&ndash;/g;
  my ($node) = ${parse_resource_path($path)}[-1];
  if ($node eq "Main")
  {
    return '<div class="column">' . $text . '</div>';
  }
#  elsif ($node =~ /\*(.*)/)
#  {
#    return '<div class=column><B>*' . $1 . '</B> ' . $text . '</div>';
#  }
#  else
  {
    return '<div class="column">' . $text . '</div>';
  }
}

# local_path_encode: string -> string
sub local_path_encode
{
  my ($rp) = @_;
  $rp =~ tr!%!_!;
  $rp;
}

# local_path_decode: string -> string
sub local_path_decode
{
  my ($value) = @_;
  $value =~ tr!_!%!;
  return $value;
}

# process_configuration_line: string -> (string option)
sub process_configuration_line
{
  my ($line) = @_;
  if ($line =~ /^\s*([a-zA-Z0-9\._]+):?\s*([^\s].*)?$/)
  {
    my $command = lc $1;
    my $params = $2;
    if ($command eq "alias")
    {
      if ($params !~ /^([^\s]*)\s+([^\s]*)\s*$/)
      {
        return "expected 'Alias alias_path true_path'";
      }
      my $alias_path = $1;
      my $true_path = $2;
      add_path_alias( $alias_path, $true_path );
    }
    elsif ($command eq "edit.editbox.dimensions")
    {
      if ($params !~ /^([0-9]+)\s*x\s*([0-9]+)\s*$/)
      {
        return "expected 'Edit.editbox.dimensions columns x rows'";
      }
      $edit_box_width = $1;
      $edit_box_height = $2;
    }
    elsif ($command eq "title")
    {
      if ($params !~ /^(.*[^\s])\s*$/)
      {
        return "expected 'Title title_string'";
      }
      $server_title = $1;
    }
    elsif ($command =~ /^([a-z]+).links$/)
    {
      my $action_name = $1;
      my $action = get_action( $action_name );
      my $flags = 0;

      $params = lc $params;
      $params =~ s/\s+$//;
      my @names = split /(?:,\s*|\s+)/, $params;
      my @link_generators;
      if (not @names)
      {
        return "no link generators specified after $command";
      }
      while (my $name = shift @names)
      {
        if ($name eq "none")
        {
          if (@link_generators or @names)
          {
            return "'none' specified with other link generators";
          }
        }
        else
        {
          my $generator = $link_generators{$name};
          if (not $generator)
          {
            return "unknown link generator '$name'";
          }
          push @link_generators, $generator;
        }
      }
      set_link_generators( $action, \@link_generators );
    }
    elsif ($command eq 'directory')
    {
      $params =~ s/\s+$//;
      if (not $params)
      {
        return "no path specified after Directory";
      }
      $database_directory = $params;
    }
    elsif ($command eq 'stylesheet')
    {
      $params =~ s/\s+$//;
      if (not $params)
      {
        return "no style sheet file specified after StyleSheet";
      }
      $style_file = $params;
    }
    elsif ($command eq 'linksattop')
    {
      $params =~ s/\s+$//;
      if ($params =~ /^true$/i)
      {
        $html_links_on_top = 1;
      }
      elsif ($params =~ /^false$/i)
      {
        $html_links_on_top = 0;
      }
      else
      {
        return "expected 'true' or 'false' after LinksAtTop";
      }
    }
    elsif ($command eq 'linksatbottom')
    {
      $params =~ s/\s+$//;
      if ($params =~ /^true$/i)
      {
        $html_links_on_bottom = 1;
      }
      elsif ($params =~ /^false$/i)
      {
        $html_links_on_bottom = 0;
      }
      else
      {
        return "expected 'true' or 'false' after LinksAtBottom";
      }
    }
    else
    {
      return "unknown configuration command: $command\n";
    }
  }
  elsif (not /^\s+$/)
  {
    return "unknown configuration line: $line\n";
  }
  return undef;
}


#  main program begins here

init();

while ($_ = shift)
{
  if (/^-h$/)
  {
    print "listen\n";
    print "  A standalone HTTP wiki server; just run this program in the background\n";
    print "  and point a web browser at localhost. This is version 200503190156-perl.\n";
    print "    -h              Prints this help message and exits.\n";
    print "    -p port         Specifies which port to listen to (default: 80)\n";
    print "    -d directory    Set the data root (default: the working directory)\n";
    print "    -t title        Sets the server title (default: 'listen')\n";
    print "    -r page_name    Sets the page displayed when a folder is fetched (default: 'Main')\n";
    print "    -c config_file  Use the given file for configuration (parsed in-place)\n";
    print "    -cl config_line Process the given line as if it were from a config file\n";
    print "  Send bugs, requests, and comments to rjmccall\@gmail.com\n";
    exit(0);
  }
  elsif (/^-p$/)
  {
    $listen_port = shift;
    if ($listen_port <= 0)
    {
      die "Invalid port specification: $listen_port\n";
    }
  }
  elsif (/^-d$/)
  {
    $database_directory = shift;
    if (not $database_directory)
    {
      die "A directory path is required after -d\n";
    }
  }
  elsif (/^-t$/)
  {
    $server_title = shift;
    if (not defined $server_title)
    {
      die "A title is required after -t\n";
    }
  }
  elsif (/^-r$/)
  {
    $directory_page = shift;
    if (not defined $directory_page)
    {
      die "A page name is required after -r\n";
    }
  }
  elsif (/^-cl$/)
  {
    my $config_line = shift;
    if (not defined $config_line)
    {
      die "Configuration line required after -cl\n";
    }
    my $error = process_configuration_line( $config_line );
    if ($error)
    {
      die "Error on command line after -cl: $error\n";
    }
  }
  elsif (/^-c$/)
  {
    my $config_file = shift;
    if (not defined $config_file)
    {
      die "Configuration file required after -c\n";
    }
    if (not open CONFIG, '<', $config_file)
    {
      die "Couldn't open configuration file '$config_file': $!\n";
    }
    my $lineno = 0;
    while (<CONFIG>)
    {
      $lineno++;
      s/#.*$//;
      my $error = process_configuration_line( $_ );
      if ($error)
      {
        die "Error in '$config_file' at line $lineno: $error\n";
      }
    }
  }
  else
  {
    die 'Unknown parameter: ', $_, "\n";
  }
}

my $tcp_proto = getprotobyname( 'tcp' );

socket Socket, PF_INET, SOCK_STREAM, $tcp_proto or die "socket: $!\n";;
setsockopt Socket, SOL_SOCKET, SO_REUSEADDR, pack( "l", 1 ) or die "setsockopt: $!";
bind Socket, sockaddr_in( $listen_port, INADDR_ANY ) or die "bind: $!\n";
listen Socket, SOMAXCONN or die "listen: $!\n";

while (1)
{
  if (not accept Conn, Socket)
  {
    warn "accept: $!\n";
    next;
  }

  my $http_request = {};
  $http_request->{response_headers} = {};
  $http_request->{socket} = *Conn;

  {
    my $line = recv_line $http_request;
    if ($line =~ /^([a-zA-Z]+)\s+([^\s]+)\s+([^\s]+)/)
    {
      $http_request->{type} = lc $1;
      $http_request->{uri} = $2;
      $http_request->{version} = $3;
    }
    else
    {
      send_error( $http_request, 400, 'Bad request', "Your HTTP client sent a request that couldn't be parsed:</p><pre>$line</pre><p>" );
      close Conn;
      next;
    }
  }

  my %http_request_headers;
  while (1)
  {
    my $line = recv_line $http_request;
    $line =~ s/\s+$//;
    last if not $line;

    $line =~ /^([^:]+):\s*(.*)$/;
    $http_request_headers{$1} = $2;
  }

  $http_request->{request_headers} = \%http_request_headers;

  handle_request $http_request;
  close Conn;
}