#!/usr/local/bin/perl
# listen v0.1-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.
# 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:
# 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
# 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;
my $database_directory = ".";
my $server_title = "listen";
my $main_page_title = "Main page";
my $edit_box_width = undef;
my $edit_box_height = undef;
my $directory_page = "Main";
# 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_filtered( \&content_filter ) );
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 );
}
# 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 $buffer = "";
if ($server_title)
{
$buffer .= $server_title . ': ';
}
$buffer .= $resource_path . "" . $body;
my $link_generators = get_link_generators( $action );
if ($link_generators)
{
my $cnt = 0;
$buffer .= '';
foreach my $link_generator (@$link_generators)
{
$buffer .= ' | ' if $cnt++ > 0;
$buffer .= $link_generator->( $resource_path );
}
$buffer .= '
';
}
$buffer .= "";
return $buffer;
}
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 "" . $main_page_title . "";
}
# list_pages_here: string -> string
sub list_pages_here
{
my ($resource_path) = @_;
return "List other pages here";
}
# edit_this_page: string -> string
sub edit_this_page
{
my ($resource_path) = @_;
return "Edit this page";
}
# 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) = @_;
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);
$pathelement =~ s/[^\w ]//g;
}
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;
}
# 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 );
}
{
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;
}
# 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 '/', @$path);
$resource_path = $action->{pathfinder}->( $resource_path );
$semantics->{resource_path} = $resource_path;
}
}
# set_response_content_type: http_request * string -> unit
sub set_response_content_type
{
my ($http_request, $type) = @_;
set_response_field( $http_request, "Content-Type", $type );
}
# set_response_field: http_request * string * string -> unit
sub set_response_field
{
my ($http_request, $field, $type) = @_;
$http_request->{response_headers}->{$field} = $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 );
}
}
# linkify: string -> string
sub linkify {
my ($text) = @_;
$text =~ s/[^\w ]//g;
if ($text eq "lb") { return "[" }
if ($text eq "rb") { return "]" }
my ($href) = $text;
$href =~ s/ /+/g;
"$text"
}
# content_filter: string -> string
sub content_filter {
my ($text) = @_;
$text =~ s/\[\[(.*?)\]\]/linkify($1)/eg;
$text
}
# handle_content_fetch: http_request -> unit
*handle_content_fetch = handle_content_fetch_filtered( sub { $_[0] } );
# handle_content_fetch_filtered: (string -> string) -> (http_request -> unit)
sub handle_content_fetch_filtered
{
my ($filter) = @_;
return sub {
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
{
if (defined $filter) { $resource->{text} = $filter->($resource->{text}) }
my $html_message = create_html_response( $http_request, $resource->{text} );
send_html_okay_response( $http_request, $html_message );
}
}
}
# 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/\/*$//;
my $cnt = 0;
my $buffer;
foreach my $filename (@files)
{
next if not should_list_resource( $resource_path, $filename );
$buffer .= '' . $filename . '
';
$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 $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 = "" . $resource->{path} . '
';
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 $content = $http_request->{request_content};
if (not defined $content)
{
send_error( $http_request, 411, "Length required", "Submissions must include the form content" );
return;
}
my $values = parse_urlencoded_parameters $content;
my $text = $values->{text};
my $resource_path = $http_request->{request_semantics}->{resource_path};
my $resource = {};
$resource->{path} = $resource_path;
$resource->{text} = $text;
my $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 ()
{
$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_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 = "" . $http_error_code . ": " . $http_error_message .
"" . $http_error_code . ": " . $http_error_message .
"
" . $http_message . "
";
set_response_content_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_field( $http_request, "Location", "http://$host$target" );
send_response( $http_request, 303, "Redirect", undef );
}
else
{
my $buffer = "Redirect to " . $target .
"Click here";
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;
}
}
# 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 200503132359-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 " 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 (/^-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 ()
{
$lineno++;
s/#.*$//;
if (/^\s*([a-zA-Z0-9\._]+):?\s*([^\s].*)?$/i)
{
my $command = lc $1;
my $params = $2;
if ($command eq "alias")
{
if ($params !~ /^([^\s]*)\s+([^\s]*)\s*$/)
{
die "Syntax error in '$config_file' at line $lineno: expected 'Alias alias_path true_path'\n";
}
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*/)
{
die "Syntax error in '$config_file' at line $lineno: expected 'Edit.editbox.dimensions columns x rows'\n";
}
$edit_box_width = $1;
$edit_box_height = $2;
}
elsif ($command eq "title")
{
if ($params !~ /^(.*[^\s])\s*$/)
{
die "Syntax error in '$config_file' at line $lineno: expected 'Title title_string'\n";
}
$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)
{
die "Error in '$config_file' at line $lineno: no link generators specified, use 'none'\n";
}
while (my $name = shift @names)
{
if ($name eq "none")
{
if (@link_generators or @names)
{
die "Error in '$config_file' at line $lineno: 'none' specified with other link generators\n";
}
}
else
{
my $generator = $link_generators{$name};
if (not $generator)
{
die "Error in '$config_file' at line $lineno: unknown link generator '$name'\n";
}
push @link_generators, $generator;
}
}
set_link_generators( $action, \@link_generators );
}
else
{
die "Unknown configuration command in '$config_file' at line $lineno: $command\n";
}
}
elsif (not /^\s+$/)
{
die "Unknown configuration line in '$config_file' at line $lineno: $_\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:$line
" );
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;
}