view release on metacpan or  search on metacpan

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

  $href .= join("/", map { uri_escape_utf8($_) } split (/\//, $resource));
  $href .= "/" if $d;
  return $href;
}

sub put {
  my ($stream, $host, $space, $path, $id, $headers, $buffer) = @_;
  return unless authorize($stream, $host, $space, $headers);
  return remove($stream, $host, $space, $path, $id, $headers) if length($buffer) == 0;
  my $mime = $headers->{"content-type"} // guess_mime_type(\$buffer);
  return webdav_error($stream, "Content type not known") unless $mime;
  return webdav_error($stream, "Page name is missing") unless $id;
  return webdav_error($stream, "Page names must not control characters") if $id =~ /[[:cntrl:]]/;
  # We don't need to close the stream because this is called via process_gemini
  # which always closes the stream in the end.
  if ($path eq "/file/$id") {
    with_lock($stream, $host, $space, sub { write_file($stream, $host, $space, $id, $buffer, $mime) } );
  } else {
    my $text = decode_utf8 $buffer // "";
    $text =~ s/\r\n/\n/g; # fix DOS EOL convention
    with_lock($stream, $host, $space, sub { write_page($stream, $host, $space, $id, $text) } );
  }
  return 1;
}

sub write_page {
  my $stream = shift;
  my $host = shift;
  my $space = shift;
  my $id = shift;
  my $text = shift;
  my $dir = wiki_dir($host, $space);
  my $file = "$dir/page/$id.gmi";
  my $revision = 0;
  my $new = 0;
  if (-e $file) {
    my $old = read_text $file;
    if ($old eq $text) {
      $log->info("$id is unchanged");
      $stream->write("HTTP/1.1 200 OK\r\n");
      $stream->write("\r\n");
      return;
    }
    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;
    }
    rename $file, "$dir/keep/$id/$revision.gmi";
  } else {
    my $index = "$dir/index";
    if (not open(my $fh, ">>:encoding(UTF-8)", $index)) {
      $log->error("Cannot write index $index: $!");
      return webdav_error($stream, "Unable to write index");
    } else {
      say $fh $id;
      close($fh);
    }
    $new = 1;
  }
  my $changes = "$dir/changes.log";
  if (not open(my $fh, ">>:encoding(UTF-8)", $changes)) {
    $log->error("Cannot write log $changes: $!");
    return webdav_error($stream, "Unable to write log");
  } else {
    my $peerhost = $stream->handle->peerhost;
    say $fh join("\x1f", scalar(time), $id, $revision + 1, bogus_hash($peerhost));
    close($fh);
  }
  mkdir "$dir/page" unless -d "$dir/page";
  eval { write_text($file, $text) };
  if ($@) {
    $log->error("Unable to save $id: $@");
    return webdav_error($stream, "Unable to save $id");
  } else {
    $log->info("Wrote $id");
    if ($new) {
      $stream->write("HTTP/1.1 201 Created\r\n");
    } else {
      $stream->write("HTTP/1.1 200 OK\r\n");
    }
    $stream->write("\r\n");
  }
}

sub write_file {
  my $stream = shift;
  my $host = shift;
  my $space = shift;
  my $id = shift;
  my $data = shift;
  my $type = shift;
  my $dir = wiki_dir($host, $space);
  my $file = "$dir/file/$id";
  my $meta = "$dir/meta/$id";
  my $new = 0;
  if (-e $file) {
    my $old = read_binary($file);
    if ($old eq $data) {
      $log->info("$id is unchanged");
      $stream->write("HTTP/1.1 200 OK\r\n");
      $stream->write("\r\n");
      return;
    }
    $new = 1;
  }
  my $changes = "$dir/changes.log";
  if (not open(my $fh, ">>:encoding(UTF-8)", $changes)) {
    $log->error("Cannot write log $changes: $!");
    return webdav_error($stream, "Unable to write log");
  } else {
    my $peerhost = $stream->handle->peerhost;
    say $fh join("\x1f", scalar(time), $id, 0, bogus_hash($peerhost));
    close($fh);
  }
  mkdir "$dir/file" unless -d "$dir/file";
  eval { write_binary($file, $data) };
  if ($@) {
    $log->error("Unable to save $id: $@");
    return webdav_error($stream, "Unable to save $id");
  }
  mkdir "$dir/meta" unless -d "$dir/meta";
  eval { write_text($meta, "content-type: $type\n") };
  if ($@) {
    $log->error("Unable to save metadata for $id: $@");
    return webdav_error($stream, "Unable to save metadata for $id");
  }
  $log->info("Wrote $id");
  if ($new) {
    $stream->write("HTTP/1.1 201 Created\r\n");
  } else {
    $stream->write("HTTP/1.1 200 OK\r\n");
  }
  $stream->write("\r\n");
}

# Can't use "delete" as a name because that's a keyword...
sub remove {
  my ($stream, $host, $space, $path, $id, $headers) = @_;
  return unless authorize($stream, $host, $space, $headers);
  return webdav_error($stream, "Page name is missing") unless $id;
  return webdav_error($stream, "Page names must not control characters") if $id =~ /[[:cntrl:]]/;
  # We don't need to close the stream because this is called via process_gemini
  # which always closes the stream in the end.
  if ($path eq "/file/$id") {
    with_lock($stream, $host, $space, sub { delete_file($stream, $host, $space, $id) } );
  } else {
    with_lock($stream, $host, $space, sub { delete_page($stream, $host, $space, $id) } );
  }
}

sub delete_page {
  my $stream = shift;
  my $host = shift;
  my $space = shift;
  my $id = shift;
  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 } split /\n/, read_text $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: $!");
    return webdav_error($stream, "Unable to write log");
  } else {
    my $peerhost = $stream->handle->peerhost;
    say $fh join("\x1f", scalar(time), $id, "🖹", bogus_hash($peerhost));
    close($fh);
  }
  $log->info("Deleted page $id");
  $stream->write("HTTP/1.1 204 No Content\r\n");
  $stream->write("\r\n");
}

sub delete_file {
  my $stream = shift;
  my $host = shift;
  my $space = shift;
  my $id = shift;
  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: $!");
    return webdav_error($stream, "Unable to write log");
  } else {
    my $peerhost = $stream->handle->peerhost;
    say $fh join("\x1f", scalar(time), $id, "🖻", bogus_hash($peerhost));
    close($fh);
  }
  $log->info("Deleted file $id");
  $stream->write("HTTP/1.1 204 No Content\r\n");
  $stream->write("\r\n");
}

sub copy {
  my ($stream, $host, $space, $path, $id, $headers) = @_;
  return unless authorize($stream, $host, $space, $headers);
  return webdav_error($stream, "Page name is missing") unless $id;
  return webdav_error($stream, "Page names must not control characters") if $id =~ /[[:cntrl:]]/;
  my $destination = $headers->{destination};
  return webdav_error($stream, "Destination is missing") unless $destination;
  my $dir = wiki_dir($host, $space);
  my $source;
  if ($path =~ m!^/raw/!) {
    $source = "$dir/page/$id.gmi";
  } else {
    $source = "$dir/file/$id";
  }
  $log->debug("Copying $source");
  return webdav_error($stream, "Resource is missing") unless -e $source;
  my $data = read_binary($source);
  # figure out the destination
  my $hosts = host_regex();
  my $port = port($stream);
  my $spaces = space_regex();
  my ($dest_host, $dest_space, $dest_path, $dest_id) =
      $destination =~ m!^https://($hosts)(?::$port)(?:/($spaces))?(/(?:file|raw)/([^/]*))!;
  if ($dest_id) {
    put($stream, $host, space($stream, $host, $dest_space), $dest_path, decode_utf8(uri_unescape($dest_id)), $headers, $data);
  } else {
    return webdav_error($stream, "Copying to remote servers not supported");
  }
}

sub move {
  remove(@_) if copy(@_);
}

sub webdav_error {
  my $stream = shift;
  my $message = shift || "Bad Request";
  $log->error($message);
  $stream->write("HTTP/1.1 400 $message\r\n");
  $stream->write("Content-Type: text/plain\r\n");
  $stream->write("\r\n");
  $stream->close_gracefully();
  return 0;
}

sub authorize {
  my ($stream, $host, $space, $headers) = @_;
  my @tokens = @{$server->{wiki_token}};
  push(@tokens, @{$server->{wiki_space_token}->{$space}})
      if $space and $server->{wiki_space_token}->{$space};
  return 1 unless  @tokens;
  my $auth = $headers->{"authorization"};
  if (not $auth or $auth !~ /^Basic (\S+)/) {