App-Phoebe

 view release on metacpan or  search on metacpan

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

    rmdir $lock if -e $lock and $age > 5;
  }
  if (mkdir($lock)) {
    $log->debug("Running code with lock $lock");
    eval { $code->() }; # protect against exceptions
    if ($@) {
      $log->error("Unable to run code with locked $lock: $@");
      result($stream, "40", "An error occured, unfortunately");
      $stream->close_gracefully();
    }
    # in the successful case, with_lock doesn't close in case there is more code
    # that needs to run, or possibly $code has closed the stream.
    rmdir($lock);
  } elsif ($count > 25) {
    $log->error("Unable to unlock $lock");
    result($stream, "40", "The wiki is locked; try again in a few seconds");
    $stream->close_gracefully();
  } else {
    $log->debug("Waiting $count...");
    Mojo::IOLoop->timer(0.2 => sub {
      with_lock($stream, $host, $space, $code, $count + 1)});
    # don't close the stream
  }
}

sub write_page {
  my $stream = shift;
  my $host = shift;
  my $space = shift;
  my $id = shift;
  my $text = shift;
  $log->info("Writing page $id");
  my $dir = wiki_dir($host, $space);
  my $file = "$dir/page/$id.gmi";
  my $revision = 0;
  if (-e $file) {
    my $old = read_text($file);
    if ($old eq $text) {
      $log->info("$id is unchanged");
      result($stream, "30", to_url($stream, $host, $space, "page/$id"));
      return;
    }
    mkdir "$dir/keep" unless -d "$dir/keep";
    if (-d "$dir/keep/$id") {
      foreach (read_dir("$dir/keep/$id")) {
	$revision = $1 if m/^(\d+)\.gmi$/ and $1 > $revision;
      }
      $revision++;
    } else {
      mkdir "$dir/keep/$id";
      $revision = 1;
    }
    rename $file, "$dir/keep/$id/$revision.gmi";
  } else {
    my $index = "$dir/index";
    if (not open(my $fh, ">>:encoding(UTF-8)", $index)) {
      $log->error("Cannot write index $index: $!");
      result($stream, "59", "Unable to write index");
      return;
    } else {
      say $fh $id;
      close($fh);
    }
  }
  my $changes = "$dir/changes.log";
  if (not open(my $fh, ">>:encoding(UTF-8)", $changes)) {
    $log->error("Cannot write log $changes: $!");
    result($stream, "59", "Unable to write log");
    return;
  } else {
    my $peerhost = $stream->handle->peerhost;
    say $fh join("\x1f", scalar(time), $id, $revision + 1, bogus_hash($peerhost));
    close($fh);
  }
  mkdir "$dir/page" unless -d "$dir/page";
  eval { write_text($file, $text) };
  if ($@) {
    $log->error("Unable to save $id: $@");
    result($stream, "59", "Unable to save $id");
  } else {
    $log->info("Wrote $id");
    result($stream, "30", to_url($stream, $host, $space, "page/$id"));
  }
}

sub delete_page {
  my $stream = shift;
  my $host = shift;
  my $space = shift;
  my $id = shift;
  $log->info("Deleting page $id");
  my $dir = wiki_dir($host, $space);
  my $file = "$dir/page/$id.gmi";
  if (-e $file) {
    my $revision = 0;
    mkdir "$dir/keep" unless -d "$dir/keep";
    if (-d "$dir/keep/$id") {
      foreach (read_dir("$dir/keep/$id")) {
	$revision = $1 if m/^(\d+)\.gmi$/ and $1 > $revision;
      }
      $revision++;
    } else {
      mkdir "$dir/keep/$id";
      $revision = 1;
    }
    # effectively deleting the file
    rename $file, "$dir/keep/$id/$revision.gmi";
  }
  my $index = "$dir/index";
  if (-f $index) {
    # remove $id from the index
    my @pages = grep { $_ ne $id } split /\n/, read_text $index;
    write_text($index, join("\n", @pages, ""));
  }
  my $changes = "$dir/changes.log";
  if (not open(my $fh, ">>:encoding(UTF-8)", $changes)) {
    $log->error("Cannot write log $changes: $!");
    result($stream, "59", "Unable to write log");
    return;
  } else {
    my $peerhost = $stream->handle->peerhost;
    say $fh join("\x1f", scalar(time), $id, "🖹", bogus_hash($peerhost));
    close($fh);
  }
  $log->info("Deleted page $id");
  result($stream, "30", to_url($stream, $host, $space, "page/$id"));
}

sub handle_gemini {
  my $stream = shift;
  my $data = shift;
  $log->debug("Handle Gemini request");
  $log->debug("Discarding " . length($data->{buffer}) . " bytes")
      if $data->{buffer};
  process_gemini($stream, $data->{request});
}

sub process_gemini {
  my ($stream, $url) = @_;
  eval {
    local $SIG{'ALRM'} = sub {
      $log->error("Timeout processing $url");
    };
    alarm(10); # timeout
    my $hosts = host_regex();
    my $port = port($stream);
    my $spaces = space_regex();
    my $reserved = reserved_regex($stream);
    $log->debug("Serving ($hosts)(?::$port)?");
    $log->debug("Spaces $spaces");
    my($scheme, $authority, $path, $query, $fragment) =
	$url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|;
    $log->info("Looking at $url");
    my ($host, $space, $id, $n, $style, $filter);
    if (run_extensions($stream, $url)) {
      # config file goes first
    } elsif (not $url) {
      $log->debug("The URL is empty");
      result($stream, "59", "URL expected");
    } elsif (length($url) > 1024) {
      $log->debug("The URL is too long");
      result($stream, "59", "The URL is too long");
    } elsif (($host, $n, $space) = $url =~ m!^(?:gemini:)?//($hosts)(:$port)?(?:/($spaces))?/(?:$reserved)$!) {
      # redirect gemini://localhost:2020/do to gemini://localhost:2020/
      # redirect gemini://localhost:2020/space/do to gemini://localhost:2020/space
      $space = space($stream, $host, $space) || "";
      result($stream, "31", "gemini://$host" . ($n ? ":$port" : "") . "/$space"); # this supports "up"
    } elsif (($host, $space) = $url =~ m!^(?:gemini:)?//($hosts)(?::$port)?(?:/($spaces))?/?$!) {
      serve_main_menu($stream, $host, space($stream, $host, $space));
    } elsif (($host, $space, $n) = $url =~ m!^(?:gemini:)?//($hosts)(?::$port)?(?:/($spaces))?/do/more(?:/(\d+))?$!) {
      serve_blog($stream, $host, space($stream, $host, $space), $n);
    } elsif (($host, $space) = $url =~ m!^(?:gemini:)?//($hosts)(?::$port)?(?:/($spaces))?/do/index$!) {
      serve_index($stream, $host, space($stream, $host, $space));
    } elsif (($host, $space) = $url =~ m!^(?:gemini:)?//($hosts)(?::$port)?(?:/($spaces))?/do/files$!) {
      serve_files($stream, $host, space($stream, $host, $space));
    } elsif (($host) = $url =~ m!^(?:gemini:)?//($hosts)(?::$port)?(?:/($spaces))?/do/spaces$!) {
      serve_spaces($stream, $host, $port);
    } elsif (($host, $space) = $url =~ m!^(?:gemini:)?//($hosts)(?::$port)?(?:/($spaces))?/do/data$!) {
      serve_data($stream, $host, space($stream, $host, $space));
    } elsif ($url =~ m!^(?:gemini:)?//($hosts)(?::$port)?(?:/($spaces))?/do/match$!) {
      result($stream, "10", "Find page by name (Perl regex)");
    } elsif ($query and ($host, $space) = $url =~ m!^(?:gemini:)?//($hosts)(?::$port)?(?:/($spaces))?/do/match\?!) {

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

  print_link($stream, $host, undef, "More...", "do/all/changes/" . 10 * $n . ($style ? "/$style" : ""));
}

sub all_logs {
  my $stream = shift;
  my $host = shift;
  my $n = shift;
  my $filter = shift;
  # merge all logs
  my @log;
  my $dir = $server->{wiki_dir};
  my @spaces = space_dirs();
  for my $space (@spaces) {
    my $changes = $dir;
    $changes .= "/$space" if $space;
    $changes .= "/changes.log";
    next unless -f $changes;
    $log->debug("Reading $changes");
    next unless my $fh = File::ReadBackwards->new($changes);
    if (keys %{$server->{host}} > 1) {
      push(@log, @{read_log($stream, $fh, $n, split(/\//, $space, 2), $filter)});
    } else {
      push(@log, @{read_log($stream, $fh, $n, $host, $space, $filter)});
    }
  }
  @log = sort { $b->[0] <=> $a->[0] } @log;
  return \@log;
 }

sub read_log {
  my $stream = shift;
  my $fh = shift; # File::ReadBackwards
  my $n = shift;
  my $host = shift;
  my $space = shift;
  my $filter = shift;
  my @changes;
  for (1 .. $n) {
    $_ = decode_utf8($fh->readline);
    # $_ can be undefined or a newline (which won't split)
    last unless $_ and $_ ne "\n";
    next if $filter and not /$filter/;
    chomp;
    push(@changes, [split(/\x1f/), $host, $space]);
  }
  $log->debug("Read changes: " . @changes);
  return \@changes;
}

# $n is the number of changes to show. $header is a code reference that prints a
# header for the date (one argument). $change is a code reference that prints
# the time and code of the person making the change (two arguments). $link is a
# code reference that prints a link (four arguments). $nolink is a code reference
# that prints a name that isn't linked (one argument). $next is a code reference
# that returns the list of attributes for the next change, these attributes
# being: the timestamp (as returned by time); the page or file name; the page
# revision or zero if a file; the code to represent the person that made the
# change, represented as a string of octal digits that will be fed to the
# colourize sub; the host, and the spaces, if any; and a boolean if space and
# page or file name should both be shown (up to seven arguments). Finally, the
# optional argument $kept is a code reference to say whether an old revision
# actually exists. If not, there's no point in showing a diff link. The default
# implementation checks for the existence of the keep file. $filter describes
# how changes are to be filtered: 'latest' means that only the latest change
# will be shown, i.e. a link to current revision. The default is to show all
# changes. $style is "coloured" or "fancy" or undefined to indicate what sort of
# changes we are looking at.
sub changes {
  my $stream = shift;
  my $n = shift;
  my $header = shift;
  my $change = shift;
  my $link = shift;
  my $nolink = shift;
  my $next = shift;
  my $kept = shift || sub {
    my ($host, $space, $id, $revision) = @_;
    -e wiki_dir($host, $space) . "/keep/$id/$revision.gmi";
  };
  my $filter = shift||'';
  my $style = shift;
  my $last_day = '';
  my %seen;
  for (1 .. $n) {
    my ($ts, $id, $revision, $code, $host, $space, $show_space) = $next->();
    return unless $ts and $id;
    my $name = name($stream, $id, $host, $space, $show_space);
    next if $filter eq "latest" and $seen{$name};
    my $day = day($stream, $ts);
    if ($day ne $last_day) {
      $header->($day);
      $last_day = $day;
    }
    $change->(time_of_day($stream, $ts), $code);
    if ($revision eq "🖹") {
      # a deleted page
      $link->($host, $space, "$name (deleted)", "page/$id");
      $link->($host, $space, "History", "history/$id" . ($style ? "/10/$style" : ""));
      $seen{$name} = 1;
    } elsif ($revision eq "🖻") {
      # a deleted file
      $nolink->("$name (deleted file)");
      $seen{$name . "\x1c"} = 1;
    } elsif ($revision > 0) {
      # a page
      if ($seen{$name}) {
	$link->($host, $space, "$name ($revision)", "page/$id/$revision");
	# there is no fancy diff, just colour diff
	$link->($host, $space, "Differences", "diff/$id/$revision" . ($style ? "/colour" : ""))
	    if $kept->($host, $space, $id, $revision);
      } elsif ($filter eq "latest") {
	$link->($host, $space, "$name", "page/$id");
	$link->($host, $space, "History", "history/$id");
	$seen{$name} = 1;
      } else {
	$link->($host, $space, "$name (current)", "page/$id");
	$link->($host, $space, "History", "history/$id" . ($style ? "/10/$style" : ""));
	$seen{$name} = 1;
      }
    } else {
      # a file

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

sub serve_file {
  my $stream = shift;
  my $host = shift;
  my $space = shift;
  my $id = shift;
  my $revision = shift;
  $log->info("Serve file $id");
  my $dir = wiki_dir($host, $space);
  my $file = "$dir/file/$id";
  my $meta = "$dir/meta/$id";
  if (not -f $file) {
    result($stream, "40", "File not found");
    return;
  } elsif (not -f $meta) {
    result($stream, "40", "Metadata not found");
    return;
  }
  my %meta = (map { split(/: /, $_, 2) } split /\n/, read_text $meta);
  if (not $meta{'content-type'}) {
    result($stream, "59", "Metadata corrupt");
    return;
  }
  success($stream, $meta{'content-type'});
  $stream->write(read_binary($file));
}

sub bogus_hash {
  my $str = shift;
  return "0000" unless $str;
  my $num = unpack("L",B::hash($str)); # 32-bit integer
  my $code = sprintf("%o", $num); # octal is 0-7
  return substr($code, 0, 4); # four numbers
}

sub write_file {
  my $stream = shift;
  my $host = shift;
  my $space = shift;
  my $id = shift;
  my $data = shift;
  my $type = shift;
  $log->info("Writing file $id");
  my $dir = wiki_dir($host, $space);
  my $file = "$dir/file/$id";
  my $meta = "$dir/meta/$id";
  if (-e $file) {
    my $old = read_binary($file);
    if ($old eq $data) {
      $log->info("$id is unchanged");
      result($stream, "30", to_url($stream, $host, $space, "page/$id"));
      return;
    }
  }
  my $changes = "$dir/changes.log";
  if (not open(my $fh, ">>:encoding(UTF-8)", $changes)) {
    $log->error("Cannot log $changes: $!");
    result($stream, "59", "Unable to write log");
    return;
  } else {
    my $peerhost = $stream->handle->peerhost;
    say $fh join("\x1f", scalar(time), $id, 0, bogus_hash($peerhost));
    close($fh);
  }
  mkdir "$dir/file" unless -d "$dir/file";
  eval { write_binary($file, $data) };
  if ($@) {
    result($stream, "59", "Unable to save $id");
    return;
  }
  mkdir "$dir/meta" unless -d "$dir/meta";
  eval { write_text($meta, "content-type: $type\n") };
  if ($@) {
    result($stream, "59", "Unable to save metadata for $id");
    return;
  }
  $log->info("Wrote $id");
  result($stream, "30", to_url($stream, $host, $space, "file/$id"));
}

sub delete_file {
  my $stream = shift;
  my $host = shift;
  my $space = shift;
  my $id = shift;
  $log->info("Deleting file $id");
  my $dir = wiki_dir($host, $space);
  unlink("$dir/file/$id", "$dir/meta/$id");
  my $changes = "$dir/changes.log";
  if (not open(my $fh, ">>:encoding(UTF-8)", $changes)) {
    $log->error("Cannot write log $changes: $!");
    result($stream, "59", "Unable to write log");
    return;
  } else {
    my $peerhost = $stream->handle->peerhost;
    say $fh join("\x1f", scalar(time), $id, "🖻", bogus_hash($peerhost));
    close($fh);
  }
  success($stream);
  $stream->write("# $id\n");
  $stream->write("The file was deleted.\n");
}

sub allow_deny_hook {
  my $stream = shift;
  my $client = shift;
  # consider adding rate limiting?
  return 1;
}

sub wiki_dir {
  my $host = shift;
  my $space = shift;
  my $dir = $server->{wiki_dir};
  if (keys %{$server->{host}} > 1) {
    $dir .= "/$host";
    mkdir($dir) unless -d $dir;
  }
  $dir .= "/$space" if $space;
  mkdir($dir) unless -d $dir;
  return $dir;
}

# If we are serving multiple hostnames, we need to check whether the space
# supplied in the URL matches a known hostname/space combo.
sub space {
  my $stream = shift;
  my $host = shift;
  my $space = shift;
  $space = decode_utf8(uri_unescape($space)) if $space;
  if (keys %{$server->{host}} > 1) {
    return undef unless $space;
    return $space if grep { $_ eq "$host/$space" } @{$server->{wiki_space}};
    # else it's an error and we jump out to the eval {} in handle_url
    result($stream, "40", "$host doesn't know about $space");
    die "unknown space: $host/$space\n"; # is caught in the eval
  }
  # Without wildcards, just return the space. We already know that the space
  # matched the regular expression of spaces.
  return $space;
}

sub space_dirs {
  my @spaces;
  if (keys %{$server->{host}} > 1) {
    push @spaces, keys %{$server->{host}};
  } else {
    push @spaces, undef;
  }
  push @spaces, @{$server->{wiki_space}};
  return @spaces;
}

# A list of links to all the spaces we have. The tricky part here is that we
# want to create appropriate links if we're virtual hosting. Keys are URLs,
# values are names.