package provide vfs::webdav 0.2

package require dom
package require vfs 1.0
package require http 2.6
# part of tcllib
package require base64

# This works for very basic operations.
# It has been put together, so far, largely by trial and error!
# What it really needs is to be filled in with proper xml support,
# using the tclxml package.

namespace eval vfs::webdav {}

proc vfs::webdav::Mount {dirurl local} {
    ::vfs::log "http-vfs: attempt to mount $dirurl at $local"
    if {[string index $dirurl end] != "/"} {
        append dirurl "/"
    }
    if {[string range $dirurl 0 6] == "http://"} {
        set rest [string range $dirurl 7 end]
    } else {
        set rest $dirurl
        set dirurl "http://${dirurl}"
    }
    
    if {![regexp {(([^:]*)(:([^@]*))?@)?([^/]*)(/(.*/)?([^/]*))?$} $rest \
            junk junk user junk pass host junk path file]} {
        return -code error "Sorry I didn't understand\
          the url address \"$dirurl\""
    }
    
    if {[string length $file]} {
        return -code error "Can only mount directories, not\
          files (perhaps you need a trailing '/' - I understood\
          a path '$path' and file '$file')"
    }
    
    if {![string length $user]} {
        set user anonymous
    }
    
    set dirurl "http://$host/$path"
    
    set extraHeadersList [list Authorization \
            [list Basic [base64::encode ${user}:${pass}]]]

    set token [::http::geturl $dirurl -headers $extraHeadersList -validate 1]
    http::cleanup $token
    
    if {![catch {vfs::filesystem info $dirurl}]} {
        # unmount old mount
        ::vfs::log "ftp-vfs: unmounted old mount point at $dirurl"
        vfs::unmount $dirurl
    }
    ::vfs::log "http $host, $path mounted at $local"
    vfs::filesystem mount $local [list vfs::webdav::handler \
            $dirurl $extraHeadersList $path]
    # Register command to unmount
    vfs::RegisterMount $local [list ::vfs::webdav::Unmount $dirurl]
    return $dirurl
}

proc vfs::webdav::Unmount {dirurl local} {
    vfs::filesystem unmount $local
}

proc vfs::webdav::handler {dirurl extraHeadersList path cmd root relative actualpath args} {
    ::vfs::log "handler $dirurl $path $cmd"
    if {$cmd == "matchindirectory" || $cmd == "open"} {
        eval [list $cmd $dirurl $extraHeadersList $relative $actualpath] $args
    } else {
    ::vfs::log "[list $cmd $dirurl $extraHeadersList $relative] $args"
        eval [list $cmd $dirurl $extraHeadersList $relative] $args
    }
}

# If we implement the commands below, we will have a perfect
# virtual file system for remote http sites.

proc vfs::webdav::stat {dirurl extraHeadersList name} {
    ::vfs::log "stat $name"
#    ::vfs::log "geturl $dirurl$name"
    set token [::http::geturl $dirurl$name -method PROPFIND \
      -headers [concat $extraHeadersList [list Depth 0]] -protocol 1.1]
    upvar #0 $token state
    set httpcode [lindex [split $state(http) " "] 1]
        if {$httpcode != 200 && $httpcode != 207} {
                ::vfs::log "No good: $state(http)"
                #parray state
                ::http::cleanup $token
                return [vfs::filesystem posixerror [::vfs::posixError ENOENT]]
        }
    set data [::http::data $token]
    ::http::cleanup $token
    ::vfs::log $data
        set xmldoc [::dom::parse $data]
        #TODO other stat info
        set resourcetype [::dom::selectNode $xmldoc {/d:multistatus/d:response/d:propstat/d:prop/d:resourcetype/d:collection} -namespaces {d DAV:}]
        if {$resourcetype != ""} {
                set type "directory"
        } else {
                set type "file" 
        }
        set filesize [::dom::selectNode $xmldoc {/d:multistatus/d:response/d:propstat/d:getcontentlength} -namespaces {d DAV:}]
        if {$filesize != ""} {
                set filesize [$filesize stringValue]
        } else {
                set filesize 0
        }
    return [list dev -1 uid -1 gid -1 nlink 1 depth 0 size $filesize atime 0 mtime 0 ctime 0 mode 777 type $type]
}

proc vfs::webdav::access {dirurl extraHeadersList name mode} {
    ::vfs::log "access $name $mode"
    if {$name == ""} { return 1 }
    set token [::http::geturl $dirurl$name -headers $extraHeadersList]
    upvar #0 $token state
    set httpcode [lindex [split $state(http) " "] 1]
        if {$httpcode != 200 && $httpcode != 207} {
                ::vfs::log "No good: $state(http)"
                #parray state
                ::http::cleanup $token
                return 0
        } else {
        ::http::cleanup $token
        return 1
    }
}

# We've chosen to implement these channels by using a memchan.
# The alternative would be to use temporary files.
proc vfs::webdav::open {dirurl extraHeadersList name actualpath mode permissions} {
    ::vfs::log "open $name $actualpath $mode $permissions"
    # return a list of two elements:
    # 1. first element is the Tcl channel name which has been opened
    # 2. second element (optional) is a command to evaluate when
    #    the channel is closed.
    set resultchannel [vfs::memchan]
    fconfigure $resultchannel -encoding binary -translation binary
    if {$mode == ""} { set mode "r" }
    if {[file isdirectory $actualpath]} {
            ::vfs::log "can not read/write to directory."
            return [vfs::filesystem posixerror [::vfs::posixError EISDIR]]
    }
    # There is a tricky part. we need to download the file from server in all cases where it must exists
    # r, r+ and a absolutly need the file
    # w, w+ do not need the file at all
    # a+ works with file and without
    if {[string match "\[ar\]*" $mode ]} {
            # we should at least try to download the file.
            set token [::http::geturl $dirurl$name -headers $extraHeadersList]
            upvar #0 $token state
            set httpcode [lindex [split $state(http) " "] 1]
            if {$httpcode != 200} {
                    # TODO give better error message.
                    if {[string match "r*" $mode] || [string equal $mode "a"]} {
                            ::vfs::log "File not found"
                            ::http::cleanup $token
                            close $resultchannel
                            return [vfs::filesystem posixerror [::vfs::posixError ENOENT]]
                    }
            } else {
                    # load file into buffer
                    puts -nonewline $resultchannel [::http::data $token]
                    ::http::cleanup $token
            }
    }
    # we need to handle uploading of the file back if writing is permitted.
    # r+, w, w+, a, a+
    # The pointer is at the beginning for: r+, w, w+
    switch -glob -- $mode {
                "" -
                "r" {
                        seek $resultchannel 0
                        return [list $resultchannel]
                }
                "r+" -
                "w" -
                "w+" {
                        seek $resultchannel 0
                }
                "a" -
                "a+" {
                        # reading and writing file created if it does not exist. position at end of file
                        # seeking does not work but we should already be at the end.
                }
                default {
                        close $resultchannel
                        return -code error "illegal access mode \"$mode\""
                }
    }
    ::vfs::log "[list $resultchannel [list ::vfs::webdav::_closing $dirurl$name $resultchannel $extraHeadersList]]"
    return [list $resultchannel [list ::vfs::webdav::_closing $dirurl$name $resultchannel $extraHeadersList]]
}
proc vfs::webdav::_closing {url channel extraHeadersList} {
        ::vfs::log "_closing $url $channel $extraHeadersList"
        seek $channel 0
        set token [::http::geturl $url -headers $extraHeadersList -method PUT -querychannel $channel]
        upvar #0 $token state
    set httpcode [lindex [split $state(http) " "] 1]
    if {$httpcode > 204} {
                    # TODO give better error message.
                    ::vfs::log "Error Writing: $httpcode"
                    ::http::cleanup $token
                        return [vfs::filesystem posixerror [::vfs::posixError EIO]]
        }
        ::vfs::log "Upload successfull"
        ::http::cleanup $token
}
proc vfs::webdav::matchindirectory {dirurl extraHeadersList path actualpath pattern type} {
    ::vfs::log "matchindirectory $dirurl $path $actualpath $pattern $type"
    set res [list]
    if {[string length $pattern]} {
                # need to match all files in a given remote http site.
                set token [::http::geturl $dirurl$path -method PROPFIND \
                  -headers [concat $extraHeadersList [list Depth 1]]]
                upvar #0 $token state
                set httpcode [lindex [split $state(http) " "] 1]
                if {$httpcode != 200 && $httpcode != 207} {
                        ::vfs::log "No good: $state(http)"
                        ::http::cleanup $token
                        return [vfs::filesystem posixerror [::vfs::posixError ENOENT]]
                }
                set body [::http::data $token]
                ::http::cleanup $token
                set xmldoc [::dom::parse $body]
                set data [::dom::selectNode $xmldoc {/d:multistatus/d:response/d:href} -namespaces {d DAV:}]
                set currentdir [lindex $data 0]
                set content [lrange $data 1 end]
                foreach node $content {
                        # strip path
                        set itemname [string map [list [$currentdir stringValue] ""] [$node stringValue]]
                        if {[string index $itemname end] == "/"} {
                                # Directories should not be show with slash at the end but without.
                                set itemname [string range $itemname 0 end-1]
                        }
                        if {[string match $pattern $itemname]} {
                                if {$type == 0} {
                                        lappend res [file join $actualpath $itemname]
                                } else {
                                        eval lappend res [_matchtypes [$node parent] [file join $actualpath $itemname] $type]        
                                }
                                #vfs::log "match: $itemname"
                        }
                }
    } else {
                # single file
                set token [::http::geturl $dirurl$path -method PROPFIND \
                  -headers [concat $extraHeadersList [list Depth 0]]]
        
                upvar #0 $token state
                set httpcode [lindex [split $state(http) " "] 1]
                if {$httpcode != 200 && $httpcode != 207} {
                        ::vfs::log "No good: $state(http)"s
                        ::http::cleanup $token
                        return [vfs::filesystem posixerror [::vfs::posixError ENOENT]]
                }
                set body [::http::data $token]
                ::http::cleanup $token
                set xmldoc [::dom::parse $body]
                set response [::dom::selectNode $xmldoc {/d:multistatus/d:response} -namespaces {d DAV:}]
                #::vfs::log $body
                eval lappend res [_matchtypes $response $actualpath $type]
    } 
    return $res
}

# Helper function
proc vfs::webdav::_matchtypes {item actualpath type} {
    #::vfs::log [list $item $actualpath $type]
    if {[$item selectNode $item {d:propstat/d:prop/d:resourcetype/d:collection} -namespaces {d DAV:}] != ""} {
                if {![::vfs::matchDirectories $type]} {
                        return ""
                }
    } else {
                if {![::vfs::matchFiles $type]} {
                        return ""
                }
    }
    return [list $actualpath]
}

proc vfs::webdav::createdirectory {dirurl extraHeadersList name} {
    ::vfs::log "createdirectory $dirurl $extraHeadersList $name"
    set token [::http::geturl $dirurl$name -method MKCOL \
                  -headers [concat $extraHeadersList [list Depth 0]]]
        upvar #0 $token state
        set httpcode [lindex [split $state(http) " "] 1]
        ::http::cleanup $token
        if {$httpcode == 201} {
                return 1
        }
        ::vfs::log "No good: $state(http)"
        switch -- $httpcode {
                403 {
                        return [vfs::filesystem posixerror [::vfs::posixError EACCES]]
                }
                507 {
                        return [vfs::filesystem posixerror [::vfs::posixError ENOSPC]]
                }
                409 {
                        return [vfs::filesystem posixerror [::vfs::posixError ENOENT]]
                }
                405 {
                        return [vfs::filesystem posixerror [::vfs::posixError EPERM]]
                }
        }
        return [vfs::filesystem posixerror [::vfs::posixError ENODEV]]
}

proc vfs::webdav::removedirectory {dirurl extraHeadersList name recursive} {
    ::vfs::log "removedirectory $dirurl $name $recursive"
    # deletion is always recursive.
    
    set token [::http::geturl $dirurl$name -method DELETE -headers $extraHeadersList]
        upvar #0 $token state
        set httpcode [lindex [split $state(http) " "] 1]
        set body [::http::data $token]
        ::vfs::log "$state(http)"
        ::http::cleanup $token
        switch -- $httpcode {
                404 {
                        return [vfs::filesystem posixerror [::vfs::posixError ENOENT]]
                }
                204 -
                200 {
                        return 1
                }
                - {
                    return [vfs::filesystem posixerror [::vfs::posixError ENOTEMPTY]]
                }
        }
}

proc vfs::webdav::deletefile {dirurl extraHeadersList name} {
    ::vfs::log "deletefile $name"
    removedirectory $dirurl $extraHeadersList $name 0
}

proc vfs::webdav::fileattributes {dirurl extraHeadersList path args} {
    ::vfs::log "fileattributes $args"
    switch -- [llength $args] {
        0 {
            # list strings
            return [list]
        }
        1 {
            # get value
            set index [lindex $args 0]
        }
        2 {
            # set value
            set index [lindex $args 0]
            set val [lindex $args 1]
             return [vfs::filesystem posixerror [::vfs::posixError ENOSYS]]
        }
    }
}

proc vfs::webdav::utime {dirurl extraHeadersList path actime mtime} {
     return [vfs::filesystem posixerror [::vfs::posixError ENOSYS]]
}

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References