code-backups/perl/server.pl

#!/usr/bin/env perl
# server.pl
#
# Basic HTTP web server without installing any extra modules*

# Features:
# - directory listing
# - auto directory index (shows index.html/index.htm if exists)
# - watch feature*
# - mimetype handling etc.

# * Requires Filesys::Notify::Simple if watch feature used, but otherwise
# not needed. However, it is possible so that the user doesn't need to install
# the module at all. See comment for instructions on embedding this module.

# License: CC0 1.0 (https://creativecommons.org/publicdomain/zero/1.0/)

# Usage:
# - Have Perl installed
# - Run "perl server.pl"
# - Visit "http://localhost:7777" on a web browser
# Run with -h for more options

# Limitations:
# - Does not handle POST (only GET for now)

# Original (public domain):
# https://renenyffenegger.ch/notes/development/languages/Perl/modules/IO/Socket/echo-server-client

use warnings;
use strict;

use IO::Socket::INET;
use Net::hostent;  # for OO version of gethostbyaddr

# To handle CLI parameters
use Getopt::Long;

use File::Basename;
use Cwd qw( abs_path cwd );
my $script_dir = abs_path(dirname($0));
# Set $PWD/public as webroot
my $webroot_dir = $script_dir . '/public';
# Fallback to current directory in case $script_dir/public is not found
unless ( -d $webroot_dir ) {
	$webroot_dir = cwd();
}

# The port to run the server in
my $port_listen = 7777;
# The dir to watch changes for
my $watch_dir;
# The command to run when file change is detected
my $watch_command;
# Check for file changes at this many seconds interval
my $watch_time_interval = 5;

$| = 1; # Autoflush

# Shows up when --help or -h is passed
sub help_text {
	print("usage: server.pl [-h] [-p PORT] [-d WEBROOT] [-w DIR] [-c COMMAND]
        [-t SECONDS]

A simple HTTP web server in Perl.

optional arguments:
  -h, --help            show this help message and exit
  -p PORT, --port PORT
						port to listen for requests [default:7777]
  -d WEBROOT, --directory WEBROOT
						directory of the files to serve [default:public or \$PWD]
  -w DIR, --watch DIR
						watch DIR for file changes
  -c COMMAND, --watch COMMAND
						run command when file changed in DIR
  -t SECONDS, --time SECONDS
						check for file changes after each SECONDS seconds [default:5]

examples:
  start server in 7777 port and serve files in public or \$PWD:
	\$ ./server.pl
  start server in 3344 port and serve files in www/static directory:
	\$ ./server.pl -p 3344 -d www/static
  start server in watch mode and run generate.pl when file changes:
	\$ ./server.pl -w src -c 'perl generate.pl'\n");
	exit;
}

# Process CLI parameters and update config values as necessary
GetOptions ("p|port=i"      => \$port_listen,
			"d|directory=s" => \$webroot_dir,
			"w|watch=s"     => \$watch_dir,
			"c|command=s"   => \$watch_command,
			"t|time=i"      => \$watch_time_interval,
			"h|help"        => \&help_text)
or die("Error in command line arguments. Please review and try again. Run with -h for help.\n");

# Watch
if ( $watch_dir ) {
	unless ( $watch_command ) {
		die('A command is required when run with -w/--watch. Please set a command with -c param to run a command when files change. See -h for details.');
	}
	# To detect if threads are built into Perl installation
	use Config;
	$Config{useithreads} or
		die('Recompile Perl with threads to run this program or try without -w/--watch param.');
	# Detect if Filesys::Notify::Simple module is installed.
	use Module::Load::Conditional qw( can_load );
	unless ( can_load( modules => {'Filesys::Notify::Simple'} ) ) {
		# Or if you want to have the Filesys::Notify::Simple module saved under
		# a "./perl" dir in the same dir as this script, download the module
		# from https://metacpan.org/pod/Filesys::Notify::Simple
		# and have the files under "/Filesys-Notify-Simple-0.14/lib/" in the
		# archive saved to ./perl, so that there is a
		# ./perl/Filesys/Notify/Simple.pm file. The module is under the same
		# license as Perl. Please include the text under the "LICENSE" heading
		# on the URL above to somewhere on your project if you include the
		# module files. Replace "./perl" with something else in this script to
		# use another directory of your choice.
		if ( -d './perl' ) {
			use lib './perl';
		} else {
			die('Filesys::Notify::Simple module is not installed. Please install and try again or do not use the -w/--watch parameter.');
		}
	}
	use Filesys::Notify::Simple;
	$watch_dir = abs_path($watch_dir);
	my $watcher = Filesys::Notify::Simple->new( [ $watch_dir ] );
	# We'll run the watch on separate thread
	use threads;
	my $thr = threads->create( \&watch_sub );
	# Will check for changes every 5 seconds or $watch_time_interval seconds
	sub watch_sub {
		while ( 1 ) {
			print "> Checking for changes...\n";
			$watcher->wait( sub {
				for my $event ( @_ ) {
					if ( $event->{path} ) {
						print "> Change detected. Running command...\n";
						system($watch_command) == 0 or print "> Command has returned a non-zero exit status :(\n";
					}
				}
			} );
			sleep $watch_time_interval;
		}
	}
	print "> Watching '${watch_dir}' directory for changes...\n";
}

my $socket = IO::Socket::INET->new(

  LocalHost   => '0.0.0.0',
  LocalPort   =>  $port_listen,
  Proto       => 'tcp',
  Listen      =>  5,
  Reuse       =>  1

) or die "Cannot create socket. The port $port_listen is probably already being used? Please pass -p PORT to set a different port or stop already running instances of this script.";

print "> Server started\n";
print "> Waiting for requests on http://localhost:${port_listen}\n";

my $request_path;
my $content='';
my $host;

while ( my $client = $socket->accept() ) {

	# Host related
	my $hostinfo = gethostbyaddr($client->peeraddr);
	$host = $client->peerhost();

	my $request;
	my $request_url = '';
	my $request_params = '';
	my $request_url_full;
	my $request_method;
	# Response related
	my $response_mimetype = 'text/plain';

	local $/ = Socket::CRLF;
	# Read request up to an empty line
	while ( <$client> ) {
		last unless /\S/;
		if (/(\S+) ([^\?]+)(\?.*)? HTTP\//) {
			$request_method = $1;
			$request_url = $2;
			$request_params = $3; # GET params. e.g. "?test=1"
		}
	}
	$request_url_full = $host . ':' . $port_listen . $request_url;

	$request_path = $webroot_dir . $request_url;

	if ( -d $request_path ) {
		if ( -f "${request_path}/index.html" ) {
			$request_path = "${request_path}/index.html";
		} elsif ( -f "${request_path}/index.htm" ) {
			$request_path = "${request_path}/index.htm";
		} else {
			opendir DIR, $request_path;
			my @dir = sort readdir(DIR);
			close DIR;
			# Indicate that we're outputting HTML for the page
			$response_mimetype = 'text/html';
			# Prepare the content for the file index
			$content = "<h1>${request_url_full}</h1>";
			$content .= "<ul>";
			foreach (@dir) {
				if ( -d $request_path . $_ ) {
					$content .= "<li><strong><a href=\"http://${request_url_full}/$_\">$_</a></strong></li>";
				} else {
					$content .= "<li><a href=\"http://${request_url_full}/$_\">$_</a></li>";
				}
			}
			$content .= "</ul>";
		}
		print "> Directory requested. Will serve index HTML instead if found or a directory file list.\n";
	}
	# File is there, so show its content.
	if ( -f $request_path ) {
		open my $CRF, '<', $request_path or die "Can't open cache file $!";
		$content = do { local $/; <$CRF> };
		close($CRF);
	# File does not exist and no directory index content is there to serve.
	# So show error.
	} elsif ( $content eq '' ) {
		print "> ${request_url_full} does not exist, so serving an error instead\n";
		$content = "ERROR: ${request_url_full} could not be found";
	}

	# Set mimetype
	if ( $request_path =~ /\.htm$/ or $request_path =~ /\.html$/ ) {
		$response_mimetype = 'text/html';
	} elsif ( $request_path =~ /\.js$/ ) {
		$response_mimetype = 'text/javascript';
	} elsif ( $request_path =~ /\.css$/ ) {
		$response_mimetype = 'text/css';
	} elsif ( $request_path =~ /\.png$/ ) {
		$response_mimetype = 'image/png';
	} elsif ( $request_path =~ /\.jpg$/ or $request_path =~ /\.jpeg$/ ) {
		$response_mimetype = 'image/jpeg';
	} elsif ( $request_path =~ /\.ico$/ ) {
		$response_mimetype = 'image/x-icon';
	} elsif ( $request_path =~ /\.gif$/ ) {
		$response_mimetype = 'image/gif';
	} elsif ( $request_path =~ /\.svg$/ ) {
		$response_mimetype = 'image/svg+xml';
	} elsif ( $request_path =~ /\.webp$/ ) {
		$response_mimetype = 'image/webp';
	} else {
		print "> Mimetype is not programmed in server for $request_url! Serving as ${response_mimetype}\n";
	}

	# Send header and content
	print $client "HTTP/1.0 200 OK", Socket::CRLF;
	print $client "Content-type: $response_mimetype", Socket::CRLF;
	print $client Socket::CRLF;
	$client->send( $content );

	# Close client and print a message on console
	close $client;
	print "> Request for ${request_url_full} has been answered\n";

}