view release on metacpan or  search on metacpan

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

Disallow: /do/match
Disallow: /do/search
# allowing /do/index!
Crawl-delay: 10
EOT
}

sub oddmuse_serve_page {
  my $stream = shift;
  my $host = shift;
  my $space = shift;
  my $id = shift;
  my $revision = shift;
  # cannot use text() because we don't know if we're serving a file or plain
  # text when querying Oddmuse
  my $page = oddmuse_get_page($stream, $host, $space, $id, $revision) // return;
  if (my ($type, $data) = $page =~ /^#FILE (\S+) ?(?:\S+)?\n(.*)/s) {
    oddmuse_serve_file_page($stream, $id, $type, $data);
  } else {
    my $text = oddmuse_gemini_text($stream, $host, $space, $page, $id);
    oddmuse_serve_gemini_page($stream, $host, $space, $id, $text, $revision);
  }
}

# this is required when combining gopher with oddmuse!
*oddmuse_text_old = \&App::Phoebe::text;
*App::Phoebe::text = \&oddmuse_text_new;

sub oddmuse_text_new {
  my ($stream, $host, $space, $id, $revision) = @_;
  if (exists $oddmuse_wikis{$host}) {
    my $text = oddmuse_get_page(@_);
    return oddmuse_gemini_text($stream, $host, $space, $text, $id);
  } else {
    return oddmuse_text_old(@_);
  }
}

sub oddmuse_get_page {
  my $stream = shift;
  my $host = shift;
  my $space = shift;
  my $id = shift;
  my $revision = shift;
  my $url = "$oddmuse_wikis{$host}";
  $url .= "/$space" if $space;
  $url .= "/raw/" . uri_escape_utf8($id);
  $url .= "?revision=$revision" if $revision;
  return oddmuse_get_raw($stream, $url);
}

# It would be cool if this were streaming...
sub oddmuse_get_raw {
  my $stream = shift;
  my $url = shift;
  $log->debug("Requesting $url");
  my $ua = Mojo::UserAgent->new;
  my $res = $ua->get($url => {'X-Forwarded-For' => $stream->handle->peerhost})->result;
  if ($res->is_success) {
    return $res->text;
  } elsif ($res->code == 404) {
    return "";
  }
  oddmuse_http_error($stream, $res->code, $res->message, $url); # false
}

sub oddmuse_http_error {
  my $stream = shift;
  my $code = shift;
  my $message = shift;
  my $url = shift;
  if ($code >= 200 and $code < 300) { $code = 20 }
  elsif ($code == 301) { $code = 31 }
  elsif ($code >= 300 and $code < 400) { $code = 30 }
  elsif ($code == 403) { $code = 60 }
  elsif ($code == 404) { $code = 51 }
  elsif ($code == 405) { $code = 59 }
  elsif ($code >= 400 and $code < 500) { $code = 50 }
  elsif ($code >= 500 and $code < 600) { $code = 40 }
  else { $code = 50 }
  $log->warn("$code $message requesting $url");
  $stream->write(encode_utf8 "$code $message\r\n");
  return; # false
}

sub oddmuse_serve_file_page {
  my $stream = shift;
  my $id = shift;
  my $type = shift;
  my $data = shift;
  $log->info("Serving $id as $type file");
  $data = decode_base64($data);
  $log->debug("Bytes: " . length($data));
  success($stream, $type);
  binmode(STDOUT, ":raw");
  $stream->write($data);
}

sub oddmuse_serve_gemini_page {
  my $stream = shift;
  my $host = shift;
  my $space = shift;
  my $id = shift;
  my $text = shift;
  my $revision = shift;
  $log->info("Serve page $id");
  success($stream);
  $stream->write(encode_utf8 "# " . normal_to_free($id) . "\n");
  $stream->write(encode_utf8 $text);
  if (not $revision and $id !~ /^Comments_on_(.*)/) {
    my $comments = oddmuse_get_page($stream, $host, $space, "Comments_on_$id");
    if ($comments) {
      $stream->write("\n\n## Comments\n");
      $stream->write(encode_utf8 oddmuse_gemini_text($stream, $host, $space, $comments, $id));
    }
  }
  $stream->write(encode_utf8 oddmuse_footer($stream, $host, $space, $id));
}

sub oddmuse_gemini_text {
  my $stream = shift;
  my $host = shift;
  my $space = shift;
  my $text = shift;
  my $id = shift;
  # escape the preformatted blocks
  my $ref = 0;
  my @escaped;
  my $link_regex = "([-,.()'%&!?;<> _1-9A-Za-z\x{0080}-\x{fffd}]|[-,.()'%&!?;<> _0-9A-Za-z\x{0080}-\x{fffd}][-,.()'%&!?;<> _0-9A-Za-z\x{0080}-\x{fffd}]+)";
  my $wiki_word = '(\p{Uppercase}+\p{Lowercase}+\p{Uppercase}\p{Alphabetic}*)';
  # newline magic: the escaped block does not include the newline; it is
  # retained in $text so that the following rules still deal with newlines
  # correctly; when we replace the escaped blocks back in, they'll be without
  # the trailing newline and fit right in.
  $text =~ s/^(```.*?\n```)\n/push(@escaped, $1); "\x03" . $ref++ . "\x04\n"/mesg;
  $text =~ s/^<pre>\n?(.*?\n)<\/pre>\n?/push(@escaped, "```\n$1```\n"); "\x03" . $ref++ . "\x04\n"/mesg;