From 837b3c5416d665995dc3ef83adef68fbdc9e3660 Mon Sep 17 00:00:00 2001 From: Vince Darley Date: Mon, 13 May 2002 18:07:31 +0000 Subject: [PATCH] webdav --- ChangeLog | 5 + library/httpvfs.tcl | 6 +- library/tclIndex | 13 +++ library/webdavvfs.tcl | 223 ++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 244 insertions(+), 3 deletions(-) create mode 100644 library/webdavvfs.tcl diff --git a/ChangeLog b/ChangeLog index 569368e..9141f42 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2002-05-13 Vince Darley + * library/webdavvfs.tcl: v. early implementation of a webdav + vfs. (Note: this and the 'http' vfs need lots of work -- + please help out!). + 2002-05-13 Vince Darley * library/mk4vfs.tcl: newer version from tclkit. diff --git a/library/httpvfs.tcl b/library/httpvfs.tcl index 048e61d..972a0f9 100644 --- a/library/httpvfs.tcl +++ b/library/httpvfs.tcl @@ -69,7 +69,7 @@ proc vfs::http::stat {dirurl name} { # get information on the type of this file. We describe everything # as a file (not a directory) since with http, even directories # really behave as the index.html they contain. - set state [::http::geturl [file join $dirurl $name] -validate 1] + set state [::http::geturl "$dirurl$name" -validate 1] set mtime 0 lappend res type file lappend res dev -1 uid -1 gid -1 nlink 1 depth 0 \ @@ -80,7 +80,7 @@ proc vfs::http::stat {dirurl name} { proc vfs::http::access {dirurl name mode} { ::vfs::log "access $name $mode" if {$name == ""} { return 1 } - set state [::http::geturl [file join $dirurl $name]] + set state [::http::geturl "$dirurl$name"] set info "" if {[string length $info]} { return 1 @@ -100,7 +100,7 @@ proc vfs::http::open {dirurl name mode permissions} { switch -glob -- $mode { "" - "r" { - set state [::http::geturl [file join $dirurl $name]] + set state [::http::geturl "$dirurl$name"] set filed [vfs::memchan] fconfigure $filed -translation binary diff --git a/library/tclIndex b/library/tclIndex index 1012287..239af8f 100644 --- a/library/tclIndex +++ b/library/tclIndex @@ -57,6 +57,7 @@ set auto_index(::mk4vfs::mkdir) [list source [file join $dir mk4vfs.tcl]] set auto_index(::mk4vfs::getdir) [list source [file join $dir mk4vfs.tcl]] set auto_index(::mk4vfs::mtime) [list source [file join $dir mk4vfs.tcl]] set auto_index(::mk4vfs::delete) [list source [file join $dir mk4vfs.tcl]] +set auto_index(loadvfs) [list source [file join $dir pkgIndex.tcl]] set auto_index(::vfs::ns::Mount) [list source [file join $dir tclprocvfs.tcl]] set auto_index(::vfs::ns::Unmount) [list source [file join $dir tclprocvfs.tcl]] set auto_index(::vfs::ns::handler) [list source [file join $dir tclprocvfs.tcl]] @@ -119,6 +120,18 @@ set auto_index(::vfs::indexToAttribute) [list source [file join $dir vfsUtils.tc set auto_index(::vfs::attributesGet) [list source [file join $dir vfsUtils.tcl]] set auto_index(::vfs::attributesSet) [list source [file join $dir vfsUtils.tcl]] set auto_index(::vfs::posixError) [list source [file join $dir vfsUtils.tcl]] +set auto_index(::vfs::webdav::Mount) [list source [file join $dir webdavvfs.tcl]] +set auto_index(::vfs::webdav::Unmount) [list source [file join $dir webdavvfs.tcl]] +set auto_index(::vfs::webdav::handler) [list source [file join $dir webdavvfs.tcl]] +set auto_index(::vfs::webdav::stat) [list source [file join $dir webdavvfs.tcl]] +set auto_index(::vfs::webdav::access) [list source [file join $dir webdavvfs.tcl]] +set auto_index(::vfs::webdav::open) [list source [file join $dir webdavvfs.tcl]] +set auto_index(::vfs::webdav::matchindirectory) [list source [file join $dir webdavvfs.tcl]] +set auto_index(::vfs::webdav::createdirectory) [list source [file join $dir webdavvfs.tcl]] +set auto_index(::vfs::webdav::removedirectory) [list source [file join $dir webdavvfs.tcl]] +set auto_index(::vfs::webdav::deletefile) [list source [file join $dir webdavvfs.tcl]] +set auto_index(::vfs::webdav::fileattributes) [list source [file join $dir webdavvfs.tcl]] +set auto_index(::vfs::webdav::utime) [list source [file join $dir webdavvfs.tcl]] set auto_index(::vfs::zip::Execute) [list source [file join $dir zipvfs.tcl]] set auto_index(::vfs::zip::Mount) [list source [file join $dir zipvfs.tcl]] set auto_index(::vfs::zip::Unmount) [list source [file join $dir zipvfs.tcl]] diff --git a/library/webdavvfs.tcl b/library/webdavvfs.tcl new file mode 100644 index 0000000..5de7171 --- /dev/null +++ b/library/webdavvfs.tcl @@ -0,0 +1,223 @@ + +package require vfs 1.0 +package require http +# part of tcllib +package require base64 + +# This works for very basic operations (cd, open, file stat, but not 'glob'). +# It has been put together, so far, largely by trial and error! + +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 "Authorization {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} { + if {$cmd == "matchindirectory"} { + eval [list $cmd $dirurl $extraHeadersList $relative $actualpath] $args + } else { + 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" + + # get information on the type of this file. + if {$name == ""} { + set mtime 0 + lappend res type directory + lappend res dev -1 uid -1 gid -1 nlink 1 depth 0 \ + atime $mtime ctime $mtime mtime $mtime mode 0777 + return $res + } + + ::vfs::log [list ::http::geturl $dirurl$name -headers $extraHeadersList] + set token [::http::geturl $dirurl$name -headers $extraHeadersList] + ::vfs::log $token + upvar #0 $token state + if {![regexp " (OK|Moved Permanently)$" $state(http)]} { + ::vfs::log "No good: $state(http)" + ::http::cleanup $token + error "Not found" + } + + if {[regexp "Moved Permanently$" $state(http)]} { + regexp {here} $state(body) -> here + if {[string index $here end] == "/"} { + set type directory + } + } + if {![info exists type]} { + set type file + } + + #parray state + set mtime 0 + + lappend res type $type + lappend res dev -1 uid -1 gid -1 nlink 1 depth 0 \ + atime $mtime ctime $mtime mtime $mtime mode 0777 \ + size $state(totalsize) + + ::http::cleanup $token + return $res +} + +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 + if {![regexp " (OK|Moved Permanently)$" $state(http)]} { + ::vfs::log "No good: $state(http)" + ::http::cleanup $token + error "Not found" + } 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 $state(charset) + + puts -nonewline $filed [::http::data $token] + + fconfigure $filed -translation auto + seek $filed 0 + ::http::cleanup $token + return [list $filed] + } + "a" - + "w*" { + error "Can't open $name for writing" + } + default { + return -code error "illegal access mode \"$mode\"" + } + } +} + +proc vfs::webdav::matchindirectory {dirurl extraHeadersList path actualpath pattern type} { + ::vfs::log "matchindirectory $path $pattern $type" + set res [list] + + if {[string length $pattern]} { + # need to match all files in a given remote http site. + + } else { + # single file + if {![catch {access $dirurl $path}]} { + lappend res $path + } + } + + return $res +} + +proc vfs::webdav::createdirectory {dirurl extraHeadersList name} { + ::vfs::log "createdirectory $name" + error "read-only" +} + +proc vfs::webdav::removedirectory {dirurl extraHeadersList name} { + ::vfs::log "removedirectory $name" + error "read-only" +} + +proc vfs::webdav::deletefile {dirurl extraHeadersList name} { + ::vfs::log "deletefile $name" + error "read-only" +} + +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] + error "read-only" + } + } +} + +proc vfs::webdav::utime {dirurl extraHeadersList path actime mtime} { + error "Can't set utime" +} + -- 2.23.0