Actually useable now

1 files changed, 595 insertions, 30 deletions

diff --git a/gmi.pl b/gmi.pl
index 36a9cd1..d55c772 100755
--- a/gmi.pl
+++ b/gmi.pl
@@ -4,43 +4,348 @@
 
 use strict;
 use warnings;
+use 5.010;
 #use diagnostics;
 
-our $VERSION = 'v0.0.1';
+our $VERSION = 'v0.0.2';
 
 # Modules
-use IO::Socket::SSL;									  # CPAN
+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 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;
 
-# sudo cpanm IO::Socket::SSL URL::XS Text::Wraper Path::Naive Term::ReadLine Smart::Comments URI::Encode
+# Program name
+$0 = 'jakes-gemini-server';
+$SIG{CHLD} = 'IGNORE';
 
-my $srv = IO::Socket::SSL->new(
-	#SSL_server => 1,
+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_cert_file => './cert.pem',
-	SSL_key_file => './key.pem',
+	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
 
-) or die "error=$!, ssl_error=$SSL_ERROR";
+my $srv = IO::Socket::SSL->new(%ssl_config) or die "error=$!, ssl_error=$SSL_ERROR";
+say $out "Server Started on ". localtime();
 
-while (1) {
-	my $cl = $srv->accept();
+# 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;
+	}
 
-	sysread($cl,my $data,1024);
+	#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;
+	};
 
-	print "Connection from $clhost:$clport - $data";
 	my $url;
 	my $path;
 	substr($data,-2,2,''); # removing \r\n
@@ -48,26 +353,286 @@ while (1) {
 		$url = parse_url($data);
 	};
 	$path = $url->{path};
-	my $doc;
 	### $data
 	### $url
-	### $path
-	if ($path) {
-		# Note: this will serve ANYTHING including /etc/passwd and other sensitive files
-		open (my $FH ,'<', "./$path") or syswrite($cl,"51 Not Found\r\n") and $cl->close('SHUT_WR') and next;
-		while (<$FH>) {
-			$doc .= $_;
+	# ## $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;
 		}
-		close ($FH);
 
-		syswrite($cl,"20 text/gemini\r\n$doc",0);
-	} 
-	else {
-		syswrite($cl,"50 Failure\r\n");
-		$cl->close('SHUT_WR');
-	} 
+		# 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 DOC_ASSIGNED;
+		}
+		else {
+			goto FAILURE;
+		}
+	}
+
+	DOC_ASSIGNED:
+	my $meta = $ft->checktype_contents($doc);
+	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';
+		}
+		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);
+	goto CLOSE;
+
+	FAILURE:
+	speak($cl, 'failure') or print $out "No file handle?";
+	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;
+}
+
+sub speak {
+	my ($cl, $header, $meta, $doc) = @_;
+	### $meta
+	my $head = gem_code($header, $meta);
+	$log .= " $head";
+	if ($doc) {
+		syswrite($cl, "$head\r\n");
+		print $cl $doc; 
+	}
+	else {
+		syswrite($cl, "$head\r\n");
+	}
+}
+
+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;
+	}
+
+}