App-Phoebe

 view release on metacpan or  search on metacpan

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

    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\?!) {
      serve_match($stream, $host, space($stream, $host, $space), decode_query($query));
    } elsif ($url =~ m!^(?:gemini:)?//($hosts)(?::$port)?(?:/($spaces))?/do/search$!) {
      result($stream, "10", "Find page by content (Perl regex)");
    } elsif ($query and ($host, $space) = $url =~ m!^(?:gemini:)?//($hosts)(?::$port)?(?:/($spaces))?/do/search\?!) {
      serve_search($stream, $host, space($stream, $host, $space), decode_query($query)); # search terms include spaces
    } elsif ($url =~ m!^(?:gemini:)?//($hosts)(?::$port)?(?:/($spaces))?/do/new$!) {
      result($stream, "10", "New page");
      # no URI escaping required
    } elsif ($query and ($host, $space) = $url =~ m!^(?:gemini:)?//($hosts)(?::$port)?(?:/($spaces))?/do/new\?!) {
      if ($space) {
	result($stream, "30", "gemini://$host:$port/$space/raw/$query");
      } else {
	result($stream, "30", "gemini://$host:$port/raw/$query");
      }
    } elsif (($host, $space, $n, $style) = $url =~ m!^(?:gemini:)?//($hosts)(?::$port)?(?:/($spaces))?/do/changes(?:/(\d+))?(?:/(colour|fancy))?$!) {
      serve_changes($stream, $host, space($stream, $host, $space), $n||100, $style);
    } elsif (($host, $filter, $n, $style) = $url =~ m!^(?:gemini:)?//($hosts)(?::$port)?/do/all(?:/(latest))?/changes(?:/(\d+))?(?:/(colour|fancy))?$!) {
      serve_all_changes($stream, $host, $n||100, $style||"", $filter||"");
    } elsif (($host, $space) = $url =~ m!^(?:gemini:)?//($hosts)(?::$port)?(?:/($spaces))?/do/rss$!) {
      serve_rss($stream, $host, space($stream, $host, $space));
    } elsif (($host, $space) = $url =~ m!^(?:gemini:)?//($hosts)(?::$port)?(?:/($spaces))?/do/blog/rss$!) {
      serve_blog_rss($stream, $host, space($stream, $host, $space));
    } elsif (($host, $space) = $url =~ m!^(?:gemini:)?//($hosts)(?::$port)?(?:/($spaces))?/do/atom$!) {
      serve_atom($stream, $host, space($stream, $host, $space));
    } elsif (($host, $space) = $url =~ m!^(?:gemini:)?//($hosts)(?::$port)?(?:/($spaces))?/do/blog/atom$!) {
      serve_blog_atom($stream, $host);
    } elsif (($host, $space) = $url =~ m!^(?:gemini:)?//($hosts)(?::$port)?(?:/($spaces))?/do/all/atom$!) {
      serve_all_atom($stream, $host);
    } elsif (($host) = $url =~ m!^(?:gemini:)?//($hosts)(?::$port)?/robots.txt(?:[#?].*)?$!) {
      serve_raw($stream, $host, undef, "robots");
    } elsif (($host, $space, $id, $n, $style) = $url =~ m!^(?:gemini:)?//($hosts)(?::$port)?(?:/($spaces))?/history/([^/]*)(?:/(\d+))?(?:/(colour|fancy))?$!) {
      serve_history($stream, $host, space($stream, $host, $space), decode_utf8(uri_unescape($id)), $n||10, $style);
    } elsif (($host, $space, $id, $n, $style) = $url =~ m!^(?:gemini:)?//($hosts)(?::$port)?(?:/($spaces))?/diff/([^/]*)(?:/(\d+))?(?:/(colour))?$!) {
      serve_diff($stream, $host, space($stream, $host, $space), decode_utf8(uri_unescape($id)), $n, $style);
    } elsif (($host, $space, $id, $n) = $url =~ m!^(?:gemini:)?//($hosts)(?::$port)?(?:/($spaces))?/raw/([^/]*)(?:/(\d+))?$!) {
      serve_raw($stream, $host, space($stream, $host, $space), decode_utf8(uri_unescape($id)), $n);
    } elsif (($host, $space, $id, $n) = $url =~ m!^(?:gemini:)?//($hosts)(?::$port)?(?:/($spaces))?/html/([^/]*)(?:/(\d+))?$!) {
      serve_html($stream, $host, space($stream, $host, $space), decode_utf8(uri_unescape($id)), $n);
    } elsif (($host, $space, $id, $n) = $url =~ m!^(?:gemini:)?//($hosts)(?::$port)?(?:/($spaces))?/page/([^/]+)(?:/(\d+))?$!) {
      serve_page($stream, $host, space($stream, $host, $space), decode_utf8(uri_unescape($id)), $n);
    } elsif (($host, $space, $id) = $url =~ m!^(?:gemini:)?//($hosts)(?::$port)?(?:/($spaces))?/file/([^/]+)?$!) {
      serve_file($stream, $host, space($stream, $host, $space), decode_utf8(uri_unescape($id)));
    } elsif (($host) = $url =~ m!^(?:gemini:)?//($hosts)(?::$port)?(/|$)!) {
      $log->info("Unknown path for $url\r");
      result($stream, "51", "Path not found for $url");
    } elsif ($authority) {
      $log->info("Unsupported proxy request for $url");
      result($stream, "53", "Unsupported proxy request for $url");
    } else {
      $log->info("No handler for $url");
      result($stream, "59", "Don't know how to handle $url");
    }
    $log->debug("Done");
  };
  $log->error("Error: $@") if $@;
  alarm(0);
  $stream->close_gracefully();
}

sub decode_query {
  my $query = shift;
  return $query unless $query;
  $query = decode_utf8(uri_unescape($query));
  $query =~ s/\+/ /g;
  return $query;
}

sub run_extensions {
  foreach my $sub (@extensions) {
    return 1 if $sub->(@_);
  }
  return;
}

sub serve_main_menu {
  my $stream = shift;
  my $host = shift||"";
  my $space = shift||"";
  $log->info("Serving main menu");
  success($stream);
  my $page = $server->{wiki_main_page};
  if ($page) {
    $stream->write(encode_utf8 text($stream, $host, $space, $page) . "\n");
  } else {
    $stream->write("# Welcome to Phoebe!\n");
    $stream->write("\n");
  }
  blog($stream, $host, $space, 10);
  for my $id (@{$server->{wiki_page}}) {
    print_link($stream, $host, $space, $id);
  }
  for my $line (@main_menu) {
    $stream->write(encode_utf8 $line . "\n");
  }
  print_link($stream, $host, $space, "Changes", "do/changes");
  print_link($stream, $host, $space, "Search matching page names", "do/match");
  print_link($stream, $host, $space, "Search matching page content", "do/search");
  print_link($stream, $host, $space, "New page", "do/new");
  $stream->write("\n");
  print_link($stream, $host, $space, "Index of all pages", "do/index");
  print_link($stream, $host, $space, "Index of all files", "do/files");
  print_link($stream, $host, undef, "Index of all spaces", "do/spaces")
      if @{$server->{wiki_space}} or keys %{$server->{host}} > 1;
  print_link($stream, $host, $space, "Download data", "do/data");
  # a requirement of the GNU Affero General Public License
  $stream->write("=> https://metacpan.org/pod/App::Phoebe Source code\n");
  $stream->write("\n");
}

sub handle_request {
  my $stream = shift;
  my $data = shift;
  if ($data->{buffer} =~ /^(.*)\r\n/) {
    $data->{request} = $1;
    $data->{buffer} =~ s/.*\r\n//;
    $log->debug("Looking at $data->{request}");
    for (my $i = 0; $i < @request_handlers; $i += 2) {
      my $re = $request_handlers[$i];
      if ($data->{request} =~ m!$re!i) {
	$data->{handler} = $request_handlers[$i+1];
	# and call the handler
	$data->{handler}->($stream, $data);
	return;
      }
    }
    $log->debug("No handler found for $data->{request}");
    result($stream, "59", "Cannot handle this request");
    $stream->close_gracefully();
  } else {
    $log->debug("Waiting for more bytes...");
  }
}

# special generic URL error handling to satisfy gemini-diagnostics
sub handle_url {
  my $stream = shift;
  my $data = shift;
  $log->debug("Unhandled proxy request");
  $log->debug("Discarding " . length($data->{buffer}) . " bytes")
      if $data->{buffer};
  result($stream, "53", "No proxying for $data->{request}");
  $stream->close_gracefully();
}

# if you call this yourself, $id must look like "page/foo"
sub to_url {
  my $stream = shift;
  my $host = lc shift;
  my $space = shift;
  my $id = shift;
  my $scheme = shift || "gemini";
  my $port = port($stream);
  if ($space) {
    $space = "" if $space eq $host;
    $space =~ s/.*\///;
    $space = uri_escape_utf8($space);
  }
  # don't encode the slash
  return "$scheme://$host:$port/"
      . ($space ? "$space/" : "")
      . join("/", map { uri_escape_utf8($_) } split (/\//, $id));
}

sub gemini_link {
  my $stream = shift;
  my $host = shift;
  my $space = shift;
  my $title = shift;
  my $id = shift;
  if (not $id) {
    $id = "page/$title";
  }
  return "=> $id $title" if $id =~ /^$full_url_regex$/;
  my $url = to_url($stream, $host, $space, $id);
  return "=> $url $title";
}

sub print_link {
  my $stream = shift;
  my $host = shift;
  my $space = shift;
  my $title = shift;
  my $id = shift;
  $stream->write(encode_utf8 gemini_link($stream, $host, $space, $title, $id) . "\n");
}

sub newest_first {
  my ($date_a, $article_a) = $a =~ /^(\d\d\d\d-\d\d(?:-\d\d)? ?)?(.*)/;
  my ($date_b, $article_b) = $b =~ /^(\d\d\d\d-\d\d(?:-\d\d)? ?)?(.*)/;
  return (($date_b and $date_a and $date_b cmp $date_a)
	  || ($article_a cmp $article_b)
	  # this last one should be unnecessary
	  || ($a cmp $b));
}

sub pages {
  my $stream = shift; # used by contributions like oddmuse.pl
  my $host = shift;
  my $space = shift;
  my $re = shift;
  my $dir = wiki_dir($host, $space);
  my $index = "$dir/index";
  if (not -f $index) {
    return if not -d "$dir/page";
    my @pages = map { s/\.gmi$//; $_ } read_dir("$dir/page");
    write_text($index, join("\n", @pages, ""));
    return sort newest_first @pages;
  }
  my @lines = sort newest_first split /\n/, read_text $index;
  return grep /$re/i, @lines if $re;
  return @lines;
}

sub blog_pages {
  my $stream = shift; # used by contributions like oddmuse.pl
  my $host = shift;
  my $space = shift;
  my $n = shift; # used by contributions like oddmuse.pl
  return sort { $b cmp $a } pages($stream, $host, $space, '^\d\d\d\d-\d\d-\d\d');
}

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

  my $html = join("\n", grep /\S/, @links);
  return "\n\nMore:\n$html" if $html =~ /\S/;
  return "";
}

sub day {
  my $stream = shift;
  my ($sec, $min, $hour, $mday, $mon, $year) = gmtime(shift);
  return sprintf('%4d-%02d-%02d', $year + 1900, $mon + 1, $mday);
}

sub time_of_day {
  my $stream = shift;
  my ($sec, $min, $hour, $mday, $mon, $year) = gmtime(shift);
  return sprintf('%02d:%02d UTC', $hour, $min);
}

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

sub serve_history {
  my $stream = shift;
  my $host = shift;
  my $space = shift;
  my $id = shift;
  my $n = shift;
  my $style = shift;
  success($stream);
  $log->info("Serve history for $id");
  $stream->write(encode_utf8 "# Page history for $id\n");
  if (not $style) { print_link($stream, $host, $space, "Colour history", "history/$id/$n/colour") }
  elsif ($style eq "colour") { print_link($stream, $host, $space, "Fancy history", "history/$id/$n/fancy") }
  elsif ($style eq "fancy") { print_link($stream, $host, $space, "Normal history", "history/$id/$n") }
  my $dir = wiki_dir($host, $space);
  my $log = "$dir/changes.log";
  if (not -e $log) {
    $stream->write("No changes.\n");
    return;
  }
  $stream->write("Showing up to $n changes.\n");
  my $fh = File::ReadBackwards->new($log);
  return unless changes($stream,
    $n,
    sub { $stream->write("## " . shift . "\n") },
    sub { $stream->write(shift . " by " . colourize($stream, shift, $style) . "\n") },
    sub { print_link($stream, @_) },
    sub { $stream->write(join("\n", @_, "")) },
    sub {
    READ:
      return unless $_ = decode_utf8($fh->readline);
      chomp;
      my ($ts, $id_log, $revision, $code) = split(/\x1f/);
      goto READ if $id_log ne $id;
      $ts, $id_log, $revision, $code, $host, $space, 0 },
    undef, #$kept
    undef, #$filter
    $style);
  $stream->write("\n");
  print_link($stream, $host, $space, "More...", "history/" . uri_escape_utf8($id) . "/" . 10 * $n . ($style ? "/$style" : ""));
}

sub footer {
  my $stream = shift;
  my $host = shift;
  my $space = shift;
  my $id = shift;
  my $revision = shift||"";
  my @links;
  push(@links, gemini_link($stream, $host, $space, "History", "history/$id"));
  push(@links, gemini_link($stream, $host, $space, "Raw text", "raw/$id/$revision"));
  push(@links, gemini_link($stream, $host, $space, "HTML", "html/$id/$revision"));
  push(@links, $_->($stream, $host, $space, $id, $revision, "gemini")) for @footer;
  return join("\n", "\n\nMore:", (grep /\S/, @links), ""); # includes a trailing newline
}

sub serve_page {
  my $stream = shift;
  my $host = shift;
  my $space = shift;
  my $id = shift;
  my $revision = shift;
  $log->info("Serve Gemini page $id");
  success($stream);
  $stream->write(encode_utf8 "# $id\n");
  $stream->write(encode_utf8 text($stream, $host, $space, $id, $revision));
  $stream->write(encode_utf8 footer($stream, $host, $space, $id, $revision));
}

sub text {
  my $stream = shift; # used by contributions like oddmuse.pl
  my $host = shift;
  my $space = shift;
  my $id = shift;
  my $revision = shift;
  my $dir = wiki_dir($host, $space);
  return read_text "$dir/keep/$id/$revision.gmi" if $revision and -f "$dir/keep/$id/$revision.gmi";
  return read_text "$dir/page/$id.gmi" if -f "$dir/page/$id.gmi";
  return robots() if $id eq "robots" and not $space;
  return "This this revision is no longer available." if $revision;
  return "This page does not yet exist.";
}

sub robots () {
  my $ban = << 'EOT';
User-agent: *
Disallow: /raw
Disallow: /html
Disallow: /diff
Disallow: /history
Disallow: /do/comment
Disallow: /do/changes
Disallow: /do/all/changes
Disallow: /do/all/latest/changes
Disallow: /do/rss
Disallow: /do/blog/rss
Disallow: /do/atom
Disallow: /do/blog/atom
Disallow: /do/all/atom
Disallow: /do/new

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

  }
  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.
sub space_links {
  my $stream = shift;
  my $scheme = shift;
  my $host = shift;
  my $port = shift;
  my %spaces;
  if (keys %{$server->{host}} > 1) {
    for (keys %{$server->{host}}) {
      $spaces{"$scheme://$_:$port/"} = $_;
    }
    for my $space (@{$server->{wiki_space}}) {
      my ($ahost, $aspace) = split(/\//m, $space, 2);
      $spaces{"$scheme://$ahost:$port/$aspace/"} = $space;
    }
  } elsif (@{$server->{wiki_space}}) {
    $spaces{"$scheme://$host:$port/"} = "Main space";
    for (sort @{$server->{wiki_space}}) {
      $spaces{"$scheme://$host:$port/$_/"} = $_;
    }
  }
  return \%spaces;
}

sub is_upload {
  my $stream = shift;
  my $request = shift;
  $log->info("Looking at $request");
  my $hosts = host_regex();
  my $spaces_regex = space_regex();
  my $port = port($stream);
  if ($request =~ m!^titan://($hosts)(?::$port)?!) {
    my $host = $1;
    my($scheme, $authority, $path, $query, $fragment) =
	$request =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|;
    if ($path =~ m!^(?:/($spaces_regex))?(?:/raw|/page|/file)?/([^/;=&]+(?:;\w+=[^;=&]+)+)!) {
      my $space = $1;
      my ($id, @params) = split(/[;=&]/, $2);
      my $params = { map {decode_utf8(uri_unescape($_))} @params };
      if (valid_params($stream, $host, $space, $id, $params)) {
	return {
	  host => $host,
	  space => space($stream, $host, $space),
	  id => decode_utf8(uri_unescape($id)),
	  params => $params,
	}
      }
    } else {
      $log->debug("The path $path is malformed");
      result($stream, "59", "The path $path is malformed");
      $stream->close_gracefully();
    }
  }
  return 0;
}

sub valid_params {
  my $stream = shift;
  my $host = shift;
  my $space = shift;
  my $id = shift;
  my $params = shift;
  return unless valid_id($stream, $host, $space, $id, $params);
  return unless valid_token($stream, $host, $space, $id, $params);
  return unless valid_mime_type($stream, $host, $space, $id, $params);
  return unless valid_size($stream, $host, $space, $id, $params);
  return 1;
}

sub valid_id {
  my $stream = shift;
  my $host = shift;
  my $space = shift;
  my $id = shift;
  if (not $id) {
    $log->debug("The URL lacks a page name");
    result($stream, "59", "The URL lacks a page name");
    $stream->close_gracefully();
    return;
  } elsif ($id =~ /[[:cntrl:]]/) {
    $log->debug("Page names must not contain any control characters");
    result($stream, "59", "Page names must not contain any control characters");
    $stream->close_gracefully();
    return;
  }
  return 1;
}

sub valid_token {
  my $stream = shift;
  my $host = shift;
  my $space = shift;
  my $id = shift;
  my $params = shift;
  my $token = quotemeta($params->{token}||"");
  my @tokens = @{$server->{wiki_token}};
  push(@tokens, @{$server->{wiki_space_token}->{$space}})
      if $space and $server->{wiki_space_token}->{$space};
  $log->debug("Valid tokens: @tokens");
  $log->debug("Spaces: " . join(", ", keys %{$server->{wiki_space_token}}));
  if (not $token and @tokens) {
    $log->debug("Uploads require a token");
    result($stream, "59", "Uploads require a token");
    $stream->close_gracefully();