App-phoebe

 view release on metacpan or  search on metacpan

lib/App/Phoebe.pm  view on Meta::CPAN

C<@main_menu> adds more lines to the main menu, possibly links that aren't
simply links to existing pages.

C<@footer> is a list of code references allowing you to add things like licenses
or contact information to every page; each code reference gets called with
$stream (L<Mojo::IOLoop::Stream>), $host, $space, $id, $revision, and $format
('gemini' or 'html') used to serve the page; return a gemtext string to append
at the end; the alternative is to overwrite the C<footer> or C<html_footer> subs
– the default implementation for Gemini adds History, Raw text and HTML link,
and C<@footer> to the bottom of every page; the default implementation for HTTP
just adds C<@footer> to the bottom of every page.

If you do hook into Phoebe's code, you probably want to make use of the
following variables:

C<$server> stores the command line options provided by the user.

C<$log> is how you log things.

A very simple example to add a contact mail at the bottom of every page; this
works for both Gemini and the web:

    # tested by t/example-footer.t
    use App::Phoebe::Web;
    use App::Phoebe qw(@footer);
    push(@footer, sub { '=> mailto:alex@alexschroeder.ch Mail' });

This prints a very simply footer instead of the usual footer for Gemini, as the
C<footer> function is redefined. At the same time, the C<@footer> array is still
used for the web:

    # tested by t/example-footer2.t
    package App::Phoebe;
    use App::Phoebe::Web;
    use Modern::Perl;
    our (@footer); # HTML only
    push(@footer, sub { '=> https://alexschroeder.ch/wiki/Contact Contact' });
    # footer sub is Gemini only
    no warnings qw(redefine);
    sub footer {
      return "\n" . '—' x 10 . "\n" . '=> mailto:alex@alexschroeder.ch Mail';
    }

This example shows you how to add a new route (a new path served by the wiki).
Instead of just writing "Test" to the page, you could of course run arbitrary
Perl code.

    # tested by t/example-route.t
    our @config = (<<'EOT');
    use App::Phoebe qw(@extensions @main_menu port host_regex success);
    use Modern::Perl;
    push(@main_menu, "=> /do/test Test");
    push(@extensions, \&serve_test);
    sub serve_test {
      my $stream = shift;
      my $url = shift;
      my $hosts = host_regex();
      my $port = port($stream);
      if ($url =~ m!^gemini://($hosts):$port/do/test$!) {
	success($stream, 'text/plain; charset=UTF-8');
	$stream->write("Test\n");
	return 1;
      }
      return;
    }
    EOT

This example also shows how to redefine existing code in your config file
without the warning "Subroutine … redefined".

Here's a more elaborate example to add a new action the main menu and a handler
for it, for Gemini only:

    # tested by t/example-new-action.t
    package App::Phoebe;
    use Modern::Perl;
    our (@extensions, @main_menu);
    push(@main_menu, "=> gemini://localhost/do/test Test");
    push(@extensions, \&serve_test);
    sub serve_test {
      my $stream = shift;
      my $url = shift;
      my $headers = shift;
      my $host = host_regex();
      my $port = port($stream);
      if ($url =~ m!^gemini://($host)(?::$port)?/do/test$!) {
	result($stream, "20", "text/plain");
	$stream->write("Test\n");
	return 1;
      }
      return;
    }
    1;

=cut

package App::Phoebe;
use Modern::Perl '2018';
use File::Slurper qw(read_text read_binary read_lines read_dir write_text write_binary);
use Encode qw(encode_utf8 decode_utf8);
use Net::IDN::Encode qw(domain_to_ascii);
use Socket qw(:addrinfo SOCK_RAW);
use List::Util qw(first min any);
use File::ReadBackwards;
use Algorithm::Diff;
use URI::Escape;
use Mojo::IOLoop;
use Mojo::Log;
use utf8;

our $VERSION = 4.00;

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(@extensions @main_menu @footer $log $server $full_url_regex
		    space port host_regex space_regex reserved_regex success
		    result get_ip_numbers run_extensions pages blog blog_pages
		    text save_page serve_index serve_page serve_raw serve_html
		    serve_history serve_diff html_page to_html @request_handlers
		    handle_request process_titan process_gemini valid_id

lib/App/Phoebe.pm  view on Meta::CPAN

# Phoebe subroutines you might want to call in your extensions

sub port {
  my $stream = shift;
  return 1965 unless $stream; # if called in a test situation
  return $stream->handle->sockport; # the actual port
}

sub get_ip_numbers {
  my $hostname = shift;
  my $punycode = domain_to_ascii($hostname);
  my @addresses;
  my ($err, @res) = getaddrinfo($punycode, "", {socktype => SOCK_RAW});
  $log->error("Cannot determine the IP number of $punycode: $err") if $err;
  for my $ai (@res) {
    my ($err, $ipaddr) = getnameinfo($ai->{addr}, NI_NUMERICHOST, NIx_NOSERV);
    $log->error("Cannot get a readable IP number of $punycode: $err") if $err;
    push(@addresses, $ipaddr) if $ipaddr;
  }
  return @addresses;
}

# The hostnames we know we want to serve because they were specified via --host
# options.
sub host_regex {
  my $stream = shift;
  return join("|", map { quotemeta domain_to_ascii $_ } keys %{$server->{host}});
}

# A regular expression matching wiki spaces in URLs. The tricky part is that we
# must strip the hostnames, as these aren't repeated: for a URL like
# gemini://localhost:1965/alex/ the regular expression must just match 'alex'
# and it's space($stream, 'localhost', 'alex') that will check whether 'alex' is a
# legal space for localhost.
sub space_regex {
  my @spaces;
  if (keys %{$server->{host}} > 1) {
    for (@{$server->{wiki_space}}) {
      my ($space) = /\/(.*)/;
      push(@spaces, $space);
    }
  } elsif (@{$server->{wiki_space}}) {
    @spaces = @{$server->{wiki_space}};
  }
  return join("|", map { quotemeta } @spaces);
}

# A regular expression matching parts of reserved paths in URLs. When looking at
# gemini://localhost:1965/page/test or gemini://localhost:1965/do/index and
# using a client that has an "up" command, you'd end up at
# gemini://localhost:1965/page – but what should happen in this case? We should
# redirect these requests to gemini://localhost:1965/, I think.
sub reserved_regex {
  return join("|", qw(do page raw file html history diff));
}


sub success {
  my $stream = shift;
  my $type = shift || 'text/gemini; charset=UTF-8';
  my $lang = shift;
  if ($lang) {
    result($stream, "20", "$type; lang=$lang");
  } else {
    result($stream, "20", "$type");
  }
}

sub result {
  my $stream = shift;
  my $code = shift;
  my $meta = shift;
  my $data = shift||"";
  $stream->write("$code $meta\r\n$data");
}

sub handle_titan {
  my $stream = shift;
  my $data = shift;
  # extra processing of the request if we didn't do that, yet
  $data->{upload} ||= is_upload($stream, $data->{request}) or return;
  my $size = $data->{upload}->{params}->{size};
  my $actual = length($data->{buffer});
  if ($actual == $size) {
    $log->debug("Handle Titan request");
    process_titan($stream, $data->{request}, $data->{upload}, $data->{buffer}, $size);
    # do not close in case we're waiting for the lock
    return;
  } elsif ($actual > $size) {
    $log->debug("Received more than the promised $size bytes");
    result($stream, "59", "Received more than the promised $size bytes");
    $stream->close_gracefully();
    return;
  }
  $log->debug("Waiting for " . ($size - $actual) . " more bytes");
}

sub process_titan {
  my ($stream, $request, $upload, $buffer, $size) = @_;
  eval {
    local $SIG{'ALRM'} = sub { $log->error("Timeout processing upload $request") };
    alarm(10); # timeout
    save_page($stream, $upload->{host}, $upload->{space}, $upload->{id},
	      $upload->{params}->{mime}, $buffer, $size);
    alarm(0);
  };
  return unless $@;
  $log->error("Error: $@");
  $stream->close_gracefully();
}

sub save_page {
  my $stream = shift;
  my $host = shift;
  my $space = shift;
  my $id = shift;
  my $type = shift;
  my $data = shift;
  my $length = shift;
  if ($type ne "text/plain") {

lib/App/Phoebe.pm  view on Meta::CPAN

    $stream->write("</entry>\n");
  }
  $stream->write("<updated>$feed_ts</updated>\n");
  $stream->write("</feed>\n");
}

sub serve_blog_atom {
  my $stream = shift;
  my $host = shift;
  my $space = shift;
  $log->info("Serving Gemini Blog Atom");
  success($stream, "application/atom+xml");
  blog_atom($stream, $host, $space, 'gemini');
}

sub blog_atom {
  my $stream = shift;
  my $host = shift;
  my $space = shift;
  my $scheme = shift;
  my $name = $server->{wiki_main_page} || "Phoebe";
  my $port = port($stream);
  $stream->write("<?xml version=\"1.0\" encoding=\"utf-8\"?>\n");
  $stream->write("<feed xmlns=\"http://www.w3.org/2005/Atom\">\n");
  $stream->write(encode_utf8 "<title>" . quote_html($name) . "</title>\n");
  my $link = to_url($stream, $host, $space, "", $scheme);
  $stream->write("<link href=\"$link\"/>\n");
  $link = to_url($stream, $host, $space, "do/blog/atom", $scheme);
  $stream->write("<link rel=\"self\" type=\"application/atom+xml\" href=\"$link\"/>\n");
  $stream->write("<id>$link</id>\n");
  my $feed_ts = "0001-01-01T00:00:00Z";
  $stream->write("<generator uri=\"https://alexschroeder.ch/cgit/phoebe/about/\" version=\"1.0\">Phoebe</generator>\n");
  my $dir = wiki_dir($host, $space);
  my @blog = blog_pages($stream, $host, $space, 10);
  my $changes = changes_for($host, $space, @blog);
  # hard coded: 10 pages blog ATOM, no pagination
  for my $id (@blog[0 .. min($#blog, 9)]) {
    $stream->write("<entry>\n");
    $stream->write(encode_utf8 "<title>" . quote_html($id) . "</title>\n");
    my $link = to_url($stream, $host, $space, "page/$id", $scheme);
    $stream->write("<link href=\"$link\"/>\n");
    $stream->write("<id>$link</id>\n");
    $stream->write(encode_utf8 "<content type=\"text\">" . quote_html(text($stream, $host, $space, $id)) . "</content>\n");
    my ($sec, $min, $hour, $mday, $mon, $year) = gmtime($changes->{$id}); # 2003-12-13T18:30:02Z
    my $ts = sprintf("%04d-%02d-%02dT%02d:%02d:%02dZ", $year + 1900, $mon + 1, $mday, $hour, $min, $sec);
    $stream->write("<updated>$ts</updated>\n");
    $feed_ts = $ts if $ts gt $feed_ts;
    $stream->write("</entry>\n");
  }
  $stream->write("<updated>$feed_ts</updated>\n");
  $stream->write("</feed>\n");
}

sub serve_raw {
  my $stream = shift;
  my $host = shift;
  my $space = shift;
  my $id = shift;
  my $revision = shift;
  $log->info("Serving raw $id");
  success($stream, 'text/plain; charset=UTF-8');
  $stream->write(encode_utf8 text($stream, $host, $space, $id, $revision));
}

sub serve_diff {
  my $stream = shift;
  my $host = shift;
  my $space = shift;
  my $id = shift;
  my $revision = shift;
  my $style = shift;
  $log->info("Serving the diff of $id");
  success($stream);
  $stream->write(encode_utf8 "# Differences for $id\n");
  if (not $style) { print_link($stream, $host, $space, "Colour diff", "diff/$id/$revision/colour") }
  else { print_link($stream, $host, $space, "Normal diff", "diff/$id/$revision") }
  $stream->write("Showing the differences between revision $revision and the current revision.\n");
  my $new = text($stream, $host, $space, $id);
  my $old = text($stream, $host, $space, $id, $revision);
  if (not $style) {
    diff($old, $new,
	 sub { $stream->write(encode_utf8 "$_\n") for @_ },
	 sub { $stream->write(encode_utf8 "> $_\n") for map { $_||"⏎" } @_ },
	 sub { $stream->write(encode_utf8 "> $_\n") for map { $_||"⏎" } @_ },
	 sub { "ï½¢$_[0]ï½£" });
  } else {
    diff($old, $new,
	 sub { $stream->write(encode_utf8 "$_\n") for @_ },
	 sub { $stream->write(encode_utf8 "> \033[31m$_\033[0m\n") for map { $_||"⏎" } @_ },
	 sub { $stream->write(encode_utf8 "> \033[32m$_\033[0m\n") for map { $_||"⏎" } @_ },
	 sub { "\033[1m$_[0]\033[22m" });
  }
}

# old text, new text, code reference to print a paragraph, print deleted text,
# print added text
sub diff {
  my @old = split(/\n/, shift);
  my @new = split(/\n/, shift);
  my $paragraph = shift;
  my $deleted = shift;
  my $added = shift;
  my $highlight = shift;
  $log->debug("Preparing a diff");
  my $diff = Algorithm::Diff->new(\@old, \@new);
  $diff->Base(1); # line numbers, not indices
  while($diff->Next()) {
    next if $diff->Same();
    my $sep = '';
    my ($min1, $max1, $min2, $max2) = $diff->Get(qw(min1 max1 min2 max2));
    if ($diff->Diff == 3) {
      my ($from, $to) = refine([$diff->Items(1)], [$diff->Items(2)], $highlight);
      $paragraph->($min1 == $max1 ? "Changed line $min1 from:" : "Changed lines $min1–$max1 from:");
      $deleted->(@$from);
      $paragraph->($min2 == $max2 ? "to:" : "to lines $min2–$max2:");
      $added->(@$to);
    } elsif ($diff->Diff == 2) {
      $paragraph->($min2 == $max2 ? "Added line $min2:" : "Added lines $min2–$max2:");
      $added->($diff->Items(2));
    } elsif ($diff->Diff == 1) {
      $paragraph->($min1 == $max1 ? "Deleted line $min1:" : "Deleted lines $min1–$max1:");
      $deleted->($diff->Items(1));
    }
  }
}

# $from_lines and $to_lines are references to lists of lines. The lines are
# concatenated and split by words.
sub refine {
  my $from_lines = shift;
  my $to_lines = shift;
  my $highlight = shift;
  my @from_words = split(/\b(?=\w)/, join("\n", @$from_lines));
  my @to_words = split(/\b(?=\w)/, join("\n", @$to_lines));
  my $diff = Algorithm::Diff->new(\@from_words, \@to_words);
  my ($from, $to);
  while($diff->Next()) {
    if (my @list = $diff->Same()) {
      $from .= join('', @list);
      $to .= join('', @list);
    } else {
      # reassemble the chunks, and highlight them per line, don't strip trailing newlines!
      $from .= join("\n", map { $_ ? $highlight->($_) : $_ } (split(/\n/, join('', $diff->Items(1)), -1)));
      $to   .= join("\n", map { $_ ? $highlight->($_) : $_ } (split(/\n/, join('', $diff->Items(2)), -1)));
    }
  }
  # return lines
  return [split(/\n/, $from)], [split(/\n/, $to)];
}

sub serve_html {
  my $stream = shift;
  my $host = shift;
  my $space = shift;
  my $id = shift;
  my $revision = shift;
  success($stream, 'text/html');
  $log->info("Serving $id as HTML");
  html_page($stream, $host, $space, $id, $revision);
}

sub html_page {
  my $stream = shift;
  my $host = shift;
  my $space = shift;
  my $id = shift;
  my $revision = shift;
  $stream->write("<!DOCTYPE html>\n");
  $stream->write("<html>\n");
  $stream->write("<head>\n");
  $stream->write("<meta charset=\"utf-8\">\n");
  $stream->write(encode_utf8 "<title>" . quote_html($id) . "</title>\n");
  $stream->write("<link type=\"text/css\" rel=\"stylesheet\" href=\"/default.css\"/>\n");
  $stream->write("<meta name=\"viewport\" content=\"width=device-width, initial-scale=1\">\n");
  $stream->write("</head>\n");
  $stream->write("<body>\n");
  $stream->write(encode_utf8 "<h1>" . quote_html($id) . "</h1>\n");
  $stream->write(encode_utf8 to_html(text($stream, $host, $space, $id, $revision)) . "\n");
  $stream->write(encode_utf8 to_html(html_footer($stream, $host, $space, $id, $revision)) . "\n");
  $stream->write("</body>\n");
  $stream->write("</html>\n");
}

# returns lines!
sub to_html {
  my $text = shift;
  my @lines;
  my $list;
  my $code;
  for (split /\n/, quote_html($text)) {
    if (/^```(?:type=([a-z]+))?/) {
      my $type = $1||"default";
      if ($code) {
	push @lines, "</pre>";
	$code = 0;
      } else {
	push @lines, "</ul>" if $list;
	$list = 0;
	push @lines, "<pre class=\"$type\">";
	$code = 1;
      }
    } elsif ($code) {
      push @lines, $_;
    } elsif (/^\* +(.*)/) {
      push @lines, "<ul>" unless $list;
      push @lines, "<li>$1";
      $list = 1;
    } elsif (my ($url, $text) = /^=&gt;\s*(\S+)\s*(.*)/) { # quoted HTML!
      push @lines, "<ul>" unless $list;
      $text ||= $url;
      push @lines, "<li><a href=\"$url\">$text</a>";
      $list = 1;
    } elsif (/^(#{1,6})\s*(.*)/) {
      push @lines, "</ul>" if $list;
      $list = 0;
      my $level = length($1);
      push @lines, "<h$level>$2</h$level>";
    } elsif (/^&gt;\s*(.*)/) { # quoted HTML!
      push @lines, "</ul>" if $list;
      $list = 0;
      push @lines, "<blockquote>$1</blockquote>";
    } else {
      push @lines, "</ul>" if $list;
      $list = 0;
      push @lines, "<p>$_";
    }
  }
  push @lines, "</pre>" if $code;
  push @lines, "</ul>" if $list;
  return join("\n", @lines);
}