view release on metacpan or  search on metacpan

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

# The hostnames we know we want to serve because they were specified via --host
# options.
sub host_regex {
  my $stream = shift;
  my $re = join("|", map { quotemeta domain_to_ascii $_ } keys %{$server->{host}});
  return qr($re)i; # case insensitive hostnames
}

# A regular expression matching wiki spaces in URLs. The tricky part is that we
# must strip the hostnames, as these aren't repeated: for a URL like
# gemini://localhost:1965/alex/ the regular expression must just match 'alex'
# and it's space($stream, 'localhost', 'alex') that will check whether 'alex' is a
# legal space for localhost.
sub space_regex {
  my @spaces;
  if (keys %{$server->{host}} > 1) {
    for (@{$server->{wiki_space}}) {
      my ($space) = /\/(.*)/;
      push(@spaces, $space);
    }
  } 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
    if (run_extensions($stream, $request, $upload, $buffer, $size)) {
      # config file goes first
    } else {
      save_page($stream, $upload->{host}, $upload->{space}, $upload->{id},
		$upload->{params}->{mime}, $buffer, $size);
    }
    alarm(0);
  };
  # save page might still be waiting for the lock so we must not close the
  # stream: save_page will close the stream
  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 || "text/plain";
  my $data = shift;
  my $length = shift;
  # If the operation succeeds, we can close the stream; if the operation fails,
  # we can close the stream; but if the operation was rescheduled, we must not
  # close the stream!
  if ($type ne "text/plain" and $type ne "text/gemini") {
    if ($length == 0) {
      with_lock($stream, $host, $space,
		sub {
		  delete_file($stream, $host, $space, $id);
		  $stream->close_gracefully();
		});
    } else {
      with_lock($stream, $host, $space,
		sub {
		  write_file($stream, $host, $space, $id, $data, $type);
		  $stream->close_gracefully();
		});
    }
  } elsif ($length == 0) {
    with_lock($stream, $host, $space,
	      sub {
		delete_page($stream, $host, $space, $id);
		$stream->close_gracefully();
	      });
  } elsif (utf8::decode($data)) { # decodes in-place and returns success
    with_lock($stream, $host, $space,
	      sub {
		write_page($stream, $host, $space, $id, $data);
		$stream->close_gracefully();
	      });
  } 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;

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

  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();
    return;
  } elsif (not grep(/^$token$/, @tokens)) {
    $log->debug("Your token is the wrong token");
    result($stream, "59", "Your token is the wrong token");
    $stream->close_gracefully();
    return;
  }
  return 1;
}

sub valid_mime_type {
  my $stream = shift;
  my $host = shift;
  my $space = shift;
  my $id = shift;
  my $params = shift;
  my $type = $params->{mime} || "text/plain";
  my ($main_type) = split(/\//, $type, 1);
  my @types = @{$server->{wiki_mime_type}};
  # the wiki always allows text/plain or text/gemini
  if ($type eq "text/plain" or $type eq "text/gemini") {
    return 1;
  } elsif (not @types) {
    $log->debug("This wiki does not allow file uploads");
    result($stream, "59", "This wiki does not allow file uploads");
    $stream->close_gracefully();
    return;
  } elsif (not grep(/^$type$/, @types) and not grep(/^$main_type$/, @types)) {
    $log->debug("This wiki does not allow $type");
    result($stream, "59", "This wiki does not allow $type, only @types");
    $stream->close_gracefully();
    return;
  }
  return 1;
}

sub valid_size {
  my $stream = shift;
  my $host = shift;
  my $space = shift;
  my $id = shift;
  my $params = shift;
  my $size = $params->{size};
  if ($size !~ /^\d+$/) {
    $log->debug("You need to send along the number of bytes, not '$size'");
    result($stream, "59", "You need to send along the number of bytes, not '$size'");
    $stream->close_gracefully();
    return;
  } elsif ($size > $server->{wiki_page_size_limit}) {
    $log->debug("This wiki does not allow more than $server->{wiki_page_size_limit} bytes per page");
    result($stream, "59", "This wiki does not allow more than $server->{wiki_page_size_limit} bytes per page");
    $stream->close_gracefully();
    return;
  }
  return 1;
}

1;

__DATA__