File Coverage

blib/lib/Net/Gemini/Server.pm

Criterion	Covered	Total	%
statement	49	55	89.0
branch	15	22	68.1
condition			n/a
subroutine	10	10	100.0
pod	5	5	100.0
total	79	92	85.8

# -*- Perl -*-
#
# a Gemini protocol server, mostly to test the Net::Gemini client with
#
#   "They are great warriors: their greatness is like the empty desert
#   wastes. They are both the lords of the River, the River of the
#   Ordeal which clears the just man. They weigh upon the evil man like
#   a neck-stock. In Kisiga, their very anciently founded city, the
#   trustworthy does not get caught, but the evil cannot pass through."

package Net::Gemini::Server;
our $VERSION = '0.08';
use strict;
use warnings;
# the below code mostly cargo culted from example/ssl_server.pl
use IO::Socket::IP;
use IO::Socket::SSL;

DESTROY { undef $_[0]{_context}; undef $_[0]{_socket} }

sub new {
    my ( $class, %param ) = @_;
    $param{listen}{LocalPort} = 1965
      unless defined $param{listen}{LocalPort};
    my %obj;
    $obj{_socket} = IO::Socket::IP->new(
        Listen => 5,
        Reuse  => 1,
        %{ $param{listen} },
    ) or die "server failed: $!";
    # server default is not to perform any verification
    $obj{_context} =
      IO::Socket::SSL::SSL_Context->new( %{ $param{context} },
        SSL_server => 1, )
      or die "context failed: $SSL_ERROR";
    $obj{_port} = $obj{_socket}->sockport;
    bless \%obj, $class;
}

sub context { $_[0]{_context} }
sub port    { $_[0]{_port} }
sub socket  { $_[0]{_socket} }

# this, as noted elsewhere, is mostly for testing the client
sub withforks {
    my ( $self, $callback, %param ) = @_;
    my $server = $self->{_socket};
    while (1) {
        my $client = $server->accept or do {
            warn "accept failed: $!\n";
            next;
        };
        if ( $param{close_on_accept} ) {
            close $client;
            next;
        }
        my $parent = fork;
        die "fork failed: $!" unless defined $parent;
        if ($parent) {
            close $client;
            next;
        }
        unless ( $param{no_ssl} ) {
            unless (
                IO::Socket::SSL->start_SSL(
                    $client,
                    SSL_server    => 1,
                    SSL_reuse_ctx => $self->{_context}
                )
            ) {
                warn "ssl handshake failed: $SSL_ERROR\n";
                close $client;
                exit;
            }
        }
        if ( $param{close_before_read} ) {
            close $client;
            exit;
        }
        binmode $client, ':raw';
        # NOTE this assumes the client isn't sending bytes one by one slow
        my $n = sysread( $client, my $buf, 1024 );
        # does not suss out any new client edge cases
        #if ( $param{close_after_read} ) {
        #    close $client;
        #    exit;
        #}
        eval {
            # NOTE the buffer is raw bytes and may need a decode
            $callback->( $client, $n, $buf );
            1;
        } or do {
            # KLUGE random stderr from a fork can confuse TAP and get
            # the tests out of sequence?
            #warn "callback error: $@";
            close $client;
        };
        exit;
    }
}

1;
__END__