Forking tiny HTTP server in perl. Compatible with almost any perl v5 - very handy with git bash on Windows.

forking-tiny-web-server.pl

#!/usr/bin/env perl

# forking tiny HTTP server
# a toy web server

# thanks to
# [email protected] - 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__

not-so-forked-web-server.pl

#!/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);
}