view release on metacpan or  search on metacpan

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

    }
  } 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") {
    if ($length == 0) {
      with_lock($stream, $host, $space, sub { delete_file($stream, $host, $space, $id) } );
    } else {
      with_lock($stream, $host, $space, sub { write_file($stream, $host, $space, $id, $data, $type) } );
    }
  } elsif ($length == 0) {
    with_lock($stream, $host, $space, sub { delete_page($stream, $host, $space, $id) } );
  } elsif (utf8::decode($data)) { # decodes in-place and returns success
    with_lock($stream, $host, $space, sub { write_page($stream, $host, $space, $id, $data) } );
  } else {
    $log->debug("The text is invalid UTF-8");
    result($stream, "59", "The text is invalid UTF-8");
    $stream->close_gracefully();
  }
}

# We can't use C<flock> because this defaults to C<fcntl> which means they are
# I<per process>
sub with_lock {
  my $stream = shift;
  my $host = shift;
  my $space = shift;
  my $code = shift;
  my $count = shift || 0;
  my $dir = wiki_dir($host, $space);
  my $lock = "$dir/locked";
  # remove stale locks
  if (-e $lock) {
    my $age = time() - modified($lock);
    $log->debug("lock is ${age}s old");
    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");
    }
    rmdir($lock);
    $stream->close_gracefully();

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

    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 } read_lines $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\?!) {
      serve_match($stream, $host, space($stream, $host, $space), decode_utf8(uri_unescape($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_utf8(uri_unescape($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));