#!/usr/bin/perl # this is a gemini server use strict; use warnings; use 5.010; #use diagnostics; our $VERSION = 'v0.0.10'; # 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/; 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 $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; 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"; 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(\$cl) and next; my $clhost = $cl->peerhost(); my $clport = $cl->peerport(); my $cl_sni = $cl->get_servername(); my $url; my $path; my $data; # We do this because 'naughty' people/bots can clog up the ports doing nothing. local $SIG{ALRM} = sub { timeout($cl, $clhost, $cl_sni) }; alarm 5; # TODO make magic number not magic. if (! sysread $cl, $data, $KBYTE) { $log = "$clhost - ($cl_sni) sysread failed"; alarm 0; goto CLOSE; } alarm 0; # removing \r\n substr $data, -2, 2, ''; # 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; } 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); 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'); say "$log [". localtime(). ']'; exit if ($fork_toggled); } $srv->close(); 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 in ' 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 = ( LocalAddr => '0.0.0.0', LocalPort => $DEFAULT_GEMINI_PORT, Listen => 10, SSL_version => '!SSLv2:!SSLv3:!TLSv1:!TLSv1_1', SSL_fast_shutdown => 1, Timeout => 2, SSL_error_trap => 1, #SSL_server => 1, ); for my $item (keys %{ $conf_ref->{default} }) { if ($item eq 'bind') { $ssl{LocalAddr} = $conf_ref->{default}{bind}; #say $conf_ref->{default}{bind}; } elsif ($item eq 'ports') { for my $port ( @{ $conf_ref->{default}{ports} } ) { # TODO; enable more than one port. $ssl{LocalPort} = $conf_ref->{default}{ports}[0]; #say $conf_ref->{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{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 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 timeout { my ($cl, $clhost, $cl_sni) = @_; # TODO: user log format say "$clhost - ($cl_sni) timed-out [". localtime() . ']'; $cl->close('SHUT_WR'); exit if ($fork_toggled); return; } sub maybe_fork { my ($cl_ref) = @_; my $pid = fork; if (not defined $pid) { warn "Cannot make a child: $ERRNO"; } if ($pid) { undef $cl_ref; return 1; } else { local $PROGRAM_NAME = "chld: $PROGRAM_NAME"; return 0; } } 1;