status codes matter, reload, remove cmds(), split nav() for access_resource() so server redirection (3x) can occur without duplicate code

1 files changed, 214 insertions, 76 deletions

diff --git a/gmi.pl b/gmi.pl
index 69281ae..e9db282 100755
--- a/gmi.pl
+++ b/gmi.pl
@@ -6,11 +6,11 @@ use strict;
 use warnings;
 #use diagnostics;
 use utf8;
-use bytes;
+#use bytes;
 use feature qw(refaliasing);
 no warnings qw(experimental::refaliasing);
 
-our $VERSION = 'v0.0.23';
+our $VERSION = 'v0.0.24';
 
 # TODO: 
 # back() only works once; should fix this
@@ -25,7 +25,10 @@ use Term::ANSIColor;									  # Core
 use Path::Naive qw(normalize_path);						  # CPAN
 use Text::ParseWords;                                     # Core
 use Term::ReadLine;										  # CPAN
-#use Smart::Comments;									  # CPAN
+use Smart::Comments;									  # CPAN
+use URI::Encode qw(uri_encode); # CPAN
+
+# sudo cpanm IO::Socket::SSL URL::XS IO::Pager Text::Wraper Term::ReadKey Path::Naive  Text::ParseWords Term::ReadLine Smart::Comments URI::Encode
 
 my $wrapper = Text::Wrapper->new(columns=>70, body_start=>'');
 #$ENV{PAGER} = 'most';
@@ -42,7 +45,16 @@ my $prompt = "";
 my $pretty_links = 1;
 my $pretty_headers = 1;
 my $pre_block = 0;
-my $status_code;
+my @status_code;
+my $status_code1;
+my $status_code2;
+my $auto_redirect = 2;
+my $auto_redirect_count = 0;
+my $sleep;
+my $timeout = 3;
+
+my $term=new Term::ReadLine "hmm, what goes here?";
+my $OUT = $term->OUT || \*STDOUT;
 
 my %commands = (
 	'url' => [sub { url($_[0]) }, 'Go to the specified URL.'],
@@ -60,8 +72,8 @@ my %commands = (
 		"IE: '/blog/drafts/secret/post.gmi -> '/blog/drafts/secret' -> '/blog/drafts'"],
 	'ur' => [sub { urlrelative($_[0]) }, 'Alias of `urlrelative\''],
 
-	'cwu' => [sub { print "$current_url\n"; }, 'Returns the current working URL.'],
-	'c' => [sub { print "$current_url\n"; }, 'Alias of `cwu\'.'],
+	'cwu' => [sub { print $OUT "$current_url\n"; }, 'Returns the current working URL.'],
+	'c' => [sub { print $OUT "$current_url\n"; }, 'Alias of `cwu\'.'],
 
 	'links' => [sub { links() }, 'Returns the links on the current page.'],
 	'l' => [sub { links() }, 'Alias of `links\'.'],
@@ -91,19 +103,26 @@ my %commands = (
 	'usepager' => [sub { toggle($use_pager) }, 'This toggles pager use. 1 = use pager, 0 = stdout.' ],
 	'pretty_links' => [sub { toggle($pretty_links) }, "0 = do nothing, 1 = pretty. Currently $pretty_links."],
 	'pretty_headers' => [sub { toggle($pretty_headers) }, "0 = do nothing, 1 = pretty. Currently $pretty_headers."],
-	'textwrap' => [sub { textwrap($_[0]) }, 'Set textwrap length.\nGiving \'auto\' will ' .
-		"automatically determine the appropriate length. (Currently $wrapper->{columns})"],
+	'textwrap' => [sub { textwrap($_[0]) }, "Set textwrap length.\nGiving 'auto' will " .
+		"automatically determine the appropriate length."],
 	'pager' => [sub { pager($_[0]) }, "Set which pager to use. (currently $ENV{PAGER})"],
 	'save' => [sub { ; }, 'Save the config settings. (Not yet implimented)'],
 	'help' => [sub { help($_[0]); }, 'Use help before a command to get extra info. (cmds to see commands)'],
-	'cmds' => [sub {cmds()}, 'Returns the available commands.'],
-	'ver' => [sub {print "$VERSION\n"}, "Returns the version ($VERSION)"],
+	'ver' => [sub {print $OUT "$VERSION\n"}, "Returns the version ($VERSION)"],
 	'exit' => [sub {exit 0;}, "This exits the program with a status code of 0."],
+
+	'autoredirection' => [sub { value_number($auto_redirect,$_[0],'autoredirect') }, "The amount of times this program is allowed to auto redirect. 0 = none."],
+	'timeout' => [sub { value_number($timeout,$_[0],'timeout') },
+		"The client will time out when the server takes too long." ],
+
+	'clearquery' => [sub { clear_query() }, "Removes query from current URL"],
+	'cq' => [sub { clear_query() }, "Alias of `clearquery'"],
+
+	'reload' => [sub {url($current_url)}, "Reload the current URL."],
+	'r' => [sub {url($current_url)}, "Alias of `reload'."],
 );
 
-my $term=new Term::ReadLine "hmm, what goes here?";
 my @completions = keys %commands;
-my $OUT = $term->OUT || \*STDOUT;
 
 $term->Attribs->{'do_expand'}=1;
 $term->Attribs->{'completion_entry_function'} = $term->Attribs->{'list_completion_function'};
@@ -112,7 +131,7 @@ $term->ornaments(0);
 
 $prompt = "$current_url > ";
 
-print "Press <tab><tab> to see available commands.\n";
+print $OUT "Press <tab><tab> to see available commands.\n";
 while ( defined ($_ = $term->readline($prompt)) ) {
 	if ($_) {
 		my ($command, $detail) = split(/\s/, $_);
@@ -137,7 +156,7 @@ sub do_command {
 	}
 	# options doesn't have the command
 	else {
-		print "Command is invalid.\n";
+		print $OUT "Command is invalid.\n";
 	}	
 }
 
@@ -145,12 +164,12 @@ sub help {
 	my ($cmd) = @_;
 	### @_
 	if ($cmd and exists $commands{$cmd}) {
-		print "$commands{$cmd}[1]\n";
+		print $OUT "$commands{$cmd}[1]\n";
 	} elsif ($cmd) {
-		print "`$cmd' isn't an avaliable command.\n";
+		print $OUT "`$cmd' isn't an avaliable command.\n";
 	}
 	else {
-		print "$commands{help}[1]\n"
+		print $OUT "$commands{help}[1]\n"
 	}
 }
 
@@ -162,7 +181,13 @@ sub url {
 		$url = "gemini://$url";
 	}
 	 
-	$url = parse_url($url);
+	eval {
+		$url = parse_url($url);
+	};
+	if ($@) {
+		print $OUT "$@\n";
+		return 1;
+	}
 
 	### $url
 	if (! $url->{port} or $url->{port} eq 0) {
@@ -172,9 +197,11 @@ sub url {
 	my $cl = IO::Socket::SSL->new(
 		PeerHost => "$url->{host}",
 		PeerPort => "$url->{port}",
-	
+
 		SSL_verify_mode => SSL_VERIFY_NONE,
 		SSL_version => '!SSLv2:!SSLv3:!TLSv1:!TLSv1_1',
+
+		Timeout => 2,
 	);
 
 	if ($cl) {
@@ -182,51 +209,156 @@ sub url {
 		### $current_url
 		### $url
 
-	
-		# gemini spec: <URL><CR><LF>
-		# <URL> is an absolute path
-		print $cl "$current_url\r\n";
-	
-		#undef($doc);
 		undef(@doc);
-
-		@doc = <$cl>;
-
-		# ["absolute_url", "description"]
-		update_history( ["$current_url", ""] );
 	
-		if (determine_status_code()) {
-			get_links();
+		eval {
+			local $SIG{ALRM} = sub {close ($cl); unshift(@doc,""); die "TIMEOUT";};
+			alarm $timeout;
+
+			# gemini spec: <URL><CR><LF>
+			# <URL> is an absolute path
+			print $cl "$current_url\r\n";
+
+			@doc = <$cl>;
+			# ["absolute_url", "description"]
+
+			alarm 0;
+		};
+
+		if ($@) {
+			print $OUT "Timed out after $timeout seconds - server is taking too long.\n";
+			update_history( ["$current_url", "timed out"] );
+			### @doc
+		} else {
+			follow_status_code();
+		}
+	}
+	else {
+		print $OUT "error=$!, ssl_error=$SSL_ERROR\n";
+	}
+}
 
+sub follow_status_code {
+	return 1 if (!@doc);
+	@status_code = split(' ', $doc[0]);
+	$status_code1 = substr($doc[0],0,1);
+	$status_code2 = substr($doc[0],1,1);
+	update_history( ["$current_url", "$status_code1$status_code2"] );
+	my $bad_code = "The server sent an invalid status code, not defined by gemini specifications.\n@doc";
+
+	if ($status_code1 == 2) { # 2 will probably be the most common server reply
+		if ($status_code2 == 0) {
+			shift(@doc); # user probably doesn't want to see the 20 */* every time
+			             # at some point deal with image/* and other media
+			get_links();
 			pretty_links() if ($pretty_links);
 			pretty_headers() if ($pretty_headers);
-	
+
 			if ($doc_out) {
 				display();
 			}
 		}
-	}
-	else {
-		print("error=$!, ssl_error=$SSL_ERROR\n");
-	}
-}
+		else {
+			print $OUT $bad_code;
+		}
 
-sub determine_status_code {
-	$status_code = substr($doc[0],0,1);
-	if ($status_code == 2) {
-		return 1;
+	} elsif ($status_code1 == 1) {
+		if ($status_code2 == 0) {
+			print $OUT "Server wants you to type something:\n@doc";
+		} elsif ($status_code2 == 1) {
+			print $OUT "Server wants you to type something secretly (do note: not secure):\n@doc";
+			ReadMode 2;
+		} else {
+			print $bad_code;
+			print $OUT "\nPresumably, the server wants you to type something:\n";
+		}
+		chomp(my $input = <STDIN>);
+		$input = uri_encode($input);
+		ReadMode 1;
+		url("$current_url?$input");
+
+	} elsif ($status_code1 == 3) { 
+		print $bad_code if ($status_code2 !~ m/^0|1$/); # not worrying about permanent/temporary yet
+		print $OUT "Redirecting anyway.\n" if ($status_code2 !~ m/^0|1$/);
+		if ($auto_redirect) {
+			$auto_redirect_count++;
+			if ($auto_redirect_count < $auto_redirect) {
+				print $OUT "Redirection...\n";
+				### @status_code
+				access_resource($status_code[1]); # redirection can be './hello.gmi'
+			}
+			else {
+				print $OUT "Reached limit for auto redirection.\n@doc";
+			}
+		}
+		else {
+			print $OUT "The server wants to redirect us, however, autoredirect has turned off.\n@doc";
+		}
+		$auto_redirect_count = 0;
+
+	} elsif ($status_code1 == 4) {
+		if ($status_code2 == 0) {
+			print $OUT "Temporary failure.\n@doc";
+		} elsif  ($status_code2 == 1) {
+			print $OUT "Server is unavailable (yet somehow sent a reply to us).\n@doc";
+		} elsif ($status_code2 == 2) {
+			print $OUT "Server's CGI script is broken.\n@doc";
+		} elsif ($status_code2 == 3) {
+			print $OUT "Server was unable to proxy content.\n@doc";
+		} elsif ($status_code2 == 4) {
+			if (!$sleep) {
+				$sleep = 5;
+				print $OUT "Server wants us to slow down.\n" .
+				"Reconnecting after $sleep seconds\n" .
+				"Press 'ctrl-C' to cancel sleep\n" .
+				"@doc\n";
+				eval {
+					local $SIG{INT} = sub { die "Cancelling Sleep!\n" };
+					sleep ($sleep); # give the server an extra second
+					url($current_url);
+				}
+			}
+			else {
+				print $OUT "The server is asking us to slow down and try again after $status_code[1] seconds.\n" .
+				"We have already done this once: not doing it again.\n";
+			}
+			undef($sleep);
+		}
+		else {
+			print $bad_code;
+		}
+
+	} elsif ($status_code1 == 5) {
+		if ($status_code2 == 0) {
+			print $OUT "Permanent failure. Requests to this URI will reliably fail.\n@doc";
+		} elsif ($status_code2 == 1) {
+			print $OUT "Not found. Not available but *may* be in the future\n@doc";
+		} elsif ($status_code2 == 2) {
+			print $OUT "Gone. This resource will not be available again.\n@doc";
+		} elsif ($status_code2 == 3) {
+			print $OUT "Proxy Request Refused. Resource not served by this server and this\n" .
+			"server does not accept proxy requests.\n@doc";
+		} elsif ($status_code2 == 9) {
+			print $OUT "Bad Request. The server is unable to parse our request.\n@doc";
+		}
+		else {
+			print $bad_code;
+		}
+
+	} elsif ($status_code1 == 6) {
+		print $OUT "The sever is saying something about a cert, but this client doesn't do certs yet.\n" .
+		"For reference: 60 = Client Cert Required, 61 = Client Cert Not Authorized, 62 = Bad Cert\n@doc";
 	}
 	else {
-		print "$doc[0]";
-		return 0;
+		print $bad_code;
 	}
-	### $status_code;
+	### @status_code;
 }
 
 sub urlrelative {
 	my ($urlr) = @_;
 	if (! $urlr) { $urlr = ""}
-	if (! $current_url) {print "Relative movement impossible: no current URL.\n"; return 1;}
+	if (! $current_url) {print $OUT "Relative movement impossible: no current URL.\n"; return 1;}
 	my $end_with_slash = 1 if ($urlr =~ m|/$|);
 	my $dot_only = 1 if ($urlr =~ m|^\.$|);
 	my $dot_2_only = 1 if ($urlr =~ m|^\.\.$|); # since we are going up into a dir
@@ -362,10 +494,10 @@ sub hist {
 		$counter++;
 	}
 	if ($hist) {
-		print($hist);
+		print $OUT $hist;
 	}
 	else {
-		print("\n");
+		print $OUT "\n";
 	}
 }
 
@@ -382,10 +514,10 @@ sub links {
 		$counter++;
 	}
 	if ($d) {
-		print($d);
+		print $OUT $d;
 	}
 	else {
-		print("No links.\n");
+		print $OUT "No links.\n";
 	}
 }
 
@@ -397,7 +529,7 @@ sub nav {
 	### $setting
 	### @_
 	if (! $n or $n !~ /\d+/) {
-		print("Try 'links' or 'hist' then 'nav x', where x is the number.\n");
+		print $OUT "Try 'links' or 'hist' then 'nav x', where x is the number.\n";
 		return 1;
 	}
 	$n -= 1;
@@ -411,10 +543,14 @@ sub nav {
 	}
 	else {
 		my $m = $n+1;
-		print("'$m' isn't available.\n");
+		print $OUT "'$m' isn't available.\n";
 		return 1;
 	}
+	access_resource($link);
+}
 
+sub access_resource {
+	my ($link) = @_;
 	# This implies it is valid fqdn
 	if (has_scheme($link)) {
 		url("$link");
@@ -424,17 +560,6 @@ sub nav {
 		my $end_with_slash = 1 if ($link =~ m|.*/$|);
 		my $begin_with_slash = 1 if ($link =~ m|^/.*|);
 
-		### current url doesnt have a path ?
-#		if (! $c_url->{path}) {
-#			delete($c_url->{path});
-#			$c_url->{path} = $link;
-#			if ($begin_with_slash) {
-#				substr($c_url->{path},0,1,'');
-#			}
-#			url(return_url($c_url));
-#			return 0;
-#		}
-
 		### absolute location ?
 		if ($begin_with_slash) {
 			delete($c_url->{path});
@@ -495,7 +620,12 @@ sub back {
 
 	$doc_out = 0 if ($display == 1);
 
-	url("$history[-2][0]");
+	if (@history >= 2) {
+		url("$history[-2][0]");
+	}
+	else {
+		print $OUT "No such history there.";
+	}
 	### @history
 
 	$doc_out = $dok_out if ($display == 1);
@@ -517,7 +647,7 @@ sub display {
 	}
 	else { 
 		#print($wrapper->wrap($doc));
-		print($wrapper->wrap($doc));
+		print $OUT $wrapper->wrap($doc);
 	}
 }
 
@@ -531,7 +661,7 @@ sub toggle {
 		$t = 1;
 	}
 	if (! $_[1]) {
-		print "$t\n";
+		print $OUT "$t\n";
 	}
 }
 
@@ -565,14 +695,6 @@ sub pager {
 	}
 }
 
-sub cmds {
-	my $c;
-	for (sort keys %commands) {
-		$c .= "$_  ";
-	}
-	print $wrapper->wrap($c);
-}
-
 sub pretty_links {
 	my $counter = 1;
 	for (@doc) {
@@ -580,10 +702,10 @@ sub pretty_links {
 		if ((substr($_,0,2)) eq '=>' and not $pre_block) {
 			$_ =~ m/^=>[\s]*([\w\d\-\\\/\.\:\~\?\=\#]+)[\s]*(.+)?$/;
 			if ($2) {
-				$_ = colored("[$counter" . _is_not_scheme_gemini($1) . "]",'underline') . " $2";
+				$_ = colored("[$counter" . _is_not_scheme_gemini($1) . "]",'underline') . " $2\n";
 			}
 			else {
-				$_ = colored("[$counter" . _is_not_scheme_gemini($1) . "]",'underline') . " $1";
+				$_ = colored("[$counter" . _is_not_scheme_gemini($1) . "]",'underline') . " $1\n";
 			}
 			$counter++;
 		}
@@ -622,3 +744,19 @@ sub _pre_block {
 		toggle($pre_block,1);
 	}
 }
+
+sub value_number {
+	# refaliasing
+	\my $v = \$_[0];
+	my $numb = $_[1];
+	my $k = $_[2];
+	$v = $numb if ($numb =~ m/^\d*$/);
+	print $OUT "$k is now: $v\n";
+	### @_
+}
+
+sub clear_query {
+	return 1 if (!$current_url);
+	my @url = split('\?', $current_url);
+	$current_url = $url[1];
+}