Add redirection via config

Uses String::Substituion

Let program know about new config parameters

Bump version

1 files changed, 81 insertions, 5 deletions

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;
+}