path: root/gmi.pl

#!/usr/bin/perl

# this is a gemini server

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

our $VERSION = 'v0.18.0-cgi_WIP';

# Modules
use IO::Socket::SSL; # CPAN
use IO::Socket::SSL::Utils; # CPAN
use IO::Socket::IP -register;
use IO::Socket::UNIX;
use IO::Select;
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;
use String::Substitution qw( gsub_modify );
use IPC::Run3;

#$IO::Socket::SSL::DEBUG = 15;

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',
	'custom'             => '!s',
);

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
	unix redirection redirect/;
const our @VALID_VHOST_SETTINGS =>
	qw/auto_cert assume_index dir_listing root cert key default_mime bind ports
	unix redirection redirect cert_req/;

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


my $working_dir = working_dir($config);
my $cert_key_dir = cert_key_dir($config);
my $out = logging($config);
select $out; ## no critic (InputOutput::ProhibitOneArgSelect)
local $OUTPUT_AUTOFLUSH = 1;

my $timeout = timeout_secs($config);

my $listen_config = listen_config($config); #, %ssl_config, %ip_config);
### $listen_config

my @srv = ip_config($listen_config);
### @srv

my %ssl_config = ssl_config($config);
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 $cl_cert;

my $sel = IO::Select->new();
select_add_listen($sel, @srv);

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

# Main server loop
while (my @ready = $sel->can_read) {
	my $cl;

	my $fh = shift @ready;
	$cl = $fh->accept;
	my ($fh_sockhost, $fh_port, $clhost, $clport) = get_fh_data($fh, $cl);

	### $fh_sockhost
	### $fh_port
	### $clhost
	### $clport

	maybe_fork() and next;

	### before start_SSL
	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;
		};
	### nice, start_SSL worked

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

	if (! check_fh_port_with_host_listen_port($cl_sni, $fh_sockhost, $fh_port)) {
		# TODO: user log format
		$log = "$clhost - ($cl_sni) client request on wrong port";
		speak($cl, 'proxy_req_refused');
		goto CLOSE;
	}

	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:
	if (ref $fh ne 'IO::Socket::UNIX') {
		# stop_SSL doesnt work with IO::Socket::UNIX for some reason, 
		# but shutdown does. stop_SSL is supposed to return $cl to 
		# it's original class (ie IO::Socket::UNIX or IO::Socket::IP)
		$cl->stop_SSL or warn "error: $ERRNO,  ssl_error: $SSL_ERROR";
		$cl->shutdown('SHUT_RDWR');
	}
	else {
		$cl->close( (SSL_fast_shutdown=>0) );
	}
	### $cl

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

	exit if ($fork_toggled);
	undef $cl_cert;
}

#$srv->close();

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

	my ($cert_req, $cert_meta, $check_path) = cert_req($vhost, $path);
	if ($cert_req) {
		if ($cert_meta) {
			speak($cl, 'custom', "60 $cert_meta");
		}
		else {
			speak($cl, 'cert_req');
		}
		goto CLOSE;
	}

	my $redirection = redirection_parameter($vhost);
	if ($redirection) {
		my $redirect = check_for_config_redirection($vhost, $path, $redirection);
		if ($redirect) {
			speak($cl, 'redirect', $redirect);
			return;
		}
	}

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

	### cgi checking
	if (check_cgi($doc_loc, $vhost)) {
		goto DOC_CGI;
	}

	# 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;

	DOC_CGI:
	do_cgi($doc_loc, $path, $cl);
	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',
		SSL_server => 1,
		Listen => 5,
		# If peer sends us a cert, use the callback to accept it for future use.
		SSL_verify_mode => SSL_VERIFY_PEER,
		SSL_verify_callback => \&verify_cert_callback,

		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 ip_config {
	my ($listening_ref) = @_;
	my @a;
	my %paths;
	for my $socket (keys %{ $listening_ref }) {
		# if IP socket
		if ($socket ne 'unix') {
			for my $port (keys %{ $listening_ref->{$socket} }) {
				my %listener = (
					LocalAddr => $socket,
					LocalPort => $port + 0, # coax into number
					Listen => 10,
					Timeout => 5, # !! Nothing to do with config option !!
					              # used when a connection to the socket doesnt do anything
				);
				push @a, \%listener;
			}
		}
		# else an UNIX socket
		else {
			for my $unix (keys %{ $listening_ref->{unix}{path} }) {
				if (exists $paths{ $listening_ref->{unix}{path}{$unix} }) {
					next;
				}
				else {
					$paths{ $listening_ref->{unix}{path}{$unix} } = 1;
					## no critic (RequireCheckedSyscalls) # doesn't matter if success or not
					unlink $listening_ref->{unix}{path}{$unix};
					my %listener = (
						Type => SOCK_STREAM(),
						Local => $listening_ref->{unix}{path}{$unix},
						Listen => 1,
					);
					push @a, \%listener
				}
			}
		### %paths
		}
	}
	return @a;
}

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;
	}
}

sub listen_config {
	my ($conf_ref, $ssl_ref, $ip_ref) = @_;
	my %listen;
	my @default_bind;
	my @default_ports;

	if (exists $conf_ref->{default}{bind}) {
		if ($conf_ref->{default}{bind} ne 'no') {
			push @default_bind, give_array($conf_ref->{default}{bind});
		}
	}
	else {
		# Listen to all
		push @default_bind, '::';
	}

	if (exists $conf_ref->{default}{ports}) {
		push @default_ports, give_array($conf_ref->{default}{ports});
	}
	else {
		push @default_ports, $DEFAULT_GEMINI_PORT;
	}

	if (exists $conf_ref->{default}{unix} and $conf_ref->{default}{unix} ne 'no') {
		$listen{unix}{path}{default} = $conf_ref->{default}{unix};
	}

	for my $vhost (keys %{ $conf_ref }) {
		next if ($vhost eq 'default');
		my $binds;
		my $ports;

		if (exists $conf_ref->{$vhost}{ports}) {
			@{ $ports } = give_array($conf_ref->{$vhost}{ports});
		}
		else {
			$ports = \@default_ports;
		}

		if (exists $conf_ref->{$vhost}{bind}) {
			if ($conf_ref->{$vhost}{bind} ne 'no') {
				@{ $binds } = give_array($conf_ref->{$vhost}{bind});
			}
		}
		else {
			$binds = \@default_bind;
		}
		### $ports
		### $binds

		for my $port (give_array($ports)) {
			for my $bind (give_array($binds)) {
				push @{ $listen{$bind}{$port} }, $vhost;
			}
		}

		# check vhost unix socket otherwise check for default unix socket
		if (exists $conf_ref->{$vhost}{unix} and $conf_ref->{$vhost}{unix} ne 'no') {
			$listen{unix}{path}{$vhost} = $conf_ref->{$vhost}{unix};
			push @{ $listen{unix}{listen} }, $vhost;
		}
		elsif (exists $listen{unix}{path}{default}) {
			push @{ $listen{unix}{listen} }, $vhost;
		}
	}
	# ## %listen
	return \%listen;
}

sub give_array {
	my ($ref) = @_;

	## no critic (Cascading, DoubleSigil)
	if (ref $ref eq 'ARRAY') {
		return @$ref;
	}
	elsif (ref $ref eq 'SCALAR') {
		return $ref;
	}
	elsif (ref \$ref eq 'ARRAY') {
		return @$ref;
	}
	elsif (ref \$ref eq 'SCALAR') {
		return $ref;
	}
	else {
		confess 'not array or scalar nor a reference to such.';
	}
}

sub check_fh_port_with_host_listen_port {
	my ($sni, $fh_sockhost, $fh_port) = @_;
	if ($fh_sockhost ne 'UNIX') {
		for my $dns_host (@{ $listen_config->{$fh_sockhost}{$fh_port} }) {
			if ($dns_host eq $sni) {
				return 1;
			}
		}
	}
	else {
		for my $dns_host (@{ $listen_config->{unix}{listen} }) {
			### $dns_host
			### $sni
			# explictly given a unix path
			if (($dns_host eq $sni) and exists $listen_config->{unix}{path}{$sni}) {
				return 1;
			}
			# default's unix path
			elsif (($dns_host eq $sni) and exists $listen_config->{unix}{path}{default}) {
				return 1;
			}
		}
	}
	return 0;
}

sub get_fh_data {
	my ($fh, $cl) = @_;
	my $fh_sockhost;
	my $fh_port;
	my $clhost;
	my $clport;
	if (ref $fh eq 'IO::Socket::IP') {
		$fh_sockhost = $fh->sockhost;
		$fh_port = $fh->sockport;
		$clhost = $cl->peerhost();
		$clport = $cl->peerport();
	} elsif (ref $fh eq 'IO::Socket::UNIX') {
		$fh_sockhost = 'UNIX';
		$fh_port = 'UNIX';
		$clhost = $cl->hostpath();
		$clport = 'UNIX';
	}
	return $fh_sockhost, $fh_port, $clhost, $clport;
}

sub select_add_listen {
	my ($sell, @srvv) = @_;
	for my $lsn (@srvv) {
		## no critic (DoubleSigil)
		if (exists $lsn->{LocalAddr}) {
			$sell->add(IO::Socket::IP->new(%$lsn))
				or die "$ERRNO ($lsn->{LocalAddr}:$lsn->{LocalPort})";
		}
		elsif (exists $lsn->{Local}) {
			$sell->add(IO::Socket::UNIX->new(%$lsn))
				or die "$ERRNO ($lsn->{Local})";
		}
	}
	return;
}

sub check_for_config_redirection {
	my ($vhost, $path, $redirection) = @_;

	if (! $path) {
		$path = '/';
	}
	else {
		$path = "/$path";
	}


	if (exists $config->{$vhost}{redirect}) {
		# 'simple'
		if ($redirection >= 1 and exists $config->{$vhost}{redirect}{$path}) {
			return $config->{$vhost}{redirect}{$path};
		}

		if ($redirection >= 2) {
			# regular expression compiling
			for my $redirect (keys %{ $config->{$vhost}{redirect} }) {
				# ## $redirect
				my $redirect_replace = $config->{$vhost}{redirect}{$redirect};
				# ## $redirect_replace

				my $regex_match;
				#my $regex_replace;
				eval {
					$regex_match = qr/$redirect$/;
				} or serr($EVAL_ERROR) and return;

				if ($path =~ m/$regex_match/) {
					gsub_modify($path, $regex_match, $redirect_replace);
					return $path;
				}
			}
		}
	}
	return;
}

sub redirection_parameter {
	my ($vhost) = @_;
	my $r;
	if (exists $config->{$vhost}{redirection}) {
		$r = $config->{$vhost}{redirection};
	}
	elsif (exists $config->{default}{redirection}) {
		$r = $config->{default}{redirection};
		$vhost = 'default';
	}

	if ($r) {
		if ($r eq 'no') {
			return 0;
		}
		elsif ($r eq 'simple') {
			return 1;
		}
		elsif ($r eq 'regex') {
			return 2;
		}
		else  {
			serr("'$vhost': Given redirection parameter is invalid: $r");
		}
	}

	return;
}

## no critic (unpack)
sub verify_cert_callback {
	### @_;
	## perl arrays start at 0, not 1
	#1. a true/false value that indicates what OpenSSL thinks of the certificate,
	#2. a C-style memory address of the certificate store,
	#3. a string containing the certificate's issuer attributes and owner attributes, and
	#4. a string containing any errors encountered (0 if no errors).
	#5. a C-style memory address of the peer's own certificate (convertible to PEM form with Net::SSLeay::PEM_get_string_X509()).
	#6. The depth of the certificate in the chain. Depth 0 is the leaf certificate.
	## $pem
	$cl_cert = CERT_asHash(PEM_string2cert(Net::SSLeay::PEM_get_string_X509($_[4])));
	### $cl_cert
	return 1;
}
## use critic

## no critic (deep, return, useless, complex)
sub cert_req {
	my ($vhost, $path) = @_;
	$path ? ($path = "/$path") : ($path = '/');

	if (exists $config->{$vhost}{cert_req}) {
		my $cert_req = $config->{$vhost}{cert_req};
		### $cert_req
		for my $key (keys %{ $cert_req }) {
			### $key
			### $path
			my $regex = qr{$key};
			if ($path =~ m/$regex/) {
				### yep, that path matched that key
				my ($req, $meta);
				if (ref $cert_req->{$key} eq 'ARRAY') {
					$req = $cert_req->{$key}[0];
					if ($req eq 'any' and defined $cl_cert) {
						return 0;
					}
					elsif ($req eq 'pubkey' and defined $cl_cert) {
						my $cl_cert_f = $cl_cert->{fingerprint_sha256};
						$cl_cert_f =~ s/://g;
						$cl_cert_f = lc $cl_cert_f;
						for my $pubkey (@{ $cert_req->{$key} }) {
							my $pk = $pubkey;
							$pk =~ s/://g;
							$pk = lc $pk;
							### $pk
							### $cl_cert_f
							if ($pk eq $cl_cert_f) {
								return 0;
							}
						}
					}
					elsif ($req eq 'file' and defined $cl_cert) {
						my $cl_cert_f = $cl_cert->{fingerprint_sha256};
						$cl_cert_f =~ s/://g;
						$cl_cert_f = lc $cl_cert_f;

						for my $file (@{ $cert_req->{$key} }) {
							### $file
							## no critic (RequireBriefOpen)
							if (-e $file and -r $file) {
								open my $fh, '<', $file
									or serr("'$vhost': cert_req: '$file': $ERRNO");
								while (<$fh>) {
									my $pk = $_;
									$pk =~ s/://g;
									$pk = lc $pk;
									chomp $pk;
									### $pk
									### $cl_cert_f
									if ($pk eq $cl_cert_f) {
										close $fh
											or warn "$vhost: $file: $ERRNO";
										return 0;
									}
								}
								close $fh
									or warn "$vhost: $file: $ERRNO";
							}
						}
					}

					### $req
					if ($cert_req->{$key}[1]) {
						return 1, $cert_req->{$key}[1];
					}
					else {
						return 1;
					}
				}
				# must be string, hopefully 'any'
				elsif ($cert_req->{$key} eq 'any') {
					if (defined $cl_cert) {
						return 0;
					}
					else {
						return 1;
					}
				}
				else {
					serr("'$vhost': certs: when not an array, it must be 'any'.");
					return 1;
				}
				### fall back to require certificate, the regex *DID* match.
				return 1, 'System Error';
			}
		}
	}
	return;
}

sub check_cgi {
	my ($doc_loc, $vhost) = @_;
	# '.cgi' should be a user defined array
	if (not -x $doc_loc or substr($doc_loc, -3, 4) eq '.cgi') {
		### not -x or ending in '.cgi'.
		return 0;
	}

	if (exists $config->{$vhost}{cgi_enabled}) {
		if ($config->{$vhost}{cgi_enabled} eq 'true') {
			return 1;
		}
	}
	elsif (exists $config->{default}{cgi_enabled}) {
 		if ($config->{default}{cgi_enabled} eq 'true') {
			return 1;
		}
	}
	### not cgi_enabled
	return;
}

sub do_cgi {
	my ($doc_loc, $path, $cl) = @_;
	$cl_cert ? (local $ENV{'AUTH_TYPE'} = 'cl_cert') : (local $ENV{'AUTH_CERT'} = '');
	local $ENV{'CONTENT_LENGTH'} = undef;
	local $ENV{'CONTENT_TYPE'} = undef;
	local $ENV{'GATEWAY_INTERFACE'} = 'CGI/1.1';
	local $ENV{'PATH_INFO'} = $doc_loc;
	local $ENV{'PATH_TRANSLATED'} = $path;
	local $ENV{'QUERY_STRING'} = ''; # to do - how to get 10 <meta> ?
	local $ENV{'REMOTE_ADDR'} = $cl->peerhost(); ## will NOT work with UNIX
	local $ENV{'REMOTE_HOST'} = '';
	local $ENV{'REMOTE_IDENT'} = undef;
	local $ENV{'REMOTE_USER'} = $cl_cert;
	local $ENV{'REQUEST_METHOD'} = '';
	local $ENV{'SCRIPT_NAME'} = $doc_loc;
	local $ENV{'SERVER_NAME'} = $cl->get_servername();
	local $ENV{'SERVER_PORT'} = $DEFAULT_GEMINI_PORT; # TODO: FIX
	local $ENV{'SERVER_PROTOCOL'} = 'gemini';
	local $ENV{'SERVER_SOFTWARE'} = $PROGRAM_NAME. '('. $VERSION. ')';

	#my ($run_in, $run_out);
	my @cmd;
	push @cmd, $doc_loc;
	### @cmd
	### $doc_loc
	run3(\@cmd); #, \$run_in, \$run_out);
	# ## $run_in
	## # $run_out
}