path: root/gmi.pl

#!/usr/bin/perl

# this is a gemini client

use strict;
use warnings;
#use diagnostics;
use utf8;
use bytes;
use feature qw(refaliasing);
no warnings qw(experimental::refaliasing);

our $VERSION = 'v0.0.15';

# TODO: 
# back() only works once; should fix this

# Modules
use IO::Socket::SSL;									  # CPAN
use URL::XS qw(parse_url split_url_path parse_url_query); # CPAN
use IO::Pager;											  # CPAN
require Text::Wrapper;									  # CPAN
use Term::ReadKey;										  # CPAN
use Term::ANSIColor;									  # Core
use Path::Naive qw(normalize_path);						  # CPAN
use Smart::Comments;									  # CPAN

my $wrapper = Text::Wrapper->new(columns=>70, body_start=>'');
$ENV{pager} = 'less';
my $use_pager = 1;
my $pager_text_wrap_auto = 1;
my $doc_out = 1; # display doc for human consumption?
my $doc;
my @links;
my $current_url = "";
my @history;
my $prompt = "$current_url> ";

my %commands = (
	'url' => [sub { url($_[0],0) }, 'Go to the specified URL.'],
	'u' => [sub { url($_[0],0) }, 'Alias of `url\''],
	
	'urlrelative' => [sub { url($_[0],1) }, "Navigate the current URL relatively.\n\n"
		."Note: if the current path is '/blog/my-post1.gmi' and 'my-post2.gmi'\n" .
		"was supplied then the resulting path will be: 'blog/my-post1.gmi/my-post2.gmi'\n" .
		"which is probably not what you want; in that case use '../my-post2.gmi'.\n\n" .
		"The very end of the path is treated like a directory which can be confusing."],
	'ur' => [sub { url($_[0],1) }, 'Alias of `urlrelative\''],

	'cwu' => [sub { cwu() }, 'Returns the current working URL.'],
	'c' => [sub { cwu() }, 'Alias of `cwu\'.'],

	'links' => [sub { links() }, 'Returns the links on the current page.'],
	'l' => [sub { links() }, 'Alias of `links\'.'],

	'nav' => [sub { nav(0, $_[0]) }, 'Navigate to a link that is on the current page (use links)'],
	'n' => [sub { nav(0, $_[0]) }, 'Alias of `nav\'.'],

	'navh' => [sub { nav(1, $_[0]) }, 'Navigate to a URL specified from history (use hist)'],
	'nh' => [sub { nav(1, $_[0]) }, 'Alias of `navh\'.'],

	'root' => [sub { root() }, 'Go to the root of the current URL.\n' .
		'Exp: gemini://capsule.com/blog/2020112.gmi -> gemini://capsule.com/' ],

	'hist' => [sub { hist() }, 'Returns history.' ],
	'h' => [sub { hist() }, 'Alias of `hist\'.' ],

	'back' => [sub { back(0) }, 'Go back in history.' ],
	'b' => [sub { back(0) }, 'Alias of `back\'.' ],

	'backnodisplay' => [sub { back(1) }, 'Go back in history but do not display the page' .
		'(still accesses the resource).' ],
	'bd' => [sub { back(1) }, 'Alias of `backnodisplay\'.'],

	'display' => [sub { display() }, 'Display the current page.' ],
	'd' => [sub { display() }, 'Alias of `display\'.' ],

	'aaa' => [sub { aaa() }, "This command returns `aaa'." ],
	'usepager' => [sub { toggle('pager') }, 'This toggles pager use. 1 = use pager, 0 = stdout.' ],
	'textwrap' => [sub { textwrap($_[0]) }, 'Set textwrap length.\nGiving \'auto\' will ' .
		"automatically determine the appropriate length. (Currently $wrapper->{columns})"],
	'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)"],
	'exit' => [sub {exit 0;}, "This exits the program with a status code of 0."],
);

print "Type 'cmds' to see available commands.\n";
while () {

	$prompt = "$current_url> ";
	print "$prompt";
	chomp(my $input = <STDIN>);

	# ## $input
	if ($input) {
		my ($command, $detail) = split(/\s/, $input);
		do_command(\$command, \$detail);
	}
}

sub do_command {
	# referenced command, referenced detail 
	my ($rCmd, $rDetail) = @_; 

	# ## @_
	# checking if %commands even has the command
	if (exists $commands{$$rCmd}) {

		# assigning a reference to a subroutine to the value
		my $rsub = $commands{$$rCmd}[0];

		#running the subroutine
		&$rsub($$rDetail);
	}
	# options doesn't have the command
	else {
		print "Command is invalid.\n";
	}	
}

sub help {
	my ($cmd) = @_;
	### @_
	if ($cmd and exists $commands{$cmd}) {
		print "$commands{$cmd}[1]\n";
	} elsif ($cmd) {
		print "`$cmd' isn't an avaliable command.\n";
	}
	else {
		print "$commands{help}[1]\n"
	}
}

sub url {
	# technically 'gemini://john/blog/thing.gmi' can be a valid url
	# where 'john' is the host
	# which makes determining relative movements a pain
	#
	# mode 0 = 'john' can be a host, 1 = 'john' is actually relative movement
	my ($url, $mode) = @_;
	### $url
	if (!$url) { print("Example: [gemini://]capsule.com/\n"); return 1;}
	if ( $url !~ m|^.*://.*|) {
		$url = "gemini://$url";
	}
	$url = parse_url($url);
	### $url
	
	# relative movement
	if ($mode eq 1) {
		if (!$current_url) {print "Relative movement impossible: no current URL.\n"; return 1;}
		my $c_url = parse_url($current_url);

		if ($url->{path}) {
			$url->{path} = "$url->{host}/$url->{path}";
		}
		else {
			delete($url->{path}); # DO NOT DELETE THIS LINE (P)
			$url->{path} = "$url->{host}"; 
		}
		$url->{host} = $c_url->{host};
		$url->{port} = $c_url->{port};

		my $cp_url = split_url_path($c_url->{path}, 256);
		$c_url->{path} = '';

		#if ( $url->{path} =~ m|\.\.| or $url->{path} =~ m|^\./?|) {
		#	pop(@$cp_url);
		#}
		for (@$cp_url) {
			$c_url->{path} .= "$_/"
		}

		$c_url->{path} = "/$c_url->{path}/$url->{path}"; # adding first / for normalize_path
		$c_url->{path} = normalize_path($c_url->{path});
		substr($c_url->{path}, 0, 1, ''); # removing the first /
		$url->{path} = $c_url->{path};
	}

	### $url
	if (! $url->{port} or $url->{port} eq 0) {
		$url->{port} = '1965';
	}
	
	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',
	); 

	if ($cl) {
		my $path;
		if (! $url->{path}) {
			$path = '' 
		}
		else {
			$path = "$url->{path}";
		}
		
		#$current_url = "$url->{scheme}://$url->{host}/$path";
		$current_url = return_url($url);
		### $current_url
		### $url

		# ["absolute_url", "description"]
		#update_history( ["$url->{scheme}://$url->{host}/$path", "$url->{host}/$path"] );
		update_history( ["$current_url", ""] );
	
		# gemini spec: <URL><CR><LF>
		# <URL> is an absolute path
		print $cl "$url->{scheme}://$url->{host}/$path\r\n";
	
		undef($doc);

		while (<$cl>) {
			$doc .= $_;
		}
		
		get_links($doc);
	
		if ($doc_out) {
			display($doc);
		}
	}
	else {
		print("error=$!, ssl_error=$SSL_ERROR\n");
	}
}

sub return_url {
	#my ($scheme, $username, $password, $host, $port, $path, $query, $fragment) = @_;
	my ($url) = @_;
	my $url_string;
	### @_
	if (ref($url) ne 'HASH') { # assuming string
		if ($url !~ m|.*://|) {
			$url =~ s|(.*)|gemini://$1|;
		}
		$url = parse_url($url);
	}
	my $scheme = $url->{scheme};
	my $username = $url->{username};
	my $password = $url->{password};
	my $host = $url->{host};
	my $port = $url->{port};
	my $path = $url->{path};
	my $query = $url->{query};
	my $fragment = $url->{fragment};
	
	# 'https://peter:bro@localhost:8989/some/path/to/resource?q1=yes&q2=no&q3=maybe#frag=1';
	# a valid url ^^
	if (! $scheme) {
		$url_string .= "gemini://";
	} 
	else {
		$url_string .= "$scheme://";
	}
	if ($username and $password) {
		$url_string .= "$username:$password@";
	} elsif ($username) {
		$url_string .= "$username@";
	}
	$url_string .= "$host" if ($host);
	if ($port and $port ne 1965) {
		$url_string .= ":$port";
	}
	$url_string .= "/";
	$url_string .= "$path" if ($path);
	$url_string .= "?$query" if ($query);
	$url_string .= "#$fragment" if ($fragment);

	#$url = "$host/$path/$url";
	#$url = normalize_path($url);
	#$url = "$scheme://$url";
	# ## $c_url;
	return $url_string;
}

sub get_links {
	undef(@links);
	my ($doc) = @_;
	for my $line (split('\n', $doc)) {
		if ($line =~ m/^=>[\s]*([\w\d\-\\\/\.\:\~\?\=\#]+)[\s]*(.+)?$/gm) {
			if ($2) {
				push(@links, ["$1", "$2"]);
			}
			else {
				push(@links, ["$1", "$1"]);
			}
		}
	}
	## @links
}

sub hist {
	my $hist;
	my $counter = 1;
	for my $item (@history) {
		$hist .= "[$counter] ". colored("$$item[0]", 'underline') ." $$item[1]\n";
		$counter++;
	}
	if ($hist) {
		print($hist);
	}
	else {
		print("\n");
	}
}

sub update_history {
	my ($history) = @_;
	push(@history, $history);
}

sub links {
	my $d;
	my $counter = 1;
	for my $item (@links) {
		$d .= "[$counter] ". colored($$item[0], 'underline') . " $$item[1]\n";
		$counter++;
	}
	if ($d) {
		print($d);
	}
	else {
		print("No links.\n");
	}
	0;
}

sub cwu {
	print("$current_url\n");
	0;
}

sub nav {
	# Setting 0: from links
	# Setting 1: from history
	my ($setting,$n) = @_;
	### $n
	### $setting
	### @_
	if (! $n or $n !~ /\d+/) {
		print("Try 'links' or 'hist' then 'nav x', where x is the number.\n");
		return 1;
	}
	$n -= 1;

	my $link;

	if ($setting == 0 and @links) {
		$link = $links[$n][0];
	} elsif ($setting == 1 and @history) {
		$link = $history[$n][0];
	}
	else {
		print("'$n' isn't available.\n");
		return 1;
	}

	# This implies it is valid fqdn
	if (has_scheme($link)) {
		url("$link");
	}
	else {
		my $c_url = parse_url($current_url);
		# relative navigation madness
		# ../../blog/my-post.gmi
		if ($link =~ m|\.{1,2}/.*|) {
			my $parsed_url_path = split_url_path($c_url->{path}, 256);
			my $url_path;

			# request doc will be different
			pop(@$parsed_url_path);
			for (@$parsed_url_path) {
				$url_path .= "/$_";
			}
			substr($url_path, 0, 1, ''); # removing the first /
			### $url_path
			### $link
			$c_url->{path} = normalize_path("$url_path/$link");

			#url("$new_url->{scheme}://$new_url->{host}$path");
			url(return_url($c_url));
		}
		# normal navigation of current domain, probably something like:
		# blog/my-post.gmi
		else {
			#url("$new_url->{scheme}://$new_url->{host}/$link");
			$c_url->{path} = "$link";
			url(return_url($c_url));
		}
	}
}

sub has_scheme {
	return ($_[0] =~ m|^.*(://)|);
}

sub root {
	my $new_url = parse_url($current_url);
	url("$new_url->{scheme}://$new_url->{host}/");
}

sub back {
	my ($display) = @_;

	### @_
	### $display
	my $dok_out = $doc_out;

	$doc_out = 0 if ($display == 1);

	url("$history[-2][0]");
	### @history

	$doc_out = $dok_out if ($display == 1);
}

sub aaa {
	print("aaa\n");
}

sub display {
	if ($pager_text_wrap_auto) {
		my ($wc) = GetTerminalSize();
		$wrapper->columns($wc);
	}
	if ($use_pager) {
		IO::Pager::open(my $FH) or warn($!);
		print $FH $wrapper->wrap($doc);
	}
	else { 
		print($wrapper->wrap($doc));
	}
}

sub toggle {
	my ($t) = @_;
	if ($t eq 'pager') {
		set_toggle($use_pager);
		print "$use_pager\n";
	}
}

sub set_toggle {
	# refaliasing
	\my $t = \$_[0];
	if ($t == 1) {
		$t = 0;
	}
	else {
		$t = 1;
	}
}

sub textwrap {
	my ($c) = @_;
	if ($c and $c =~ m/^\d+$/) {
		$wrapper->columns($c);
		$pager_text_wrap_auto = 0;
	} elsif ($c and $c eq 'auto') {
		$pager_text_wrap_auto = 1;
	}
	else {
		if ($pager_text_wrap_auto) {
			my ($c) = GetTerminalSize();
			print("[AUTO] $c\n");
		}
		else {
			print("$wrapper->{columns}\n");
		}
	}
}

sub pager {
	my ($p) = @_;
	if ($p) {
		$ENV{pager} = $p;
		0;
	}
	else {
		print("$ENV{pager}\n");
	}
}

sub cmds {
	my $c;
	for (sort keys %commands) {
		$c .= "$_  ";
	}
	print $wrapper->wrap($c);
}