diff options
| -rwxr-xr-x | gmi.pl | 290 |
1 files changed, 214 insertions, 76 deletions
@@ -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]; +} |