view release on metacpan or  search on metacpan

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

      $okprops->addChild($prop);
      $prop = $doc->createElement('D:getcontenttype');
      $prop->appendText($mime);
      $okprops->addChild($prop);
      $prop = $doc->createElement('D:getlastmodified');
      $prop->appendText($mtime);
      $okprops->addChild($prop);
      $prop = $doc->createElement('D:resourcetype');
      if ($is_dir) {
	my $col = $doc->createElement('D:collection');
	$prop->addChild($col);
      }
      $okprops->addChild($prop);
    }
    if ($okprops->hasChildNodes) {
      my $propstat = $doc->createElement('D:propstat');
      $propstat->addChild($okprops);
      my $stat = $doc->createElement('D:status');
      $stat->appendText('HTTP/1.1 200 OK');
      $propstat->addChild($stat);
      $resp->addChild($propstat);
    }
    if ($nfprops->hasChildNodes) {
      my $propstat = $doc->createElement('D:propstat');
      $propstat->addChild($nfprops);
      my $stat = $doc->createElement('D:status');
      $stat->appendText('HTTP/1.1 404 Not Found');
      $propstat->addChild($stat);
      $resp->addChild($propstat);
    }
  }
  my $str = $doc->toString(1);
  my $len = length($str);
  $log->debug("RESPONSE: 207\n" . $doc->toString(1));
  $stream->write("HTTP/1.1 207 Multi-Status\r\n");
  $stream->write("Content-Type: application/xml; charset=\"utf-8\"\r\n");
  $stream->write("Content-Length: $len\r\n");
  if ($path =~ m!/(page|raw|file|login)$!) {
    $stream->write("Content-Location: $path/\r\n");
  }
  $stream->write("\r\n");
  $stream->write($str);
}

sub to_url {
  my $space = shift;
  my $resource = shift;
  my $href;
  $href .= "/" . uri_escape_utf8($space) if $space;
  # split doesn't produce empty fields at the end
  my $d = substr($resource, -1) eq "/";
  $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 {

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

  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+)/) {
    $log->info("Missing authorization header");
    $stream->write("HTTP/1.1 401 Unauthorized\r\n");
    $stream->write("WWW-Authenticate: Basic realm=\"Phoebe\"\r\n");
    $stream->write("\r\n");
    return;
  }
  my $bytes = b64_decode $1;
  my ($userid, $token) = split(/:/, $bytes, 2);
  if (not $token) {
    $log->info("Token required (one of @tokens)");
    $stream->write("HTTP/1.1 401 Unauthorized\r\n");
    $stream->write("WWW-Authenticate: Basic realm=\"Phoebe\"\r\n");
    $stream->write("\r\n");
    return;
  }
  if (not grep(/^$token$/, @tokens)) {
    $log->info("Wrong token ($token)");
    $stream->write("HTTP/1.1 401 Unauthorized\r\n");
    $stream->write("WWW-Authenticate: Basic realm=\"Phoebe\"\r\n");
    $stream->write("\r\n");
    return;
  }
  return 1;
}

sub guess_mime_type {
  my $SH = new IO::Scalar shift;
  return mimetype($SH);
}

1;