#!/usr/local/bin/perl
# listen v0.1-perl
# A standalone HTTP Wiki server.
# Created 2005.03.11-03.12 by rjmccall@gmail.com
# Released without warranty and without restriction, except that the author should
# receive appropriate credit for any derivative products.
#
# Doesn't use a database, isn't multithreaded, isn't documented, is written in perl.
use Socket;
use strict;
my $listen_port = 80;
my $database_directory = ".";
my $server_title = "listen";
my $root_page = "Main";
my $main_page_title = "Main page";
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 200503122337-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 entry referenced by / (default: 'Main')\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 'Invalid directory specification: ', $database_directory, '\n';
}
}
elsif (/^-t$/)
{
$server_title = shift;
if (not defined $server_title)
{
die 'Invalid server title specification: ', $server_title, '\n';
}
}
elsif (/^-r$/)
{
$root_page = shift;
if (not defined $root_page)
{
die 'Invalid page specification: ', $root_page, '\n';
}
}
else
{
die 'Unknown parameter: ', $_, "\n";
}
}
sub EDIT_THIS_PAGE { return 0x1; }
sub GO_TO_MAIN_PAGE { return 0x2; }
sub LIST_PAGES_HERE { return 0x4; }
# create_html_response: http_request * string * flags -> string
# Takes a resource path and a body and produces an HTML message
sub create_html_response
{
my ($http_request, $body, $flags) = @_;
my $resource_path = $http_request->{request_semantics}->{resource_path};
my $buffer = "";
if ($server_title)
{
$buffer .= $server_title . ': ';
}
$buffer .= $resource_path . "" . $body;
my $cnt = 0;
if ($flags)
{
$buffer .= '';
}
if ($flags & GO_TO_MAIN_PAGE)
{
$buffer .= ' | ' if $cnt++ > 0;
$buffer .= "" . $main_page_title . "";
}
if ($flags & LIST_PAGES_HERE)
{
$buffer .= ' | ' if $cnt++ > 0;
$buffer .= "List other pages here";
}
if ($flags & EDIT_THIS_PAGE)
{
$buffer .= ' | ' if $cnt++ > 0;
$buffer .= "Edit this page";
}
if ($flags)
{
$buffer .= '
';
}
$buffer .= "";
return $buffer;
}
# 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 ($http_request) = @_;
my $resource_path = $http_request->{request_semantics}->{resource_path};
$resource_path =~ s@/[^/]+$@@;
return $resource_path . '/list';
}
# create_resource_edit_path: string -> string
sub create_resource_edit_path
{
my ($http_request) = @_;
my $resource_path = $http_request->{request_semantics}->{resource_path};
return $resource_path . '/edit';
}
# create_resource_submit_path: string -> string
sub create_resource_submit_path
{
my ($http_request) = @_;
my $resource_path = $http_request->{request_semantics}->{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;
}
}
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 %directory_actions;
# add_action: string * (string option) -> unit
# Adds an action, possibly as an alias for another action
sub add_action
{
my ($action, $aliased) = @_;
if (defined $aliased)
{
$actions{$action} = $aliased;
}
else
{
$actions{$action} = $action;
}
}
# set_directory_action: string -> unit
# Flags an action as applying to directories (not entries)
sub set_directory_action
{
my ($action) = @_;
$directory_actions{$action} = 1;
}
# 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 = "fetch";
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;
if (not $directory_actions{$action} and $length == 0)
{
push @$path, $root_page;
}
my $resource_path = '/' . (join '/', @$path);
$semantics->{resource_path} = $resource_path;
my $resource_name = $path->[$length - 1];
$semantics->{resource_name} = $resource_name;
}
}
# 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 %content_handlers;
# 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 = $content_handlers{$action};
if (not $handler)
{
send_error( $http_request, 500, "Internal Server Error", "Couldn't find a content handler for the semantic action '" . $action . "'." );
}
else
{
$handler->( $http_request );
}
}
# set_content_handler: string * (http_request -> unit) -> unit
sub set_content_handler
{
my ($action, $handler) = @_;
add_action( $action );
$content_handlers{$action} = $handler;
}
}
# handle_content_fetch: http_request -> unit
sub handle_content_fetch
{
my ($http_request) = @_;
my $resource = read_semantic_resource( $http_request->{request_semantics} );
if (not defined $resource)
{
my $editpath = create_resource_edit_path( $http_request );
send_redirect( $http_request, $editpath );
}
else
{
my $html_message = create_html_response( $http_request, $resource->{text}, EDIT_THIS_PAGE | GO_TO_MAIN_PAGE | LIST_PAGES_HERE );
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, GO_TO_MAIN_PAGE );
send_html_okay_response( $http_request, $html_response );
}
}
# handle_content_edit: http_request -> unit
sub handle_content_edit
{
my ($http_request) = @_;
my $resource = read_semantic_resource( $http_request->{request_semantics} );
if (not defined $resource)
{
$resource = {};
$resource->{name} = $http_request->{request_semantics}->{resource_name};
$resource->{name} = $http_request->{request_semantics}->{resource_path};
$resource->{text} = "";
}
my $body = "" . $resource->{name} . '
';
my $html_response = create_html_response( $http_request, $body, GO_TO_MAIN_PAGE | LIST_PAGES_HERE );
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->{name} = $http_request->{request_semantics}->{resource_name};
$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
{
print RESOURCE $resource->{text};
close RESOURCE;
return undef;
}
}
# read_semantic_resource: request_semantics -> resource option
sub read_semantic_resource
{
my ($semantics) = @_;
my $resource_path = $semantics->{resource_path};
my $resource_name = $semantics->{resource_name};
if (not open RESOURCE, '<', create_local_path( $resource_path ))
{
return undef;
}
else
{
my $text = "";
while ()
{
$text .= $_;
}
close RESOURCE;
my $resource = {};
$resource->{path} = $resource_path;
$resource->{name} = $resource_name;
$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;
}
}
set_handler( "get", \&handle_get );
set_handler( "head", \&handle_get );
set_handler( "post", \&handle_post );
set_content_handler( "fetch", \&handle_content_fetch );
set_content_handler( "submit", \&handle_content_submit );
set_content_handler( "edit", \&handle_content_edit );
set_content_handler( "list", \&handle_content_list );
set_directory_action( "list" );
my $tcp_proto = getprotobyname( 'tcp' );
socket Socket, PF_INET, SOCK_STREAM, $tcp_proto or die "socket: $!\n";;
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;
}