Apache-WebDAV

 view release on metacpan or  search on metacpan

lib/Apache/WebDAV.pm  view on Meta::CPAN

        }
        elsif($handler->test('d', $file))
        {
            push @errors, $file unless $handler->rmdir($file);
        }
    }

    if(@errors)
    {
        return $self->delete_response($r, \@errors);
    }
    else
    {
        return HTTP_NO_CONTENT;
    }
}

#
# Fetch a resource.
#
sub get
{
    my ($self, $r, $handler) = @_;

    my $path = $r->uri();

    # If the requested path is a readable file, use the Filesys::Virtual
    # interface to read the file and send it back to the client.
    if($handler->test('f', $path) && $handler->test('r', $path))
    {
        $r->header_out('Last-Modified', $handler->modtime($path));

        my $fh = $handler->open_read($path) or return NOT_FOUND;

        my $file;

        while(my $line = <$fh>)
        {
            $file .= $line;
        }

        $handler->close_read($fh);

        $r->status(200);
        $r->header_out('Content-Length', length($file));

        $r->send_http_header();
        $r->print($file);

        return OK;
    }
    # If the requested path is a directory, it's unclear what we're supposed to
    # do.  Net::DAV::Server prints an HTML representation of the directory
    # structure.
    #
    # Update: this happens if you connect with a regular browser, or if you
    # connect using IE but don't check the Web Folder box.  So just print a
    # warning.
    elsif($handler->test('d', $path))
    {
        $r->content_type('text/html; charset="utf-8"');
        $r->send_http_header();
        $r->print("If you are using IE, please use File -> Open and check the
                   Open As Web Folder box.");
    }
    else
    {
        return NOT_FOUND;
    }
}

#
# Respond to a head request about a file.
#
sub head
{
    my ($self, $r, $handler) = @_;

    my $path = $r->uri();

    if($handler->test('f', $path))
    {
        $r->header_out('Last-Modified', $handler->modtime($path));
    }
    elsif($handler->test('d', $path))
    {
        $r->content_type('text/html; charset="utf-8"');
        $r->send_http_header();
    }
    else
    {
        return NOT_FOUND;
    }

    return OK;
}

#
# Create a "collection" which is actually a directory.
#
sub mkcol
{
    my ($self, $r, $handler) = @_;

    my $path = $r->uri();

    my $content = $self->get_request_content($r);

    if($content)
    {
        return 415; # huh?
    }
    elsif(!$handler->test('e', $path))
    {
        $handler->mkdir($path);

        if(!$handler->test('d', $path))
        {
            return 409; # What?
        }
        else
        {
            return 201; # Created.
        }
    }
    else
    {
        return HTTP_METHOD_NOT_ALLOWED;
    }
}

#
# Move a resource to another location.  I'm specifically performing a copy and
# then a delete, something that sort of makes sense but has specific drawbacks
# according to the WebDAV book.  We'll worry about it later, because it's
# possible that none of our child modules will ever use this functionality.
#
sub move
{
    my ($self, $r, $handler) = @_;

    my $path = $r->uri();

    my $destination = $r->header_in('Destination');

    $destination = URI->new($destination)->path();

lib/Apache/WebDAV.pm  view on Meta::CPAN

            return 403;
        }
        else
        {
            return FORBIDDEN;
        }
    }

    my $delete_result = $self->delete_resource($r, $handler, $path);

    # Did the delete work properly?
    if(!$delete_result)
    {
        return FORBIDDEN;
    }

    if($already_exists)
    {
        return 204;
    }
    else
    {
        return 201;
    }
}

#
# Specify the options this WebDAV server supports.
#
sub options
{
    my ($self, $r, $handler) = @_;

    $r->header_out('Allow'         => join(',', map { uc } keys %implemented));
    $r->header_out('DAV'           => '1,2,<http://apache.org/dav/propset/fs/1>');
    $r->header_out('MS-Author-Via' => 'DAV');
    $r->header_out('Keep-Alive'    => 'timeout=15, max=96');

    $r->send_http_header();

    return OK;
}

#
# Get information about a file or a directory (or the contents of a directory).
#
sub propfind
{
    my ($self, $r, $handler) = @_;

    my $depth = $r->header_in('Depth');
    my $uri   = $r->uri();

    # Make sure the resource exists
    if(!$handler->test('e', $uri))
    {
        return NOT_FOUND;
    }

    $r->status(207);
    $r->content_type('text/xml; charset="utf-8"');

    my @files;

    if($depth == 0)
    {
        @files = ($uri);
    }
    elsif($depth == 1)
    {
        $uri =~ s/\/$//; # strip trailing slash, we don't store it in the db

        @files = $handler->list($uri);

        # remove . and .. from the list
        @files = grep( $_ !~ /^\.\.?$/, @files );

        # Add a trailing slash to the directory if there isn't one already
        if($uri !~ /\/$/)
        {
            $uri .= '/';
        }

        # Add the current folder to the front of the filename
        @files = map { "$uri$_" } @files;

        # Goliath only doesn't want to see the current/base directory in the
        # response.
        if($r->header_in('User-Agent') !~ /Goliath/)
        {
            push @files, $uri;
        }
    }

    my %wanted_properties = $self->get_wanted_properties($r);

    # The list of properties in order which a stat() call must return.
    my @properties = qw(dev ino mode nlink uid gid rdev getcontentlength
                        atime getlastmodified creationdate);

    # Loop through all the files and call stat() on each one.  Keep track of
    # which properties the client requested.
    my @results;

    foreach my $path (@files)
    {
        my %stat;
        my $info;

        my $handler = $self->get_handler_for_path($path);

        $info->{'getcontenttype'} = 'application/octet-stream';
        $info->{'resourcetype'}   = '';

        if($handler->test('d', $path))
        {
            $info->{'getcontenttype'} = 'httpd/unix-directory';
            $info->{'resourcetype'}   = 'collection';
        }

        @stat{@properties} = $handler->stat($path);

lib/Apache/WebDAV.pm  view on Meta::CPAN

#
#
# Helper methods below here.
#
#

#
# This method builds up an xml response to a delete request ONLY IF the delete
# request had errors.  A delete request with no errors sends only a header, not
# an associated XML document.  So again, this method is only used when an error
# occurs.
#
# @arg $r apache object
# @arg $files arrayref of files that had errors
#
# @ret 200 OK
#
sub delete_response
{
    my ($self, $r, $files) = @_;

    # This is a bit screwed up.  WebDrive doesn't properly parse 207 multistatus
    # responses for deletes.  So if it's webdrive, just send a generic error
    # code.  I know this sucks but the majority of our users use webdrive so
    # we have to do it.
    #
    # Here is the response from their tech support:
    # 
    # webdrive is not parsing the 207 multistatus response to look for the
    # error code.  If the DELETE returns an HTTP error like 403 instead of
    # 207 then webdrive would recognize the error.  Webdrive should parse
    # the response but currently it doesn't for the DELETE command.
    # It's nothing you are doing wrong, it's just something that wasn't
    # fully implemented with webdrive and the delete command.
    #
    if($r->header_in('User-Agent') =~ /WebDrive/)
    {
        $r->status(FORBIDDEN);
        $r->send_http_header();
        return OK;
    }

    my $doc = new XML::LibXML::Document('1.0', 'utf-8');
    my $multistat = $doc->createElement('D:multistatus');

    $multistat->setAttribute('xmlns:D', 'DAV:');
    $doc->setDocumentElement($multistat);

    foreach my $file (@$files)
    {
        my $response = $doc->createElement('D:response');

        $response->appendTextChild('D:href'   => $file);
        $response->appendTextChild('D:status' => 'HTTP/1.1 403 Forbidden');

        $multistat->addChild($response);
    }

    $r->status(207);
    $r->content_type('text/xml; charset="utf-8"');
    $r->send_http_header();

    if(!$r->header_only())
    {
        $r->print($doc->toString(1));
    }

    return OK;
}

#
# Build up a WebDAV flavored XML document containing a list of files in a
# directory.  Most of this was copied from Net::DAV::Server, but I took out
# all the stuff specific to HTTP::Daemon, HTTP::Request and HTTP::Response
# (so it would be compatible with apache/mod_perl).
#
# @arg $r apache object
# @arg $files arrayref of files [{path => $path, stat => $info}, {etc...}]
#
# @ret 200 OK
#
sub list_response
{
    my ($self, $r, $files) = @_;

    my $doc = new XML::LibXML::Document('1.0', 'utf-8');
    my $multistat = $doc->createElement('D:multistatus');

    $multistat->setAttribute('xmlns:D', 'DAV:');
    $doc->setDocumentElement($multistat);

    foreach my $file (@$files)
    {
        my $path = $file->{'path'};
        my $stat = $file->{'stat'};
        my $resp = $doc->createElement('D:response');

        $multistat->addChild($resp);

        my $href = $doc->createElement('D:href');

        $href->appendText(
            File::Spec->catdir(
                map { uri_escape encode_utf8 $_ } File::Spec->splitdir($path)
            )
        );

        $resp->addChild($href);

        my $okprops = $doc->createElement('D:prop');

        foreach my $wanted_prop (keys %$stat)
        {
            # We set these down there automatically (we are faking quota
            # support to keep webdrive happy).
            next if $wanted_prop eq 'quota';
            next if $wanted_prop eq 'quotaused';
            next if $wanted_prop eq 'quota-available-bytes';
            next if $wanted_prop eq 'quota-used-bytes';
            next if $wanted_prop eq 'quota-assigned-bytes';