oddmuse/t/gemini-server.t

# Copyright (C) 2017–2020  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/>.

package OddMuse;
use strict;
use 5.10.0;
use Test::More;
use IO::Socket::SSL;
use utf8; # tests contain UTF-8 characters and it matters
use Modern::Perl;
use XML::RSS;
use XML::LibXML;

require './t/test.pl';
require './stuff/gemini-server.pl';

add_module('tags.pl');

# enable uploads and filtering by language
our($ConfigFile);
AppendStringToFile($ConfigFile, <<'EOT');
$UploadAllowed = 1;
%Languages = (
  'de' => '\b(der|die|das|und|oder)\b',
  'en' => '\b(i|he|she|it|we|they|this|that|a|is|was)\b', );
EOT

# enable comments
our($CommentsPrefix);
$CommentsPrefix = 'Comments_on_';
AppendStringToFile($ConfigFile, "\$CommentsPrefix = 'Comments_on_';\n");
AppendStringToFile($ConfigFile, "\@QuestionaskerQuestions = (['Who rules in Rivendell?' => sub { shift =~ /^Elrond/i }]);\n");

# write a gemini-only extension
our($DataDir);
WriteStringToFile("$DataDir/gemini_config", <<'EOT');
package OddMuse;
use Modern::Perl;
our (@extensions, @main_menu_links);
push(@extensions, \&serve_cert);
sub serve_cert {
  my $self = shift;
  my $url = shift;
  my $selector = shift;
  my $base = $self->base();
  if ($selector =~ m!^do/test!) {
    say "20 text/plain\r";
    say "Test";
    return 1;
  }
  return;
}
1;
EOT

my $host = "127.0.0.1";
my $port = random_port();
my $pid = fork();

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

if (!defined $pid) {
  die "Cannot fork: $!";
} elsif ($pid == 0) {
  use Config;
  my $secure_perl_path = $Config{perlpath};
  exec($secure_perl_path,
       "stuff/gemini-server.pl",
       "--host=$host",
       "--port=$port",
       "--wiki_cert_file=t/cert.pem",
       "--wiki_key_file=t/key.pem",
       "--log_level=0", # set to 4 for verbose logging
       "--wiki=./wiki.pl",
       "--wiki_dir=$DataDir",
       "--wiki_pages=Alex",
       "--wiki_pages=Berta",
       "--wiki_pages=Chris")
      or die "Cannot exec: $!";
}

# Sorting
is(sub{$a="Alex"; $b="Berta"; newest_first()}->(), -1, "Alex before Berta");
is(sub{$a="Alex"; $b="Comments_on_Alex"; newest_first()}->(), -1, "Alex before Comments_on_Alex");
is(sub{$a="Chris"; $b="Comments_on_Alex"; newest_first()}->(), 1, "Chris after Comments_on_A");
is(sub{$a="Image_1_for_Alex"; $b="Image_10_for_Alex"; newest_first()}->(), -1, "Image_1_for_Alex before Image_10_for_Alex");
is(sub{$a="Comments_on_Alex"; $b="Image_1_for_Alex"; newest_first()}->(), -1, "Comments_on_Alex before Image_1_for_Alex");
is(join(" ", sort newest_first qw(Alex Berta Chris)), "Alex Berta Chris", "Sort alphabetically");
is(join(" ", sort newest_first qw(2017-12-25 2017-12-26 2017-12-27)), "2017-12-27 2017-12-26 2017-12-25", "Sort by date descending");
is(join(" ", sort newest_first qw(Alex Comments_on_Alex Berta Chris)), "Alex Comments_on_Alex Berta Chris", "Comments after pages");
is(join(" ", sort newest_first qw(2017-12-25 2017-12-26 Comments_on_2017-12-26 2017-12-27)), "2017-12-27 2017-12-26 Comments_on_2017-12-26 2017-12-25", "Comments after date pages");
is(join(" ", sort newest_first qw(Alex Comments_on_Alex Image_1_for_Alex Image_2_for_Alex Image_10_for_Alex Berta Chris)), "Alex Comments_on_Alex Image_1_for_Alex Image_2_for_Alex Image_10_for_Alex Berta Chris", "Images sorted numerically");

update_page('Alex', "My best friend is [[Berta]].\n\nTags: [[tag:Friends]]\n");
update_page('Berta', "This is me.\n\nTags: [[tag:Friends]]\n");
update_page('Chris', "I'm Chris.\n\nTags: [[tag:Friends]]\n");
update_page('Friends', "Some friends.\n");
update_page('2017-12-25', 'It was a Monday.\n\nTags: [[tag:Day]]');
update_page('2017-12-26', 'It was a Tuesday.\n\nTags: [[tag:Day]]');
update_page('2017-12-27', 'It was a Wednesday.\n\nTags: [[tag:Day]]');
update_page('Friends', "News about friends.\n", 'rewrite', 1); # minor change
update_page('Friends', "News about friends:\n\n<journal search tag:friends>\n",
	    'add journal tag', 1); # minor change

# file created using convert NULL: test.png && base64 test.png
update_page('Picture',
	    "#FILE image/png\niVBORw0KGgoAAAANSUhEUgAAAAEAAAABAQAAAAA3bv"
	    . "kkAAAACklEQVQI12NoAAAAggCB3UNq9AAAAABJRU5ErkJggg==");

sub query_gemini {
  my $query = shift;
  my $text = shift;

  # create client
  my $socket = IO::Socket::SSL->new(
    PeerHost => "localhost",
    PeerService => $port,
    SSL_cert_file => 'cert.pem',
    SSL_key_file => 'key.pem',
    SSL_verify_mode => SSL_VERIFY_NONE)
      or die "Cannot construct client socket: $@";

  $socket->print("$query\r\n");
  $socket->print($text);

  undef $/; # slurp
  return <$socket>;
}

my $base = "gemini://$host:$port";

# main menu
my $page = query_gemini("$base/");

for my $item(qw(Alex Berta Chris 2017-12-25 2017-12-26 2017-12-27)) {
  like($page, qr/^=> $base\/$item $item/m, "main menu contains $item");
}

unlike($page, qr/^=> .*\/$/m, "No empty links in the menu");

$page = query_gemini("$base/Alex");

like($page, qr/^My best friend is Berta\.$/m, "Local free link (text)");
like($page, qr/=> $base\/Berta Berta$/m, "Local free link (link)");
like($page, qr/^Tags:$/m, "Tags footer");
like($page, qr/^Tags:$/m, "Tags footer");
like($page, qr/=> $base\/tag\/Friends Friends$/m, "Tag link");
like($page, qr/^=> $base\/raw\/Alex Raw text$/m, "Raw text link");
like($page, qr/^=> $base\/history\/Alex History$/m, "History");
like($page, qr/^=> $base\/Comments_on_Alex Comments on this page$/m, "Comment link");

# language tag
$page = query_gemini("$base\/2017-12-25");
like($page, qr/^20 text\/gemini; charset=UTF-8; lang=en\r\n/, "Result 20 with MIME type and language");

# plain text
$page = query_gemini("$base\/raw\/Alex");
like($page, qr/^My best friend is \[\[Berta\]\]\.$/m, "Raw text");

# history
$page = query_gemini("$base/history/Friends");
like($page, qr/^=> $base\/Friends\/1 Friends \(1\)/m, "Revision 1 is listed");
like($page, qr/^=> $base\/Friends\/2 Friends \(2\)/m, "Revision 2 is listed");
like($page, qr/^=> $base\/diff\/Friends\/1 Diff between revision 1 and the current one/m, "Diff 1 link");
like($page, qr/^=> $base\/diff\/Friends\/2 Diff between revision 2 and the current one/m, "Diff 2 link");
like($page, qr/^=> $base\/Friends Friends \(current\)/m, "Current revision is listed");
$page = query_gemini("$base/Friends/1");
like($page, qr/^Some friends\.$/m, "Revision 1 content");
$page = query_gemini("$base/Friends/2");
like($page, qr/^News about friends\.$/m, "Revision 2 content");

#diffs
$page = query_gemini("$base/diff/Friends/1");
like($page, qr/^< Some friends\.\n-+\n> News about friends:\n> \n> <journal search tag:friends>\n$/m, "Diff 1 content");
$page = query_gemini("$base/diff/Friends/2");
like($page, qr/^< News about friends\.\n-+\n> News about friends:\n> \n> <journal search tag:friends>\n$/m, "Diff 1 content");

# tags
$page = query_gemini("$base\/tag\/Friends");
like($page, qr/^This page is about the tag Friends\.$/m, "tag menu intro");
for my $item(qw(Friends Alex Berta Chris)) {
  like($page, qr/^=> $base\/$item $item$/m, "tag menu contains $item");
}

# tags
$page = query_gemini("$base\/tag\/Day");
like($page, qr/2017-12-27.*2017-12-26.*2017-12-25/s,
     "tag menu sorted newest first");

# match
$page = query_gemini("$base\/do/match?2017");
for my $item(qw(2017-12-25 2017-12-26 2017-12-27)) {
  like($page, qr/^=> $base\/$item $item$/m, "match menu contains $item");
}
like($page, qr/2017-12-27.*2017-12-26.*2017-12-25/s,
     "match menu sorted newest first");

# search
$page = query_gemini("$base\/do/search?tag:day");
for my $item(qw(2017-12-25 2017-12-26 2017-12-27)) {
  like($page, qr/^=> $base\/$item $item/m, "search menu contains $item");
}
like($page, qr/2017-12-27.*2017-12-26.*2017-12-25/s,
     "search menu sorted newest first");

# rc
$page = query_gemini("$base\/do/rc");
my $re = join(".*", "Picture", "2017-12-27", "2017-12-26", "2017-12-25",
	      "Friends", "Chris", "Berta", "Alex");
like($page, qr/$re/s, "rc in the right order");

$page = query_gemini("$base\/do/rc/minor");

$re = join(".*", "Friends", "2017-12-27", "2017-12-26", "2017-12-25");
like($page, qr/$re/s, "minor rc in the right order");

# feeds
my $xpc = XML::LibXML::XPathContext->new;
$xpc->registerNs('atom', 'http://www.w3.org/2005/Atom');

# rss with regular pages
my $feed = new XML::RSS;
$page = query_gemini("$base\/do/rss");
ok($page =~ s!^20 application/rss\+xml\r\n!!, "RSS header OK");
ok($feed->parse($page), "RSS parse OK");
for my $item(qw(Alex Berta Chris 2017-12-25 2017-12-26 2017-12-27)) {
  ok(grep(/$item/, map { $_->{title} } @{$feed->{items}}), "$item found in RSS feed");
}

# atom with regular pages
$page = query_gemini("$base\/do/atom");
ok($page =~ s!^20 application/atom\+xml\r\n!!, "Atom header OK");
# $feed->parse($page) results in warnings that I can't get rid of
ok(my $doc = XML::LibXML->load_xml(string => $page), "Atom parse OK");
for my $item(qw(Alex Berta Chris 2017-12-25 2017-12-26 2017-12-27)) {
  ok($xpc->find("//atom:entry/atom:title[text()='$item']", $doc), "$item found in Atom feed");
}

add_module('journal-rss.pl');

# rss with just the journal
$page = query_gemini("$base\/do/rss");
ok($page =~ s!^20 application/rss\+xml\r\n!!, "RSS header OK");
ok($feed->parse($page), "RSS parse OK");
for my $item(qw(2017-12-25 2017-12-26 2017-12-27)) {
  ok(grep(/$item/, map { $_->{title} } @{$feed->{items}}), "$item found in RSS feed");
}
for my $item(qw(Alex Berta Chris)) {
  ok(!grep(/$item/, map { $_->{title} } @{$feed->{items}}), "$item not found in RSS feed");
}
my ($sec, $min, $hour, $mday, $mon, $year, $wday) = localtime;
$year += 1900;
# Fri, 19 Jun 2020 20:41:55 GMT
my $today = sprintf("%s, %02d %s %d",
		    qw(Sun Mon Tue Wed Thu Fri Sat)[$wday], $mday,
		    qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec)[$mon], $year);
like($page, qr!<pubDate>$today \d\d:\d\d:\d\d GMT</pubDate>!, "Update timestamp for today");

# atom with just the journal
$page = query_gemini("$base\/do/atom");
ok($page =~ s!^20 application/atom\+xml\r\n!!, "Atom header OK");
# $feed->parse($page) results in warnings that I can't get rid of
ok($doc = XML::LibXML->load_xml(string => $page), "Atom parse OK");
for my $item(qw(2017-12-25 2017-12-26 2017-12-27)) {
  ok($xpc->find("//atom:entry/atom:title[text()='$item']", $doc), "$item found in Atom feed");
}
for my $item(qw(Alex Berta Chris)) {
  ok(!$xpc->find("//atom:entry/atom:title[text()='$item']", $doc), "$item not found in Atom feed");
}
$today = sprintf("%d-%02d-%02d", $year, $mon+1, $mday);
like($page, qr!<updated>${today}T\d\d:\d\d:\d\dZ</updated>!, "Update timestamp for today");

# upload text

my $titan = "titan://$host:$port";

my $haiku = <<EOT;
Quiet disk ratling
Keyboard clicking, then it stops.
Rain falls and I think
EOT

$page = query_gemini("$titan/raw/Haiku;size=76;mime=text/plain", $haiku);
like($page, qr/^30 $base\/Haiku\r$/, "Titan Haiku");

my $haiku_re = $haiku;
$haiku_re =~ s/\s+/ /g; # lines get wrapped
$haiku_re =~ s/\s+$//g;
$haiku_re = quotemeta($haiku_re);
$page = query_gemini("$base/Haiku");
like($page, qr/^$haiku_re/m, "Haiku saved");

# comment

like($page, qr/^=> $base\/Comments_on_Haiku Comments on this page$/m, "Comment page link");

$page = query_gemini("$base/Comments_on_Haiku");
like($page, qr/^=> $base\/do\/comment\/Comments_on_Haiku Leave a comment$/m, "Leave comment link");

$page = query_gemini("$base/do/comment/Comments_on_Haiku");
like($page, qr/^30 $base\/do\/comment\/Comments_on_Haiku\/0\r$/, "Redirect to a question");

$page = query_gemini("$base/do/comment/Comments_on_Haiku/0");
like($page, qr/^10 Who rules in Rivendell\?\r$/, "Ask security question");

$page = query_gemini("$base/do/comment/Comments_on_Haiku/0?elrond");
like($page, qr/^30 $base\/do\/comment\/Comments_on_Haiku\/0\/elrond\r$/, "Redirect to comment prompt");

$page = query_gemini("$base/do/comment/Comments_on_Haiku/0/elrond");
like($page, qr/^10 Comment\r$/, "Ask for comment");

$page = query_gemini("$base/do/comment/Comments_on_Haiku/0/elrond?Give%20me%20the%20ring!");
like($page, qr/^30 $base\/Comments_on_Haiku\r$/, "Redirect back to the main page");

$page = query_gemini("$base/Comments_on_Haiku");
like($page, qr/^Give me the ring!\n\n-- Anonymous/m, "Comment saved");

# extension

$page = query_gemini("$base/do/test");
like($page, qr/^Test\n/m, "Extension runs");

done_testing();