File Coverage

blib/lib/Net/Gemini.pm

Criterion	Covered	Total	%
statement	170	199	85.4
branch	69	96	71.8
condition	20	25	80.0
subroutine	31	31	100.0
pod	14	14	100.0
total	304	365	83.2

# -*- 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.08';
use strict;
use warnings;
use Digest::SHA 'sha256_hex';
use Encode ();
use Exporter 'import';
use IO::Socket::IP;
use IO::Socket::SSL;
use Net::SSLeay;
use Parse::MIME 'parse_mime_type';

our @EXPORT_OK = qw(gemini_request);

sub _DEFAULT_BUFSIZE ()        { 4096 }
sub _DEFAULT_MAX_CONTENT ()    { 2097152 }
sub _DEFAULT_REDIRECTS ()      { 5 }
sub _DEFAULT_REDIRECT_SLEEP () { 1 }

sub code { $_[0]{_code} }    # 0..6 response code

sub content {
    $_[0]{_content};
}                            # NOTE only after certain calls and codes
sub error  { $_[0]{_error} } # error message for 0 code
sub host   { $_[0]{_host} }
sub ip     { $_[0]{_ip} }
sub meta   { $_[0]{_meta} }
sub mime   { $_[0]{_mime} }  # NOTE only after certain calls and codes
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::IP->new(
            PeerAddr => $obj{_host},
            PeerPort => $obj{_port},
            Proto    => 'tcp'
        ) or die $!;
        $obj{_ip} = $obj{_socket}->peerhost;
        IO::Socket::SSL->start_SSL(
            $obj{_socket},
            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;
                }
                my $digest = ( $param{verify_ssl} || \&_verify_ssl )->(
                    {   host   => $obj{_host},
                        port   => $obj{_port},
                        cert   => $cert,         # warning, memory address!
                                                 # compatible with certID function of amfora
                        digest =>
                          uc( sha256_hex( Net::SSLeay::X509_get_X509_PUBKEY($cert) ) ),
                        ip        => $obj{_ip},
                        notBefore => Net::SSLeay::P_ASN1_TIME_get_isotime(
                            Net::SSLeay::X509_get_notBefore($cert)
                        ),
                        notAfter => Net::SSLeay::P_ASN1_TIME_get_isotime(
                            Net::SSLeay::X509_get_notAfter($cert)
                        ),
                        okay => $ok,
                    }
                );
            },
            ( exists $param{ssl} ? %{ $param{ssl} } : () ),
        ) 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;
    }

    # 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;
    }
    # NOTE this is sloppy; there are fewer "full two digit status codes"
    # defined in the appendix, e.g. only 10, 11, 20, 30, 31, 40, ...
    # on the other hand, this supports any new extensions to the
    # existing numbers
    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' if $obj{_code} == 2;
            } 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;
                };
                # another special case (RFC 2045 says that these things
                # are not case sensitive, hence the (?i) despite the
                # gemini specification saying "text/")
                if (    $obj{_code} == 2
                    and $obj{_meta} =~ m{^(?i)text/}
                    and $obj{_meta} !~ m/(?i)charset=/ ) {
                    $obj{_meta} .= ';charset=utf-8';
                }
            }
            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};
}

# utility function that handles redirects and various means of content
# collection
sub gemini_request {
    my ( $source, %options ) = @_;
    $options{max_redirects} = _DEFAULT_REDIRECTS
      unless exists $options{max_redirects};
    $options{redirect_delay} = _DEFAULT_REDIRECT_SLEEP
      unless exists $options{redirect_delay};
    $options{max_size} = _DEFAULT_MAX_CONTENT
      unless exists $options{max_size};

    my ( $gem, $code );
    my $redirects = 0;
  REQUEST:
    ( $gem, $code ) = Net::Gemini->get( $source,
        ( exists $options{param} ? %{ $options{param} } : () ) );
    if ( $code == 2 ) {
        my $len     = length $gem->{_buf};
        my $bufsize = $options{bufsize} || _DEFAULT_BUFSIZE;
        # this can make uninit noise for a meta of ";" which might be
        # worth an upstream patch?
        $gem->{_mime} = [ parse_mime_type( $gem->meta ) ];
        if ( exists $options{content_callback} ) {
            if ($len) {
                $options{content_callback}->( $gem->{_buf}, $len, $gem )
                  or goto CLEANUP;
            }
            while (1) {
                my $buf;
                $len = sysread $gem->{_socket}, $buf, $bufsize;
                if ( !defined $len ) {
                    die "sysread failed: $!\n";
                } elsif ( $len == 0 ) {
                    last;
                }
                $options{content_callback}->( $buf, $len, $gem ) or goto CLEANUP;
            }
        } else {
            if ($len) {
                if ( $len > $options{max_size} ) {
                    $gem->{_content} = substr $gem->{_buf}, 0, $options{max_size};
                    @{$gem}{qw(_code _error)} = ( 0, 'max_size' );
                    goto CLEANUP;
                }
                $gem->{_content} = $gem->{_buf};
                $options{max_size} -= $len;
            }
            while (1) {
                my $buf;
                $len = sysread $gem->{_socket}, $buf, $bufsize;
                if ( !defined $len ) {
                    die "sysread failed: $!\n";
                } elsif ( $len == 0 ) {
                    last;
                }
                if ( $len > $options{max_size} ) {
                    $gem->{_content} .= substr $buf, 0, $options{max_size};
                    @{$gem}{qw(_code _error)} = ( 0, 'max_size' );
                    goto CLEANUP;
                }
                $gem->{_content} .= $buf;
                $options{max_size} -= $len;
            }
        }
    } elsif ( $code == 3 and ++$redirects <= $options{max_redirects} ) {
        # a '31' permanent redirect should result in us not requesting
        # the old URL again, but that would require more code here for
        # something that is probably rare
        my $new = $gem->{_meta};
        $source = URI->new_abs( $new, $gem->{_uri} );
        select( undef, undef, undef, $options{redirect_delay} );
        goto REQUEST;
    }
  CLEANUP:
    undef $gem->{_buf};
    close $gem->{_socket};
    return $gem, $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;
        undef $self->{_buf};
    }

    my $bufsize = $param{bufsize} || _DEFAULT_BUFSIZE;
    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__