view release on metacpan or  search on metacpan

t/basic.t  view on Meta::CPAN

#!/usr/bin/env perl
# Copyright (C) 2018–2021  Alex Schroeder <alex@gnu.org>

# This program is free software: you can redistribute it and/or modify it under
# the terms of the GNU General Public License as published by the Free Software
# Foundation, either version 3 of the License, or (at your option) any later
# version.
#
# This program is distributed in the hope that it will be useful, but WITHOUT
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License along with
# this program. If not, see <http://www.gnu.org/licenses/>.

use Modern::Perl;
use Mojo::IOLoop;
use IO::Socket::SSL;
use Test::More;
use File::Slurper qw(write_text);
use Config;

my $host = 'localhost';
my $port = Mojo::IOLoop::Server->generate_port;

my $pid = fork();

END {
  # kill server
  if ($pid) {
    kill 'KILL', $pid or warn "Could not kill server $pid";
  }
}

our $data_dir = 't';

if (!defined $pid) {
  die "Cannot fork: $!";
} elsif ($pid == 0) {
  say "This is the server listening on port $port...";
  if (not -f "t/cert.pem" or not -f "t/key.pem") {
    local $/ = undef;
    my $data = <DATA>;
    my $pos = index($data, "-----BEGIN PRIVATE KEY-----");
    write_text("t/cert.pem", substr($data, 0, $pos));
    write_text("t/key.pem", substr($data, $pos));
  }
  chdir($data_dir);
  my $perl_path = $Config{perlpath};
  exec($perl_path, "../blib/script/lupa-pona", "--host=$host", "--port=$port", "--log_level=warn")
      or die "Cannot exec: $!";
}

sub query_gemini {
  my $query = shift;
  my $socket = IO::Socket::SSL->new(
    PeerHost => $host,
    PeerService => $port,
    SSL_verify_mode => SSL_VERIFY_NONE)
      or die "Cannot construct client socket: $@";
  print $socket "$query\r\n";
  undef $/; # slurp
  return <$socket>;
}

my $total = 0;
my $ok = 0;

# What I'm seeing is that $@ is the empty string and $! is "Connection refused"
# even though I thought $@ would be set. Oh well.
say "This is the client waiting for the server to start on port $port...";
for (qw(1 1 1 1 2 2 3 4 5)) {
  if (not $total or $!) {
    diag "$!: waiting ${_}s..." if $total > 0;
    $total += $_;
    sleep $_;
    eval { query_gemini("gemini://$host:$port/") };
  } else {
    $ok = 1;
    last;
  }
}

die "$!: giving up after ${total}s\n" unless $ok;

my $page = query_gemini("gemini://$host:$port/");
like($page, qr"^20 text/gemini; charset=UTF-8\r\n", "Gemini header");
like($page, qr/Welcome to Lupa Pona!/, "Title");
like($page, qr/=> basic\.t/, "basic.t");
like($page, qr/=> test\.gmi/, "test.gmi");
like($page, qr/=> test\.txt/, "test.txt");
is(scalar(() = $page =~ m/=>/g), 3, "three links");

$page = query_gemini("gemini://$host:$port/basic.t");
# the MIME type can be application/x-perl or text/troff, depending on the system
# the test runs on…
like($page, qr"^20 (application/x-perl|text/(troff|gemini); charset=UTF-8)\r\n", "File header");
like($page, qr"GNU General Public License", "File content");

$page = query_gemini("gemini://$host:$port/test.txt");
like($page, qr"^20 text/plain; charset=UTF-8\r\n", "File header");
like($page, qr"Alex Schröder", "File content");

$page = query_gemini("gemini://$host:$port/test.gmi");
like($page, qr"^20 text/gemini; charset=UTF-8\r\n", "File header");
like($page, qr"Hallo", "File content");

$page = query_gemini("gemini://$host:$port/cert.pem");
like($page, qr"^50 ", "Do not serve cert.pem");

$page = query_gemini("gemini://127.0.0.1:$port/");
like($page, qr"^53 ", "Do not proxy");

done_testing();

__DATA__