view release on metacpan or  search on metacpan

script/phoebe-ctl  view on Meta::CPAN

    journalctl --unit phoebe | phoebe-ctl log requests

The same, but limited to a particular IP number:

    journalctl --unit phoebe | phoebe-ctl log requests 201.159.58.193

=cut

package Gemini::Wiki::Control;
use Modern::Perl '2018';
use File::Slurper qw(read_dir read_text write_text);
use Encode qw(encode_utf8 decode_utf8);
use Getopt::Long;
use Pod::Text;
use File::Path qw(remove_tree);
use POSIX qw(round);
use utf8;

binmode(STDOUT, ":utf8");

my $log = 2;
my $dir = "./wiki";
my @sources;
my $target;
my $no_extension;
GetOptions (
  "log=i" => \$log,
  "wiki_dir=s" => \$dir,
  "source=s" => \@sources,
  "target=s" => \$target,
  "no-extension" => \$no_extension, );
@sources = ("") unless @sources;

my $subcommands = {
  "help" => 0,
  "update-changes" => \&update_changes,
  "erase-page" => \&erase_page,
  "html-export" => \&html_export,
  "log" => \&log, };

my $subcommand;
$subcommand = shift(@ARGV) if @ARGV;
die "No subcommand\n" unless $subcommand;
$subcommand = $subcommands->{$subcommand};
die "No known subcommand\n" unless defined $subcommand;
if (not $subcommand) {
  my $parser = Pod::Text->new();
  $parser->parse_file($0);
  exit;
}

$subcommand->(@ARGV);

exit;

sub update_changes {
  my %pages;
  my $now = time;
  $pages{decode_utf8($_)} = modified("$dir/page/$_.gmi") for map { s/\.gmi$//; $_ } grep /\.gmi$/, read_dir("$dir/page");
  say "Read " . scalar(keys %pages) . " pages" if $log >= 3;
  say join("\n", map { $_ . "\t" . $pages{$_} } sort keys %pages) if $log >= 4;
  my %files;
  $files{decode_utf8($_)} = modified("$dir/file/$_") for read_dir("$dir/file");
  say "Read " . scalar(keys %files) . " files" if $log >= 3;
  say join("\n", map { $_ . "\t" . $files{$_} } sort keys %files) if $log >= 4;
  my %revisions;
  my %changes;
  for (split /\n/, read_text "$dir/changes.log") {
    my ($ts, $id, $revision) = split(/\x1f/);
    $revisions{$id} = $revision;
    if ($revision) {
      $changes{$id} = $ts;
    } else {
      $changes{$id . "\x1c"} = $ts;
    }
  };
  say "Read " . scalar(keys %changes) . " changes" if $log >= 3;
  say join("\n", map { $_ . "\t" . $changes{$_} } sort keys %changes) if $log >= 4;
  open(my $fh, ">>:encoding(UTF-8)", "$dir/changes.log") or die "Cannot write $dir/changes.log: $!";
  for (keys %pages) {
    if (not $changes{$_} or $pages{$_} > $changes{$_}) {
      say "Page $_ is added to changes" if $log >= 4;
      my $revision = $revisions{$_} || 0;
      say $fh join("\x1f", $now, $_, 1 + $revision, "0000");
      utime($now, $now, "$dir/page/$_.gmi") or warn "Could not set utime for $dir/page/$_.gmi\n";
    }
  }
  for (keys %files) {
    if (not $changes{$_ . "\x1c"} or $files{$_} > $changes{$_ . "\x1c"}) {
      say "File $_ is added to changes" if $log >= 4;
      say $fh join("\x1f", $now, $_, 0, "0000");
      utime($now, $now, "$dir/file/$_") or warn "Could not set utime for $dir/file/$_\n";
    }
  }
  close($fh);
}

sub modified {
  my $ts = (stat(shift))[9];
  return $ts;
}

sub erase_page {
  my @page = @_;
  die "You need to list the pages to erase\n" unless @page;
  for my $page (@page) {
    if (not -f "$dir/page/$page.gmi") {
      warn "$page does not exist\n";
      next;
    }
  }
  my $n = unlink map { "$dir/page/$_.gmi" } @page;
  warn "Deleted $n pages: $!\n" if $n < @page;
  my @dirs = grep { -d } map { "$dir/keep/$_" } @page;
  remove_tree(@dirs, { safe => 1});
  if (-f "$dir/changes.log") {
    my @log = grep {
      my ($ts, $id, $revision, $code) = split(/\x1f/);
      0 == grep { $id eq $_ } @page; # only keep log lines that are not mentioned
    } split /\n/, read_text "$dir/changes.log";
    rename("$dir/changes.log", "$dir/changes.log~")
	or die "Cannot rename $dir/changes.log to changes.log~: $!";
    write_text("$dir/changes.log", join("\n", @log));
  }
  if (-f "$dir/index") {
    my @index = grep {
      my $id = $_;
      0 == grep { $id eq $_ } @page; # only keep index pages that are not mentioned
    } split /\n/, read_text "$dir/index";
    rename("$dir/index", "$dir/index~")
	or die "Cannot rename $dir/index to index~: $!";
    write_text("$dir/index", join("\n", @index));
  }
}

sub html_export {
  die "You need to provide a target directory for the HTML files using --target=directory\n" unless $target;
  for my $source (@sources) {
    my $source_dir = "$dir$source";
    die "Source directory $source_dir does not exist\n" unless -d $source_dir;
    my $target_dir = "$target$source";
    mkdir $target_dir or die "Cannot create target directory $target_dir: $!\n"
	unless -d $target_dir;
    for my $page (map { s/\.gmi$//; $_ } grep /\.gmi$/, read_dir("$source_dir/page")) {
      my $id = decode_utf8 $page;
      my $text = read_text "$source_dir/page/$page.gmi"; # fatal if it does not exist
      say "Converting $id";
      my $filename = "$target_dir/$page";
      $filename .= ".html" unless $no_extension;
      open(my $fh, ">:utf8", $filename)
	  or die "Cannot write $filename: $!\n";
      say $fh "<!DOCTYPE html>";
      say $fh "<html>";
      say $fh "<head>";
      say $fh "<meta charset=\"utf-8\">";
      say $fh "<title>" . quote_html($id) . "</title>";
      say $fh "<link type=\"text/css\" rel=\"stylesheet\" href=\"/default.css\"/>";
      say $fh "<meta name=\"viewport\" content=\"width=device-width, initial-scale=1\">";
      say $fh "</head>";
      say $fh "<body>";
      say $fh "<h1>" . quote_html($id) . "</h1>";
      say $fh to_html($text);
      # skipping footers
      say $fh "</body>";
      say $fh "</html>";
    }
  }
}

sub quote_html {
  my $html = shift;
  $html =~ s/&/&amp;/g;
  $html =~ s/</&lt;/g;
  $html =~ s/>/&gt;/g;
  $html =~ s/[\x00-\x08\x0b\x0c\x0e-\x1f]/ /g; # legal xml: #x9 | #xA | #xD | [#x20-#xD7FF] | [#xE000-#xFFFD] | [#x10000-#x10FFFF]
  return $html;
}

# 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);
}

sub log {
  my ($type, $filter) = @ARGV;
  if (not $type or $type ne "hits" and $type ne "requests") {
    die "No known log type (one of: hits, requests)\n";
  }
  my ($ip, %ip, %block, $n, $blocks, %request);
  while (<STDIN>) {
    if (/\[debug\] Visitor: (\S+)$/) {
      $ip = $1;
      $ip{$ip}++;
    } elsif ((not $filter or $ip and $filter eq $ip) and /\[info\] Looking at (.*)/) {
      $request{$1}++;
      $n++;
      $ip //= "anon";
    } elsif ($ip and (not $filter or $filter eq $ip) and /\[info\] (Net range (\S+) is blocked|IP is blocked)/) {
      $block{$ip}++;
      $blocks++;
    }
  }
  die("No hits (you must run the server on --log_level=info or --log_level=debug\n") unless $n;
  say("Total hits:   $n");
  say("Total blocks: $blocks");
  say("Bot level:    " . round($blocks / $n * 100) . "%") if $blocks;
  say("-" x length("Total blocks: $blocks"));
  if ($type eq "hits") {
    printf("%5s %4s%% %5s %s\n", "Hits", "Hits", "Block", "IP Number");
    for (sort { $ip{$b} <=> $ip{$a} } keys %ip) {
      printf("%5d %4d%% %4d%% %s\n", $ip{$_}, int(100*$ip{$_}/$n), exists $block{$_} ? int(100*$block{$_}/$n) : 0, $_);
    }
  } elsif ($type eq "requests") {
    printf("%5s %4s%% %s\n", "Hits", "Hits", "Request");
    for (sort { $request{$b} <=> $request{$a} } keys %request) {
      printf("%5d %4d%% %s\n", $request{$_}, int(100*$request{$_}/$n), $_);
    }
  }
}