App-phoebe
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));
( run in 0.327 second using v1.01-cache-2.11-cpan-eab888a1d7d )