File Coverage

blib/lib/Net/Gemini.pm

Criterion	Covered	Total	%
statement	110	133	82.7
branch	35	58	60.3
condition	10	14	71.4
subroutine	22	24	91.6
pod	11	11	100.0
total	188	240	78.3

# -*- Perl -*-
#
# a Gemini protocol client
#
#   "The conjunction of Jupiter with one of the stars of Gemini, which
#   'we ourselves have seen' (1.6.343b30) has been dated in recent years
#   to December 337 BC."
#    -- Malcolm Wilson. Structure and Method in Aristotle's Meteorologica.

# NOTE this silently accepts URI with userinfo; those probably
# should be failed?
#
# KLUGE this may break if the URI module ever gets URI/gemini.pm
package URI::gemini {
    use URI;
    use parent 'URI::_server';
    sub default_port { 1965 }
    sub userinfo     { return undef }    # gemini has no userinfo
    sub secure       { 1 }

    sub canonical {
        my $self  = shift;
        my $other = $self->SUPER::canonical;
        $self->SUPER::userinfo(undef);    # gemini has no userinfo

        my $slash_path =
             defined( $other->authority )
          && !length( $other->path )
          && !defined( $other->query );

        if ($slash_path) {
            $other = $other->clone if $other == $self;
            $other->path("/");
        }
        $other;
    }
}

package Net::Gemini;
our $VERSION = '0.06';
use strict;
use warnings;
use Encode ();
use IO::Socket::SSL;
use Net::SSLeay;

sub _DEFAULT_BUFSIZE () { 4096 }

sub code    { $_[0]{_code} }      # 0..6 response code
sub content { $_[0]{_buf} }
sub error   { $_[0]{_error} }     # error message for 0 code
sub host    { $_[0]{_host} }
sub meta    { $_[0]{_meta} }
sub port    { $_[0]{_port} }
sub socket  { $_[0]{_socket} }
sub status  { $_[0]{_status} }    # two digit '1x', '2x', ... response code
sub uri     { $_[0]{_uri} }

# see VERIFICATION below; the caller should supply a custom callback.
# the default is thus "Trust On Almost Any Use" (TOAAU) or similar to
# what gg(1) of gmid does
sub _verify_ssl { 1 }

# minimal method to get a resource (see also ->request)
sub get {
    my ( $class, $source, %param ) = @_;
    my %obj;
    unless ( defined $source ) {
        @obj{qw(_code _error)} = ( 0, "source is not defined" );
        goto BLESSING;
    }

    $obj{_uri} = URI->new($source);
    unless ( $obj{_uri}->scheme eq 'gemini' ) {
        @obj{qw(_code _error)} = ( 0, "could not parse '$source'" );
        goto BLESSING;
    }
    @obj{qw/_host _port/} = ( $obj{_uri}->host, $obj{_uri}->port );

    my $yuri = $obj{_uri}->canonical;
    if ( length $yuri > 1024 ) {
        @obj{qw(_code _error)} = ( 0, "URI is too long" );
        goto BLESSING;
    }

    # VERIFICATION is based on the following though much remains up to
    # the caller to manage
    # gemini://makeworld.space/gemlog/2020-07-03-tofu-rec.gmi
    # gemini://alexschroeder.ch/page/2020-07-20%20Does%20a%20Gemini%20certificate%20need%20a%20Common%20Name%20matching%20the%20domain%3F
    eval {
        $obj{_socket} = IO::Socket::SSL->new(
            SSL_hostname        => $obj{_host},    # SNI
			( $param{tofu} ? ( SSL_verifycn_scheme => 'none' ) : () ),
            SSL_verify_callback => sub {
                my ( $ok, $ctx_store, $certname, $error, $cert, $depth ) = @_;
                if ( $depth != 0 ) {
                    return 1 if $param{tofu};
                    return $ok;
                }
                ( $param{verify_ssl} || \&_verify_ssl )->(
                    @obj{qw(_host _port)},
                    Net::SSLeay::X509_get_fingerprint( $cert, 'sha256' ),
                    Net::SSLeay::P_ASN1_TIME_get_isotime( Net::SSLeay::X509_get_notBefore($cert) ),
                    Net::SSLeay::P_ASN1_TIME_get_isotime( Net::SSLeay::X509_get_notAfter($cert) ),
                    $ok,
                    $cert
                );
            },
            ( exists $param{ssl} ? %{ $param{ssl} } : () ),
            PeerHost => $obj{_host},
            PeerPort => $obj{_port},
        ) or die $!;
        1;
    } or do {
        @obj{qw(_code _error)} = ( 0, "IO::Socket::SSL failed: $@" );
        goto BLESSING;
    };

    binmode $obj{_socket}, ':raw';

    my $n = syswrite $obj{_socket}, "$yuri\r\n";
    unless ( defined $n ) {
        @obj{qw(_code _error)} = ( 0, "send URI failed: $!" );
        goto BLESSING;
    }
    # KLUGE we're done with the connection as a writer at this point,
    # but IO::Socket::SSL does not appear to offer a public means to
    # only call shutdown and nothing else. using this is a bit risky
    # should the IO::Socket::SSL internals change
    Net::SSLeay::shutdown( ${ *{ $obj{_socket} } }{'_SSL_object'} )
      if $param{early_shutdown};

    # get the STATUS SPACE header response (and, probably, more)
    $obj{_buf} = '';
    while (1) {
        my $n = sysread $obj{_socket}, my $buf, $param{bufsize} || _DEFAULT_BUFSIZE;
        unless ( defined $n ) {
            @obj{qw(_code _error)} = ( 0, "recv response failed: $!" );
            goto BLESSING;
        }
        if ( $n == 0 ) {
            @obj{qw(_code _error)} = ( 0, "recv EOF" );
            goto BLESSING;
        }
        $obj{_buf} .= $buf;
        last if length $obj{_buf} >= 3;
    }
    if ( $obj{_buf} =~ m/^(([1-6])[0-9])[ ]/ ) {
        @obj{qw(_status _code)} = ( $1, $2 );
        substr $obj{_buf}, 0, 3, '';
    } else {
        @obj{qw(_code _error)} =
          ( 0, "invalid response " . sprintf "%vx", substr $obj{_buf}, 0, 3 );
        goto BLESSING;
    }

    # META -- at most 1024 characters, followed by \r\n. the loop is in
    # the event the server is being naughty and trickling bytes in one
    # by one (probably you will want a timeout somewhere, or an async
    # version of this code)
    my $bufsize = $param{bufsize} || _DEFAULT_BUFSIZE;
    while (1) {
        if ( $obj{_buf} =~ m/^(.{0,1024}?)\r\n/ ) {
            $obj{_meta} = $1;
            my $len = length $obj{_meta};
            if ( $len == 0 ) {
                # special case mentioned in the specification
                $obj{_meta} = 'text/gemini; charset=utf-8';
            } else {
                eval {
                    $obj{_meta} = Encode::decode( 'UTF-8', $obj{_meta}, Encode::FB_CROAK );
                    1;
                } or do {
                    @obj{qw(_code _error)} = ( 0, "failed to decode meta: $@" );
                    goto BLESSING;
                };
                substr $obj{_buf}, 0, $len + 2, '';    # +2 for the \r\n
            }
            last;
        } else {
            my $len = length $obj{_buf};
            if ( $len > 1024 ) {
                @obj{qw(_code _error)} = ( 0, "meta is too long" );
                goto BLESSING;
            }
            my $buf;
            my $n = sysread $obj{_socket}, $buf, $bufsize;
            unless ( defined $n ) {
                @obj{qw(_code _error)} = ( 0, "recv response failed: $!" );
                goto BLESSING;
            }
            if ( $n == 0 ) {
                @obj{qw(_code _error)} = ( 0, "recv EOF" );
                goto BLESSING;
            }
            $obj{_buf} .= $buf;
        }
    }

  BLESSING:
    close $obj{_socket} if defined $obj{_socket} and $obj{_code} != 2;
    bless( \%obj, $class ), $obj{_code};
}

# drain what remains (if anything) via a callback interface. assumes
# that a ->get call has been made
sub getmore {
    my ( $self, $callback, %param ) = @_;

    my $len = length $self->{_buf};
    if ($len) {
        $callback->( $self->{_buf}, $len ) or return;
    }

    my $bufsize = $param{bufsize} || 4096;
    while (1) {
        my $buf;
        $len = sysread $self->{_socket}, $buf, $bufsize;
        if ( !defined $len ) {
            die "sysread failed: $!\n";
        } elsif ( $len == 0 ) {
            last;
        }
        $callback->( $buf, $len ) or return;
    }
    close $self->{_socket};
}

1;
__END__