path: root/gmi.pl

#!/usr/bin/perl

# this is a gemini server

use strict;
use warnings;
use 5.010;
#use diagnostics;

our $VERSION = 'v0.0.12';

# Modules
use IO::Socket::SSL; # CPAN
use IO::Socket::SSL::Utils; # CPAN
use URL::XS qw(parse_url split_url_path parse_url_query); # CPAN
use Path::Naive qw(normalize_path); # CPAN
#use Smart::Comments; # CPAN
use URI::Encode qw(uri_encode); # CPAN
use IO::Select;
use TOML qw(from_toml);
use Data::Dumper;
use Cwd;
use File::Type;
use English qw( -no_match_vars );
use Const::Fast;
use Carp;

local $PROGRAM_NAME = 'jakes-gemini-server';
# Not worried about fork()-ed children
local $SIG{CHLD} = 'IGNORE';

const my $DEFAULT_GEMINI_PORT => 1965;
const my $KBYTE => 1024;
const my $SECS_IN_YEAR => 3_156_000;
const my $UMASK_FOR_CERTS_KEYS => '077'; # '-rwx------'

const our %GEM_RES_CODES => (
	'input'              => '10 Input',
	'hidden_input'       => '11 Sensitive Input',
	'success'            => '20 !s',
	'redirect'           => '30 !s',
	'redirect_perm'      => '31 !s',
	'temp_failure'       => '40 Temporary Failure',
	'server_unavailable' => '41 Server Unavailable',
	'cgi_error'          => '42 CGI Error',
	'proxy_error'        => '43 Proxy Error',
	'slow_down'          => '44 Slow Down',
	'failure'            => '50 Permament Failure',
	'not_found'          => '51 Not Found',
	'gone'               => '52 Gone',
	'proxy_req_refused'  => '53 Proxy Request Refused',
	'bad_request'        => '59 Bad Request',
	'cert_req'           => '60 Certificate Required',
	'cert_unauth'        => '61 Certificate Unauthorized',
	'cert_invalid'       => '62 Certificate Invalid',
);

const our @VALID_DEFAULT_SETTINGS =>
	qw/bind ports tls assume_index dir_listing root working_dir cert_key_dir 
	log_file log_to_stdout default_mime cert_key_dir_write_warning fork timeout/;
const our @VALID_VHOST_SETTINGS =>
	qw/auto_cert assume_index dir_listing root cert key default_mime/;

my ($config, $err) = from_toml(_slurp('./config.toml'));
if ($err) {
	die "TOML config error: $err.";
}
### $config

my %ssl_config = ssl_config($config);
my %inet_config = inet_config($config);
my $working_dir = working_dir($config);
my $cert_key_dir = cert_key_dir($config);
my $out = logging($config);
my $timeout = timeout_secs($config);
select $out; ## no critic (InputOutput::ProhibitOneArgSelect)
local $OUTPUT_AUTOFLUSH = 1;
ssl_vhost_cert_key(\%ssl_config);

my $fork_toggled = fork_toggle($config);

# let the user know if an invalid option was used
check_config_keys($config);

### %ssl_config

my $ft = File::Type->new();

my $log;

#my $srv = IO::Socket::SSL->new(%ssl_config)
#	or die "error=$ERRNO, ssl_error=$SSL_ERROR";
my $srv = IO::Socket::INET->new(%inet_config)
	or die "error=$ERRNO";

say "$PROGRAM_NAME ($VERSION) started on ". localtime;
if (! $fork_toggled) {
	say 'forking disabled.';
}

# Main server loop
while () {
	my $cl = $srv->accept or next;
	maybe_fork() and next;

	my $clhost = $cl->peerhost();

	IO::Socket::SSL->start_SSL($cl, %ssl_config)
		or do {
			# TODO: user log format
			say "$clhost - $SSL_ERROR [". localtime. ']';
			$cl->shutdown('SHUT_RDWR');
			exit if ($fork_toggled);
			next;
		};

	my $clport = $cl->peerport();
	my $cl_sni = $cl->get_servername();

	my $url;
	my $path;
	my $data;

	my $timedout = 0;
	# We do this because 'naughty' people/bots can clog up the ports doing nothing.
	local $SIG{ALRM} = sub { $timedout = 1 };

	alarm $timeout;

	# ALRM interrupts this
	sysread $cl, $data, $KBYTE
		or $data = '';

	alarm 0;

	if ($timedout) {
		$log = "$clhost - ($cl_sni) sysread failed";
		goto CLOSE;
	}
	if ($data) {
		# removing \r\n
		substr $data, -2, 2, '';
	}
	else {
		# TODO: user log format
		$log = "$clhost - ($cl_sni) no read";
		goto CLOSE;
	}

	# TODO: user log format
	$log = "$clhost - ($cl_sni) $data";

	eval {
		$url = parse_url($data); # if parse_url() fails, it makes the program die.
	} or do {
		### parse_url failed
		speak($cl, 'bad_request');
		goto CLOSE;
	};
	$path = $url->{path};
	### $data
	### $url
	# ## $path

	my $vhost = $url->{host};
	my $doc_loc;

	# only happens if someone is hacking/cracking
	if ($vhost ne $cl_sni) {
		speak($cl, 'bad_request');
		goto CLOSE;
	}

	respond_to_client($cl, $vhost, $doc_loc, $path);
	CLOSE:
	$cl->stop_SSL or warn "error: $ERRNO,  ssl_error: $SSL_ERROR";
	$cl->shutdown('SHUT_RDWR');
	### $cl

	say "$log [". localtime(). ']';

	exit if ($fork_toggled);
}

$srv->close();

sub respond_to_client {
	my ($cl, $vhost, $doc_loc, $path) = @_;

	if (not $doc_loc = get_request_in_vhost_root($vhost, $path)) {
		goto FAILURE;
	}
	### $doc_loc

	# not a directory
	if (! -d $doc_loc) {
		goto DOC_ASSIGNED;
	}

	# make sure 'dir' is 'dir/'
	if (substr($doc_loc,-1,1) ne '/') {
		## no critic (ValuesAndExpressions::ProhibitMagicNumbers)
		# if the '256' (maximum array return size) is not there, the program dies.
		speak($cl, 'redirect', @{ split_url_path($path, 256) }[-1]. '/');
		goto CLOSE;
	}

	my $cv = check_vhost_settings($vhost);

	# if assume_index
	if (($cv == 1 or $cv == 3) and file_exists_and_readable($doc_loc. '/index.gmi')) {
		$doc_loc .= '/index.gmi';
		#$doc = _slurp($doc_loc);
		goto DOC_ASSIGNED;
	}
	# if dir_listing
	elsif ($cv == 2 or $cv == 3) {
		goto DIR_LISTING;
	}
	else {
		goto FAILURE;
	}

	DOC_ASSIGNED:
	#my $meta = $ft->checktype_contents($doc);
	my $meta = detect_mime($doc_loc, $vhost);
	speak($cl, 'success', $meta, $doc_loc);
	return;

	DIR_LISTING:
	speak($cl, 'success', 'text/gemini', $doc_loc, $path);
	return;

	FAILURE:
	speak($cl, 'failure');
	return;
}

sub _slurp {
	my $filename = shift;
	open my $in, '<', $filename
		or carp "Cannot open '$filename' - $ERRNO"
		and return;
	local $INPUT_RECORD_SEPARATOR = undef; # enable 'slurp mode'
	my $contents = <$in>;
	close $in
		or carp "Cannot close filehandle ($filename): $ERRNO";
	return $contents;
}

sub dir_listing {
	my ($doc_loc, $path) = @_;
	return if (! -d $doc_loc || ! -r $doc_loc);

	my $doc = 'Dir listing for /';
	if ($path) { $doc .= "$path" };
	$doc .= "\n\n";

	opendir my $dh, $doc_loc
		or warn "Cannot open $doc_loc: $ERRNO"
		and return; # No point in continuing.

	while (my $i = readdir $dh) {
		if (substr($i,0,1) eq '.') { # dont display hidden files
			next;
		}

		# convert space into %20
		# (there is probably an edge-case bug here)
		$i =~ s/ /%20/g;

		$doc .= "=> $i";
		if (-d "$doc_loc/$i") {
			$doc .= '/';
		}
		$doc .= "\n";
	}
	closedir $dh
		or warn "Cannot close $doc_loc: $ERRNO";

	return $doc;
}

sub gen_cert {
	my ($hostname, $path) = @_;
	my $cert_loc = "$path/$hostname". '_cert.pem';
	my $key_loc = "$path/$hostname". '_key.pem';

	my $not_before = time;
	my $not_after = 20 * $SECS_IN_YEAR + time;

	my %cert = (
		'subject' => { 'commonName' => $hostname },
		'not_before' => $not_before,
		'not_after' => $not_after,
	);
	my ($cert, $key) = CERT_create(%cert);

	my $old_umask = umask oct $UMASK_FOR_CERTS_KEYS;
	PEM_cert2file($cert, $cert_loc);
	PEM_key2file($key, $key_loc);
	CERT_free($cert);
	KEY_free($key);
	umask $old_umask
		or warn "umask: $ERRNO";
	return;
}

# return appropriate path that can be sysread -> syswrite
# WARNING: this has not been tested properly for security!! may serve any file somehow!
# rude users can `ln -s /etc/passwd ./passwd` in their capsule directory. 
sub get_request_in_vhost_root {
	my ($vhost, $request) = @_;
	my $r = '';

	if ($request) {
		# remove '..'
		$request =~ s/[.]{2}//g;
		# convert %20 into space
		$request =~ s/%20/ /g;

		$r = normalize_path($request);
		if (substr($request, -1, 1) eq '/') {
			# normalize_path() removes the trailing '/'
			$r .= '/';
		}
	}
	### $r

	if (exists $config->{$vhost}{root}) {
		my $p = accurate_path($config->{$vhost}{root}, $working_dir);
		if (file_exists_and_readable("$p/$r")) {
			return "$p/$r";
		}
	}
	# try default's root
	elsif (exists $config->{default}{root}) {
		my $p = accurate_path($config->{default}{root}, $working_dir);
		if (file_exists_and_readable("$p/$r")) {
			return "$p/$r";
		}
	}
	else {
		serr("default and $vhost have improper root settings.");
		return;
	}
	return;
}

sub file_exists_and_readable {
	my ($path) = @_;
	if (defined $path and ref \$path eq 'SCALAR') {
		(-e $path and -r $path) ? return 1 : return 0;
	}
	return;
}

sub gem_code {
	my ($code, @r) = @_;
	exists $GEM_RES_CODES{$code}
		or die "'$code' is an invalid Gemini Status.";

	my $res = $GEM_RES_CODES{$code};
	for (@r) {
		$res =~ s/!s/$_/;
	}
	return $res;
}

sub speak {
	my ($cl, $header, $meta, $doc_loc, $path) = @_;
	### $meta
	my $head = gem_code($header, $meta);
	$log .= " $head";
	syswrite $cl, "$head\r\n"
		or warn "syswrite failed: $ERRNO";

	if ($doc_loc) {
		if (file_exists_and_readable($doc_loc) and (! -d $doc_loc)) {
			my $r;
			## no critic (InputOutput::RequireBriefOpen)
			open my $fh, '<', $doc_loc
				or warn "Cannot open '$doc_loc': $ERRNO"
				and return;
			# An SSL packet can only have about 16k bytes 
			# so, read less 16k, send it until eof
			while (sysread $fh, $r, 15*$KBYTE) {
				syswrite $cl, $r
					or $log .= " $ERRNO"
					and return;
				undef $r;
			}
			close $fh
				or warn "failed to close filehandle: $ERRNO";
		}
		elsif (file_exists_and_readable($doc_loc) and -d $doc_loc) {
			my $doc;
			$path ? ($doc = dir_listing($doc_loc, $path)) : ($doc = dir_listing($doc_loc));

			# It is possible that a dir listing can produce more than 16k bytes
			my $offset = 0;
			while (my $w = syswrite $cl, $doc, 15*$KBYTE, $offset) {
				$offset += $w;
			}
		}
	}
	return;
}

sub check_vhost_settings {
	# assume_index first, then dir_listing
	# returns:
	# 0 = no setting 
	# 1 = assume_index
	# 2 = dir_listing
	# 3 = assume_index and dir_listing
	my ($vhost) = @_;

	my $assume_index = 0;
	my $dir_listing = 0;

	# Vhost first
	if (exists $config->{$vhost}{assume_index}) {
		if ($config->{$vhost}{assume_index} eq 'true') {
			### vhost assume index is true
			$assume_index = 1;
		}
		elsif ($config->{$vhost}{assume_index} eq 'false') {
			### vhost assume index is false 
			$assume_index = 2;
		}
	}

	if (exists $config->{$vhost}{dir_listing}) {
		if ($config->{$vhost}{dir_listing} eq 'true') {
			### vhost dir listing is true 
			$dir_listing = 1;
		}
		elsif ($config->{$vhost}{dir_listing} eq 'false') {
			### vhost dir listing is false 
			$dir_listing = 2;
		}
	}

	# no vhost option, check default setting.
	if ($assume_index == 0 and $dir_listing == 0) {
		if (exists $config->{default}{assume_index} and $config->{default}{assume_index} eq 'true') {
			### default assume_index is true 
			$assume_index = 1;
		}

		if (exists $config->{default}{dir_listing} and $config->{default}{dir_listing} eq 'true') {
			### default dir_listing is true 
			$dir_listing = 1;
		}
	}

	if ($assume_index == 1 and $dir_listing == 1) {
		### returning 3
		return 3;
	} elsif ($assume_index == 1) {
		### returning 1
		return 1
	} elsif ($dir_listing == 1) {
		### returning 2 
		return 2;
	}
	else {
		### returning 0
		return 0;
	}
	return;
}

sub abs_or_rel {
	my ($p) = @_;
	if (defined $p and ref \$p eq 'SCALAR') {
		substr($p,0,1) eq '/'
			? return 'abs' : return 'rel';
	}
	return;
}

# '"config value is invalid" at <line_numb> in <program>' is ugly.
sub serr {
	my ($s) = @_;
	return say {*STDERR} $s;
}

sub cert_key_dir {
	my ($conf_ref) = @_;
	my $dir;
	if (exists $conf_ref->{default}{cert_key_dir}) {
		$dir = accurate_path($conf_ref->{default}{cert_key_dir}, $working_dir);
	}
	else {
		$dir = "$working_dir/certs";
	}

	# Create cert_key_dir if needed
	if (-d $dir and -r $dir and -x $dir) {
		if (! -w $dir) {
			if (! (exists $conf_ref->{default}{cert_key_dir_write_warning}
				and $conf_ref->{default}{cert_key_dir_write_warning} eq 'false'))
			{
				serr("cert_key_dir ($dir) not writable.");
			}
		}
	} elsif (! -e $dir) {
		mkdir $dir
			or die "Could not create cert_key_dir ($dir) - $ERRNO";
	}
	else {
		die "cert_key_dir ($dir) is not all of these: ".
		'directory, readable, or executeable.';
	}

	return $dir;
}

sub working_dir {
	my ($conf_ref) = @_;
	my $dir;
	if (exists $conf_ref->{default}{working_dir}) {
		$dir = $conf_ref->{default}{working_dir};
		if (! (-e $dir and -r $dir and -d $dir) ) {
			die "$working_dir is either: not existing, readable, or a directory.";
		}
	}
	else {
		$dir = getcwd;
	}
	return $dir;
}

sub ssl_config {
	my ($conf_ref) = @_;
	my %ssl = (
		SSL_version => '!SSLv2:!SSLv3:!TLSv1:!TLSv1_1',
		Listen => 5,

		SSL_fast_shutdown => 1,
		Timeout => 5, # !! Nothing to do with the config option !!
		              # used if /no/ SSL was established
		SSL_error_trap => 1,
		#SSL_server => 1,
	);
	for my $item (keys %{ $conf_ref->{default} } ) {
		if ($item eq 'tls') {
			# don't allow any on the assuption the config has specified which to allow 
			# (only 1.2 and 1.3 per the Gemini Spec)
			$ssl{SSL_version} = '!SSLv2:!SSLv3:!TLSv1:!TLSv1_1:!TLSv1_2:!TLSv1_3';

			for my $tls ( @{ $conf_ref->{default}{tls} } ) {
				if ($tls eq 'v1.2') {
					$ssl{SSL_version} =~ s/:!TLSv1_2//;
				}
				elsif ($tls eq 'v1.3') {
					$ssl{SSL_version} =~ s/:!TLSv1_3//;
				}
				else {
					serr("TLS option '$tls' not supported - ignoring.");
				}
			}
		}
	}
	return %ssl;
}

sub inet_config {
	my ($conf_ref) = @_;
	my %inet = (
		LocalAddr => '0.0.0.0',
		LocalPort => $DEFAULT_GEMINI_PORT,
		Listen => 10,
		Timeout => 5, # !! Nothing to do with config option !!
		              # used when a connection to the socket doesnt do anything
	);
	for my $item (keys %{ $conf_ref->{default} }) {
		if ($item eq 'bind') {
			$inet{LocalAddr} = $conf_ref->{default}{bind};
		}
		elsif ($item eq 'ports') {
			for my $port ( @{ $conf_ref->{default}{ports} } ) {
				# TODO; enable more than one port.
				$inet{LocalPort} = $conf_ref->{default}{ports}[0];
			}
		}
	}
	return %inet;
}

sub logging {
	my ($conf_ref) = @_;
	if (exists $conf_ref->{default}{log_to_stdout} and $conf_ref->{default}{log_to_stdout} eq 'true') {
		return \*STDOUT;
	}
	elsif (exists $conf_ref->{default}{log_file} and $conf_ref->{default}{log_file}) {
		my $p = abs_or_rel($conf_ref->{default}{log_file});
		if ($p eq 'abs') {
			open my $fh, '>>', "$conf_ref->{default}{log_file}"
				or die "Cannot open log file: $ERRNO";
			return $fh;
		}
		elsif ($p eq 'rel') {
			open my $fh, '>>', "$working_dir/$conf_ref->{default}{log_file}"
				or die "Cannot open log file: $ERRNO";
			return $fh;
		}
		else {
			die 'log_file: is neither absolute or relative.'
		}
	}
	else {
		serr('default: No log option specified, logging to STDOUT.');
		return \*STDOUT;
	}
	return;
}

sub fork_toggle {
	my ($conf_ref) = @_;
	if (exists $conf_ref->{default}{fork}) {
		if ($conf_ref->{default}{fork} eq 'true') {
			return 1;
		}
		elsif ($conf_ref->{default}{fork} eq 'false') {
			return 0;
		}
		else {
			serr("fork value ($conf_ref->{default}{fork}) is not true/false. Assuming true.");
			return 1;
		}
	}
	else {
		return 1;
	}
}

sub ssl_vhost_cert_key {
	my ($ssl_ref) = @_;
	for my $vhost (keys %{ $config }) {
		next if ($vhost eq 'default');
		my $error_free = 1;
		my $cert_loc;
		my $key_loc;

		if (exists $config->{$vhost}{cert} and exists $config->{$vhost}{key}) {
			$cert_loc = accurate_path($config->{$vhost}{cert}, $cert_key_dir);
			if (! -e $cert_loc) {
				serr("$vhost: '$cert_loc' does not exist.");
				$error_free = 0;
			}

			$key_loc = accurate_path($config->{$vhost}{key}, $cert_key_dir);
			if (! -e $key_loc) {
				serr("$vhost: '$key_loc' does not exist.");
				$error_free = 0;
			}
		}
		else {
			if (exists $config->{$vhost}{auto_cert} and $config->{$vhost}{auto_cert} eq 'true') {
				# manage cert for user
				$cert_loc = "$cert_key_dir/$vhost". '_cert.pem';
				$key_loc = "$cert_key_dir/$vhost". '_key.pem';

				if ((! -e $cert_loc) or (! -e $key_loc)) {
					gen_cert($vhost, $cert_key_dir);
					say "$vhost cert/key pair generated in '$cert_key_dir'.";
				}
				else {
					# TODO: make sure cert is valid, otherwise re-generate them
				}
			}
			else {
				serr("$vhost: only has one part of a cert/key pair and/or auto_cert is not true.");
				$error_free = 0;
			}
		}

		if ($error_free) {
			$ssl_ref->{SSL_cert_file}{$vhost} = $cert_loc;
			$ssl_ref->{SSL_key_file}{$vhost} = $key_loc;
		}
		else {
			serr("$vhost: will not listen for incoming requests.");
		}
	}
	return;
}

sub check_config_keys {
	my ($conf_ref) = @_;
	for my $vhost (keys %{ $conf_ref }) {
		## no critic (References::ProhibitDoubleSigils)
		my $array_ref = \@VALID_VHOST_SETTINGS;
		if ($vhost eq 'default') {
			$array_ref = \@VALID_DEFAULT_SETTINGS;
		}
		for my $option (keys %{ $conf_ref->{$vhost} }) {
			my $valid = 0;
			for (@$array_ref) {
				if ($option eq $_) {
					$valid = 1;
					last;
				}
			}
			if (! $valid) {
				serr("$vhost: '$option' is invalid.");
			}
		}
	}
	return;
}

sub accurate_path {
	my ($p, $rel) = @_;
	my $aor = abs_or_rel($p);
	if ($aor eq 'abs') {
		return $p;
	}
	elsif ($aor = 'rel') {
		return "$rel/$p";
	}
	else {
		carp "Value is neither absolute or relative: $p";
		return;
	}
}

sub detect_mime {
	my ($doc_loc, $vhost) = @_;
	my $meta = $ft->checktype_filename($doc_loc);
	# 'text/gemini' is non-standard mime-type
	if ($meta eq 'application/octet-stream') {
		## no critic (ControlStructures::ProhibitCascadingIfElse)
		if ((substr($doc_loc, -4, 4) eq '.gmi') or (substr($doc_loc, -1, 1) eq '/')) {
			return 'text/gemini';
		}
		# Manually support webm until better magic detection is used
		elsif (substr($doc_loc, -4, 4) eq 'webm') {
			return webm_type($doc_loc);
		}
		elsif (exists $config->{$vhost}{default_mime}) {
			return $config->{$vhost}{default_mime};
		}
		elsif (exists $config->{default}{default_mime}) {
			return $config->{default}{default_mime};
		}
		### $meta
	}
	return $meta;
}

sub webm_type {
	my ($doc_loc) = @_;
	my $mime;
	open my $fh, '<', $doc_loc
		or warn "Cannot open webm ($doc_loc) for mime detection: $ERRNO"
		and return;
	read $fh, $mime, 1*$KBYTE
		or warn "Cannot read webm ($doc_loc) for mime detection: $ERRNO"
		and return;
	close $fh
		or warn "Cannot close file handle: $ERRNO";
	if ($mime =~ m/V_VP9/) {
		return 'video/VP9';
	} elsif ($mime =~ m/V_VP8/) {
		return 'video/VP8';
	} else {
		# fall back
		return 'application/octet-stream';
	}
}

sub maybe_fork {
	if ($fork_toggled) {
		my $pid = fork;
		if (not defined $pid) {
			warn "Cannot make a child: $ERRNO";
			return;
		}
		if ($pid) {
			return 1;
		}
		else {
			local $PROGRAM_NAME = "chld: $PROGRAM_NAME";
			return;
		}
	}
}

sub timeout_secs {
	my ($cert_ref) = @_;
	if (exists $cert_ref->{default}{timeout}) {
		if ($cert_ref->{default}{timeout} =~ /^(\d*)$/) {
			return $1;
		}
		else {
			serr("Timeout value ($cert_ref->{default}{timeout}) is invalid. Using 5 seconds.");
			return 5;
		}
	}
	else {
		return 5;
	}
}

1;