A forking tiny web server

This is the uncommonly low denominator in HTTP servers. It does very little, and conforms to HTTP spec in only the most absurdly rudimentary way. Clearly, it's very insecure and poorly coded.

This toy HTTP server is supposed to be used as a tool of last resort. It's implemented in perl because perl version 5 remains ubiquitous - it comes with git on Windows!?! When you need a web server to have a particular behavior, to test a scenario, to break a client in just the right way, it's perfect - all it requires is more code. About the only thing it abstracts is raw socket handling (a bit - thanks perl), and the actual implementation of fork().

However, it's small enough to type in if you're in one of those annoyingly secure sites where you can't just download random rubbish from the Internet and execute it (where's the excitement in that?).

Features:

• Serves multiple HTTP clients simultaneously
• Will run in the most constrained environments (like ancient Unixes, or Visual Studio with git).
• Simple enough to be easily re-written for different test scenarios.
• Implements enough of the HTTP spec that curl won't complain.
• It's moderately secure (because it doesn't do much).
• No bugs (because it doesn't claim to do much)
• Is small enough to be typed in on a coffee break.
• Does some logging
• Serves up 10 GiB fast enough to flood some networks and crash some clients.
• Has enough problems that everyone can find something to fix
• Supports CPUs (more than one!)
• Has comments(? - ok, I'm stretching here)

	#!/usr/bin/env perl
	# forking tiny HTTP server
	# a toy web server
	# thanks to
	# keiya_21@yahoo.co.jp - https://gist.githubusercontent.com/keiya/2782414/raw/811565ccfa479a9e12d0653e2f5118e68e7fda37/server.pl
	use strict;
	use warnings;
	use IO::Socket::INET;
	use Socket qw(SOL_SOCKET);
	$| = 1;
	my $local_port = 9000;
	my $maximum_request_size = 65535; # any HTTP request bigger than this will be silently truncated.
	my $preferred_HTTP_body_size=1*(1000**3); # 10GiB is 10*(1024**3)
	# probably leave these alone
	my $sysread_size = 65535 * 8; # the size of the blob to try and read from the socket on each attempt. 65535 is the the socket buffer size on the machine I wrote this
	my $syswrite_size = $sysread_size; # the size to write... defaults to the same as the read size.
	sub get_more_body {
	my ($offset, $chunk_size, $preferred_total) = @_;
	if ($chunk_size > $preferred_total - $offset) {
	$chunk_size = $preferred_total - $offset
	}
	return('0' x $chunk_size);
	}
	#actual program begins
	my $sock_receive = IO::Socket::INET->new(LocalPort => $local_port, Proto => 'tcp', Listen => SOMAXCONN)
	or die "Cannot create socket: $@";
	# so we can restart our server quickly
	$sock_receive->setsockopt(SOL_SOCKET, SO_REUSEADDR, 1) or
	die "setsockopt: $!";
	print '['.$$.']: Started parent process on port '.$local_port."\n";
	my $sock_client;
	while($sock_client = $sock_receive->accept()) {
	print '['.$$.']: Connection from: '.$sock_client->peerhost().':'.$sock_client->peerport()."\n";
	if (my $pid = fork()){
	$sock_client->close();
	next;
	} else {
	print '['.$$."]: Started child process\n";
	# fiddle about with autoflush after https://perldoc.perl.org/functions/select.html
	my $old_handle = select $sock_client;
	$| = 1;
	select $old_handle;
	# read the request
	my ($this_read, $rv, $receive_buf);
	read_loop: {
	do {
	$rv = sysread($sock_client, $this_read, $sysread_size); # might overrun by 65534
	$receive_buf .= $this_read;
	if (!defined($rv)) {
	print '['.$$."]: Error reading from socket: $!\n";
	last read_loop; # it's ok to continue with a broken request - this is a toy.
	}
	# "parse" the HTTP header.
	last read_loop if $receive_buf =~ /^[A-Z]+[[:space:]].*\r\n\r\n/sm; # break read_loop
	} while ($rv && length($receive_buf) < 1 + $maximum_request_size );
	}
	# do something clever. Nope - I'll do nothing
	# send a reply
	my ($http_overhead, $send_buf);
	my $header = "HTTP/1.0 200 OK\r\nContent-Length: $preferred_HTTP_body_size\r\nConnection: Close\r\n\r\n";
	my $header_size = length($header);
	my $total_sent_size = 0;
	write_loop: {
	do {
	if ($total_sent_size < $header_size) {
	$send_buf = substr($header, $total_sent_size);
	}
	else {
	$send_buf = '';
	}
	$send_buf .= get_more_body($total_sent_size - $header_size, $syswrite_size, $preferred_HTTP_body_size);
	$rv = syswrite($sock_client, $send_buf, $syswrite_size);
	if (!defined($rv)) {
	print '['.$$."]: Error writing to socket: $!\n";
	last write_loop;
	}
	$total_sent_size += $rv;
	} while ($rv && $total_sent_size < ($header_size + $preferred_HTTP_body_size));
	}
	$sock_client->close();
	print '['.$$."]: Disconnect, exited child process.\n";
	exit;
	}
	}
	__END__

view raw forking-tiny-web-server.pl hosted with ❤ by GitHub

	#!/usr/bin/perl
	# nonforker - server who multiplexes without forking
	use strict;
	use warnings;
	use POSIX;
	use IO::Socket;
	use IO::Select;
	use Socket;
	use Fcntl;
	use Tie::RefHash;
	my $port = 1685; # change this at will
	# Listen to port.
	my $server = IO::Socket::INET->new(LocalPort => $port, Proto => 'tcp', Listen => SOMAXCONN)
	or die "Can't make server socket: $@\n";
	# begin with empty buffers
	my %inbuffer = ();
	my %outsent = ();
	my %ready = ();
	tie %ready, 'Tie::RefHash';
	my $preferred_HTTP_body_size = 10*(1024**3);
	my $send_buffer_size = 1024**3;
	my $header = "HTTP/1.0 200 OK\r\nContent-Length: $preferred_HTTP_body_size\r\nConnection: Close\r\n\r\n";
	my $header_size = length($header);
	my $total_response_size = $header_size + $preferred_HTTP_body_size;
	my $send_buf = '';
	nonblock($server);
	my $select = IO::Select->new($server);
	warn 'Started listening on port '.$port."\n";
	# Main loop: check reads/accepts, check writes, check ready to process
	while (1) {
	my ($client, $rv, $data);
	# check for new information on the connections we have
	# anything to read or accept?
	foreach $client ($select->can_read(1)) {
	if ($client == $server) {
	# accept a new connection
	$client = $server->accept();
	warn "Client $client connection from: ".$client->peerhost().':'.$client->peerport()."\n";
	$select->add($client);
	nonblock($client);
	} else {
	# read data
	$data = '';
	$rv = $client->recv($data, POSIX::BUFSIZ, 0);
	unless (defined($rv) && length $data) {
	# This would be the end of file, so close the client
	delete $inbuffer{$client};
	delete $outsent{$client};
	delete $ready{$client};
	$select->remove($client);
	close $client;
	warn "Client $client disconnected\n";
	next;
	}
	$inbuffer{$client} .= $data;
	# test whether the data in the buffer or the data we
	# just read means there is a complete request waiting
	# to be fulfilled. If there is, set $ready{$client}
	# to the requests waiting to be fulfilled.
	while ($inbuffer{$client} =~ s/^([A-Z]+[[:space:]].*\r\n\r\n).*$//sm) {
	push( @{$ready{$client}}, $1 );
	}
	}
	}
	# Any complete requests to process?
	foreach $client (keys %ready) {
	handle($client);
	}
	# Buffers to flush?
	foreach $client ($select->can_write(1)) {
	# Skip this client if we have nothing to say
	next unless exists $outsent{$client};
	if ($outsent{$client} < $header_size) {
	$send_buf = substr($header, $outsent{$client},$header_size - $outsent{$client});
	}
	else {
	$send_buf = '';
	}
	$send_buf .= get_more_body($outsent{$client}, $send_buffer_size, $total_response_size);
	$rv = $client->send($send_buf, 0);
	unless (defined $rv) {
	# Whine, but move on.
	warn "Client $client had error writing to socket: $!\n";
	next;
	}
	if ($rv <= $total_response_size || $! == POSIX::EWOULDBLOCK) {
	$outsent{$client} += $rv;
	delete $outsent{$client} if ($outsent{$client} >= $total_response_size);
	} else {
	# Couldn't write all the data, and it wasn't because
	# it would have blocked. Shutdown and move on.
	warn "Client $client disconnected. Error $!\n";
	delete $inbuffer{$client};
	delete $outsent{$client};
	delete $ready{$client};
	$select->remove($client);
	close($client);
	next;
	}
	}
	# Out of band data?
	foreach $client ($select->has_exception(0)) { # arg is timeout
	# Deal with out-of-band data here, if you want to.
	}
	}
	# handle($socket) deals with all pending requests for $client
	sub handle {
	# requests are in $ready{$client}
	# set output size to $outsent{$client}
	my $client = shift;
	my $request;
	foreach $request (@{$ready{$client}}) {
	# $request is the text of the request
	# put sent size (bytes) of reply into $outsent{$client}
	$outsent{$client} = 0;
	}
	delete $ready{$client};
	}
	# nonblock($socket) puts socket into nonblocking mode
	sub nonblock {
	my $socket = shift;
	my $flags;
	$flags = fcntl($socket, F_GETFL, 0)
	or die "Can't get flags for socket: $!\n";
	fcntl($socket, F_SETFL, $flags | O_NONBLOCK)
	or die "Can't make socket nonblocking: $!\n";
	}
	# create data chunk
	sub get_more_body {
	my ($offset, $chunk_size, $preferred_total) = @_;
	if ($chunk_size > $preferred_total - $offset) {
	$chunk_size = $preferred_total - $offset
	}
	return('0' x $chunk_size);
	}

view raw not-so-forked-web-server.pl hosted with ❤ by GitHub