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.3b';

# 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 Term::ANSIColor; # Core
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;

# Program name
$0 = 'jakes-gemini-server';
$SIG{CHLD} = 'IGNORE';

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",
);

our @VALID_DEFAULT_SETTINGS = 
	qw/bind ports tls assume_index dir_listing root root_relative working_dir cert_key_dir 
	log_file log_to_stdout default_mime/;
our @VALID_VHOST_SETTINGS = 
	qw/auto_cert assume_index dir_listing root root_relative cert key default_mime/;

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

my ($config, $err) = from_toml(_slurp("./config.toml")); 
if ($err) {
	warn "TOML config error: $err.\nWill (try to) listen on 'localhost:1965'"; 
	$config = {
		default => {
			assume_index => 'true',
			dir_listing => 'false',
			bind => '0.0.0.0',
			ports => [ 1965 ],
			tls => ['v1.2', 'v1.3'],
			root => "default_root",
			default_mime => 'text/plain',
			log_2_stdout => 'true',
		},
		localhost => {
			auto_cert => 'true',
		}
	}
}
### $config

# Hard coded SSL defaults
my %ssl_config = (
	LocalAddr => '0.0.0.0',
	LocalPort => 1965,
	Listen => 10,

	SSL_version => '!SSLv2:!SSLv3:!TLSv1:!TLSv1_1',

	SSL_fast_shutdown => 1,
	Timeout => 2,
	SSL_error_trap => 1,
	#SSL_server => 1,
);

# Override hard coded defaults for SSL stuff
for my $item (keys %{ $config->{default} }) {
	if ($item eq 'working_dir') {
		;
	}
	elsif ($item eq 'bind') {
		$ssl_config{LocalAddr} = $config->{default}{bind};
		#say $config->{default}{bind};
	}
	elsif ($item eq 'ports') {
		for my $port ( @{ $config->{default}{ports} } ) {
			# TODO; enable more than one port.
			$ssl_config{LocalPort} = $config->{default}{ports}[0];
			#say $config->{default}{ports}[0];
		}
	}
	elsif ($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_config{SSL_version} = '!SSLv2:!SSLv3:!TLSv1:!TLSv1_1:!TLSv1_2:!TLSv1_3';

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

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

my $cert_key_dir;
if (exists $config->{default}{cert_key_dir}) {
	# Absolute
	if (substr($config->{default}{cert_key_dir},0,1) eq '/') {
		$cert_key_dir = $config->{default}{cert_key_dir};
	}
	# Relative
	else {
		$cert_key_dir = "$working_dir/$config->{default}{cert_key_dir}";
	}
}
else {
	$cert_key_dir = "$working_dir/certs";
}
# Create $cert_key_dir if needed
if (-d $cert_key_dir and -r $cert_key_dir and -w $cert_key_dir and -x $cert_key_dir) {
	;
} elsif (! -e $cert_key_dir) {
	mkdir $cert_key_dir;
} else {
	die "cert_key_dir option ($cert_key_dir) is not all of these: ".
	"directory, readable, writable or executeable.";
}

# Logging
my $out;
if (exists $config->{default}{log_to_stdout} and $config->{default}{log_to_stdout} eq 'true') {
	$out = \*STDOUT;
} elsif (exists $config->{default}{log_file} and $config->{default}{log_file}) {
	open ($out, ">>", "$working_dir/$config->{default}{log_file}");
}
else {
	say STDERR "Not log option specified, logging to STDOUT.";
	$out = \*STDOUT;
}
select $out;
$| = 1; # Making the *current* Filehandle 'hot' so Perl flushes the buffer immeditally.
my $log;

# VirtualHosts
for my $item (keys %{ $config }) {
	next if ($item eq 'default');
	my $error_free = 1;
	my $cert_loc;
	my $key_loc;

	if (exists $config->{$item}{cert} and exists $config->{$item}{key}) {

		# checking if absolute location
		if (substr($config->{$item}{cert},0,1) eq '/') {
			if (-e $config->{$item}{cert}) {
				$cert_loc = $config->{$item}{cert};
			}
			else {
				say "'$config->{$item}{cert}' does not exist.";
				$error_free = 0;
			}
		}
		if (substr($config->{$item}{key},0,1) eq '/') {
			if (-e $config->{$item}{key}) {
				$key_loc = $config->{$item}{key};
			}
			else {
				say "'$config->{$item}{key}' does not exist.";
				$error_free = 0;
			}
		}

		# Is it relative?
		if (! $cert_loc or ! $key_loc) {
			if (-e "$cert_key_dir/$config->{$item}{cert}") {
				$cert_loc = "$cert_key_dir/$config->{$item}{cert}";
			} 
			else {
				say STDERR "'$cert_key_dir/$config->{$item}{cert}' does not exist.";
				$error_free = 0;
			}

			if (-e "$cert_key_dir/$config->{$item}{key}") {
				$key_loc = "$cert_key_dir/$config->{$item}{key}";
			}
			else {
				say STDERR "'$cert_key_dir/$config->{$item}{key}' does not exist.";
				$error_free = 0;
			}
		}

	}
	else {
		if (exists $config->{$item}{auto_cert} and $config->{$item}{auto_cert} ne 'false') {
			# manage cert for user
			$cert_loc = "$cert_key_dir/$item". '_cert.pem';
			$key_loc = "$cert_key_dir/$item". '_key.pem';

			if (! -e $cert_loc or ! -e $key_loc) {
				say $out "$item cert/key pair generated in '$cert_key_dir'.";
				gen_cert($item, $cert_key_dir)
			}
			else {
				# TODO: make sure cert is valid, otherwise re-generate them
			}
		}
		else {
			say STDERR "$item only has one part of a cert/key pair and/or auto_cert is not enabled.";
			$error_free = 0;
		}
	}
	
	if ($error_free) {
		$ssl_config{SSL_cert_file}{$item} = $cert_loc;
		$ssl_config{SSL_key_file}{$item} = $key_loc;
	}
	else {
		say STDERR "Will not use cert/key for $item";
	}
}

# let the user know if an invalid option was used
for my $option (keys %{ $config->{default} }) {
	my $valid = 0;
	for (@VALID_DEFAULT_SETTINGS) {
		if ($option eq $_) {
			$valid = 1;
			last;
		}
	}
	if (! $valid) {
		say STDERR "'$option' is invalid in default.";
	}
}
for my $vhost (keys %{ $config }) {
	next if ($vhost eq 'default');
	for my $option (keys %{ $config->{$vhost} }) {
		my $valid = 0;
		for (@VALID_VHOST_SETTINGS) {
			if ($option eq $_) {
				$valid = 1;
				last;
			}
		}
		if (! $valid) {
			say STDERR "'$option' is invalid in $vhost.";
		}
	}
}

### %ssl_config

my $srv = IO::Socket::SSL->new(%ssl_config) or die "error=$!, ssl_error=$SSL_ERROR";
say $out "Server Started on ". localtime();

# Main server loop
while () {
	my $cl = $srv->accept() or next;
	my $pid = fork();
	if (not defined $pid) {
		warn "Cannot make a child: $!";
		next;
	}
	if ($pid) {
		undef $cl;
		next;
	}

	#close STDIN;
	#close STDOUT;
	#close STDERR;
	#open($out, '>>', './logs');

	my $opened = $cl->opened();
	if ($opened == 1) {
		#print $out "Everything works! Wow!\n";
		;
	} elsif ($opened == -1) {
		print $out "IO::Handle opened but the SSL handshake failed.\n";
		$cl->close('SHUT_WR');
		exit;
	} elsif (! $opened) {
		print $out "Socket could not be opened.\n";
		exit;
	}
	else {
		print $out "Something is very wrong.\n";
		exit;
	}

	my $data;
	my $clhost = $cl->peerhost();
	my $clport = $cl->peerport();
	my $cl_sni = $cl->get_servername();
	
	eval {
		# We do this because 'naughty' people/bots can clog up the ports doing nothing.
		local $SIG{ALRM} = sub { 
			say $out "$clhost - ($cl_sni) timed-out [". localtime(). ']';
			$cl->close('SHUT_WR');
			exit;
		};
		alarm 5; # TODO make magic number not magic.

		if ( ! sysread($cl, $data, 1024) ) {
			$log = "$clhost - ($cl_sni) sysread failed ... Invalid certificate/key?";
			goto CLOSE;
			exit;
		}

		alarm 0;
	};

	my $url;
	my $path;
	substr($data,-2,2,''); # removing \r\n
	eval {
		$url = parse_url($data);
	};
	$path = $url->{path};
	### $data
	### $url
	# ## $path
	
	# TODO: make user adjustable
	$log = "$clhost - ($cl_sni) $data";

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

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

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

	my $cv = check_vhost_settings($vhost);
	# we already know it exists and is readable
	if (! -d $doc_loc) {
		#$doc = _slurp($doc_loc);
		goto DOC_ASSIGNED;
	}
	elsif (-d $doc_loc) {
		# make sure 'dir' is 'dir/' 
		if (substr($doc_loc,-1,1) ne '/') { 
			speak($cl, 'redirect', "$path/");
			goto CLOSE;
		}

		# if assume_index
		if (($cv == 1 or $cv == 3) and is_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) {
			#$doc = dir_listing($doc_loc, $path);
			goto DIR_LISTING;
		}
		else {
			goto FAILURE;
		}
	}

	DOC_ASSIGNED:
	#my $meta = $ft->checktype_contents($doc);
	my $meta = $ft->checktype_filename($doc_loc);
	if ($meta eq "application/octet-stream") {
		# 'text/gemini' is non-standard mime-type
		if ((substr($doc_loc, -4, 4) eq '.gmi') or (substr($doc_loc, -1, 1) eq '/' and ($cv == 2 or $cv == 3))) {
			$meta = 'text/gemini';
		}
		# Manually support webm until better magic detection is used
		elsif (substr($doc_loc, -4, 4) eq 'webm') {
			open(my $fh, '<', $doc_loc);
			my $h;
			read($fh, $h, 1*1024);
			if ($h =~ m/V_VP9/) {
				$meta = 'video/VP9';
			} elsif ($h =~ m/V_VP8/) {
				$meta = 'video/VP8';
			} else {
				$meta = 'application/octet-stream';
			}
			close $fh;
			undef($h);
		}
		elsif (exists $config->{$vhost}{default_mime}) {
			$meta = $config->{$vhost}{default_mime};
		}
		elsif (exists $config->{default}{default_mime}) {
			$meta = $config->{default}{default_mime};
		}
		### $meta
	}
	speak($cl, 'success', $meta, $doc_loc);
	goto CLOSE;

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

	FAILURE:
	speak($cl, 'failure');
	goto CLOSE;

	CLOSE:
	$cl->close('SHUT_WR');
	print $out "$log [". localtime(). "]\n";
	exit;
}

$srv->close();

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

sub dir_listing {
	my ($doc_loc, $path) = @_;
	return 0 if (! -d $doc_loc and ! -r $doc_loc);
	
	my $doc = "Dir listing for /";
	if ($path) { $doc .= "$path" };
	$doc .= "\n\n";

	opendir (my $dh, $doc_loc) or warn "$!" and return undef;
	while (my $i = readdir($dh)) {
		if (substr($i,0,1) eq '.') { # dont display hidden files
			next;
		}
		$doc .= "=> $i";
		if (-d "$doc_loc/$i") {
			$doc .= '/';
		}
		$doc .= "\n";
	}
	closedir $dh;

	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 * 3156000 + time(); # 20 years * 3156000 seconds (365 days) + time()

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

	my $old_umask = umask(077);
	PEM_cert2file($cert, $cert_loc);
	PEM_key2file($key, $key_loc);
	CERT_free($cert);
	KEY_free($key);
	umask($old_umask);
}

# return appropriate path that should be _slurp()-ed
# 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 = '';
	
	# remove '..'
	$request =~ s/\.\.//g if ($request);
		 
	$r = normalize_path($request) if ($request);

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

	# relative to working_dir
	if (exists $config->{$vhost}{root} and exists $config->{$vhost}{root_relative} and
							$config->{$vhost}{root_relative} eq 'true')
	{
		my $work_loc = "$working_dir/$config->{$vhost}{root}";
		is_exists_and_readable("$work_loc/$r") ? return "$work_loc/$r" : return undef;
	}

	# not relative to working_dir
	elsif (exists $config->{$vhost}{root} and (not exists $config->{$vhost}{root_relative} or 
						$config->{$vhost}{root_relative} eq 'false')) 
	{
		my $work_loc = "$config->{$vhost}{root}";
		is_exists_and_readable("$work_loc/$r") ? return "$work_loc/$r" : return undef;
	}

	# use default's root
	elsif (not exists $config->{$vhost}{root}) {
		my $work_loc = "$working_dir/$config->{default}{root}";
		is_exists_and_readable("$work_loc/$r") ? return "$work_loc/$r" : return undef;
	}

	else {
		warn "$vhost has improper root/root_relative settings.";
		return 0;
	}
}

sub is_exists_and_readable {
	my ($path) = @_;
	(-e $path and -r $path) ? return 1 : return 0;
}

sub gem_code {
	my ($code, @r) = @_;
	exists $GEM_RES_CODES{$code}
		or die "'$code' is an invalid Gemini Status."; 
		# ^ this actually kills child, not parent

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

# TODO: remove magic numbers
sub speak {
	my ($cl, $header, $meta, $doc_loc, $path) = @_;
	### $meta
	my $head = gem_code($header, $meta);
	$log .= " $head";
	syswrite($cl, "$head\r\n");

	if ($doc_loc) {
		if (is_exists_and_readable($doc_loc) and ! -d $doc_loc) {
			my $r;
			open (my $fh, '<', $doc_loc);
			# An SSL packet can only have about 16k bytes 
			# so, read less 16k, send it until eof
			while (sysread($fh, $r, 15*1024)) { 
				syswrite($cl, $r);
				undef($r);
			}
			close $fh;
		}
		elsif (is_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*1024, $offset)) {
				$offset += $w;
			}
		}
	}
}

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;
		}
	}
	
	if ($assume_index == 0 and $dir_listing == 0) {
		# no vhost option, lets check default setting.
		if (exists $config->{default}{assume_index} and $config->{default}{assume_index} eq 'true') {
			### default dir listing 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;
	}

}