diff options
Diffstat (limited to 'gmi.pl')
| -rwxr-xr-x | gmi.pl | 625 |
1 files changed, 595 insertions, 30 deletions
@@ -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; + } + +} |