Add redirection via config

Uses String::Substituion

Let program know about new config parameters

Bump version

3 files changed, 103 insertions, 8 deletions

diff --git a/TO_FIX.md b/TO_FIX.md
index b610871..8ebd90d 100644
--- a/TO_FIX.md
+++ b/TO_FIX.md
@@ -20,6 +20,4 @@ check if loaded cert/keys are actually valid
 
 check values for keys in config file
 
-redirection via config
-
 handle signals like interrupt better
diff --git a/config.toml.sample b/config.toml.sample
index cdbe8bf..3f22149 100644
--- a/config.toml.sample
+++ b/config.toml.sample
@@ -51,6 +51,11 @@ assume_index = true
 dir_listing = false 
 # otherwise the fallback is 'application/octet-stream' (gemini is primary text based so 'octet-stream' probably not wanted)
 default_mime = 'text/plain' 
+# redirection allows this program to check for vhost redirect values.
+# 'no' meaning, no redirection.
+# 'simple', which is simply "if 'x' key exist, return the value for it"
+# 'regex' which is a bit more complex and uses Perl's built in regualar expression. See the vhost for an example of one.
+redirection = 'simple'
 
 ### Not implimented yet
 # similar to .htaccess, .gmiaccess
@@ -75,7 +80,7 @@ assume_index = true
 # bind can be set to a string or a list or 'no' which will not be accessible via IP address.
 #bind = ['172.16.0.53', '10.43.14.32']
 #ports = [10000,10001,10002]
-# example.com can only be accesed through this socket, other vhost
+# example.com can only be accesed through this socket, other vhost can use it too.
 # unix can be set to some path or to 'no' which will not include it in default's unix path if it is set.
 #unix = '/some/other/path/to/unix.sock'
 #auto_cert = false
@@ -91,3 +96,19 @@ assume_index = true
 #assume_index = true
 #dir_listing = true
 #default_mime = 'text/plain'
+#
+#redirection = 'regex'
+#redirect = {
+#    # note the beginning '/'. 
+#    # The regex is complied like so: qr{^...$} (^ = beginning of line, $ = end of line)
+#    # In other words, the entire key value MUST match.
+#    # this one would be a simple redirection
+#    '/redirect' = 'gemini://my-other-example.com',
+#
+#    # these are Perl's regular expression.
+#    '/share/some_(.*)' = "/share/",
+#    #               $1
+#    '/blog/2022/dec/(.+)' = '/blog/2022/jul/$1',
+#    #      $1     $2   $3 
+#    '/blog/(20..)/(.+)/(.+)' = '/newsgroup/$1-$2/$3',
+#  }
diff --git a/gmi.pl b/gmi.pl
index b0ef88b..4ab8b3f 100755
--- a/gmi.pl
+++ b/gmi.pl
@@ -7,7 +7,7 @@ use warnings;
 use 5.010;
 #use diagnostics;
 
-our $VERSION = 'v0.15.2';
+our $VERSION = 'v0.16.1';
 
 # Modules
 use IO::Socket::SSL; # CPAN
@@ -27,6 +27,7 @@ use File::Type;
 use English qw( -no_match_vars );
 use Const::Fast;
 use Carp;
+use String::Substitution qw( gsub_modify );
 
 #$IO::Socket::SSL::DEBUG = 15;
 
@@ -63,10 +64,10 @@ const our %GEM_RES_CODES => (
 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/;
+	unix redirection redirect/;
 const our @VALID_VHOST_SETTINGS =>
 	qw/auto_cert assume_index dir_listing root cert key default_mime bind ports
-	unix/;
+	unix redirection redirect/;
 
 my ($config, $err) = from_toml(_slurp('./config.toml'));
 if ($err) {
@@ -223,6 +224,15 @@ while (my @ready = $sel->can_read) {
 sub respond_to_client {
 	my ($cl, $vhost, $doc_loc, $path) = @_;
 
+	my $redirection = redirection_parameter($vhost);
+	if ($redirection) {
+		my $redirect = check_for_config_redirection($vhost, $path, $redirection);
+		if ($redirect) {
+			speak($cl, 'redirect', $redirect);
+			goto CLOSE;
+		}
+	}
+
 	if (not $doc_loc = get_request_in_vhost_root($vhost, $path)) {
 		goto FAILURE;
 	}
@@ -1003,12 +1013,78 @@ sub select_add_listen {
 		## no critic (DoubleSigil)
 		if (exists $lsn->{LocalAddr}) {
 			$sell->add(IO::Socket::IP->new(%$lsn))
-				or die "$ERRNO";
+				or die "$ERRNO ($lsn->{LocalAddr}:$lsn->{LocalPort})";
 		}
 		elsif (exists $lsn->{Local}) {
 			$sell->add(IO::Socket::UNIX->new(%$lsn))
-				or die "$ERRNO";
+				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 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;
+}