tclvfs now contains the first vague attempts at a 'webdav' implementation in Tcl.
Gotisch - 2011-12-17 20:02:43
I updated the webdavvfs.tcl and post it here in case someelse wants the updated version.
I started by using the tclxml package and redoing some of the already implemented features which didnt work for me anymore (going into directory for example) and added creating / deleting directories.
for the writing to files, im not quiet sure how webdav handles that. afaik its simple a PUT request to the url of the file with the new files body as content. but im not sure how it must be encoded and if tcl's http package can handle that.
if it can its probably as easy as using the an in memory stream and just appending that to the http geturl request.
I also started adding the posix errors, but they turn out to be not correct for the system im on (at least i added "Function not implemented" but tcl kept throwing "File exists")
attached the updated code.
package provide vfs::webdav 0.1
package require vfs 1.0
package require http 2.6
package require dom
# 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"} {
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 mode permissions} {
::vfs::log "open $name $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.
switch -glob -- $mode {
"" -
"r" {
set token [::http::geturl $dirurl$name -headers $extraHeadersList]
upvar #0 $token state
set filed [vfs::memchan]
fconfigure $filed -encoding binary -translation binary
puts -nonewline $filed [::http::data $token]
seek $filed 0
::http::cleanup $token
return [list $filed]
}
"a" -
"w*" {
return [vfs::filesystem posixerror [::vfs::posixError ENOSYS]]
}
default {
return -code error "illegal access mode \"$mode\""
}
}
}
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]]
}