SEH 8/6/04 - Bug fixes and polish. Quotas now apply to directories as well as files. I'm thinking of combining this with ftpd to create the beginnings of a backup and archiving utility.
escargo 7 Aug 2004 - Out of curiousity, where did you first encounter file systems with quotas? I first ran into them with Multics in the late 70s. Other systems I used since then have had it as well (DEC's VAX VMS, Sun's Solaris, and now Linux). What features of file systems with quotas are you trying to include, and do you know how they compare with existing files systems? And by the way, great work!
SEH 8/10/04 - Some more polish, and I think we're ready for prime time here. In answer to the above, I've never encountered a quota filesystem before, and that's the problem. I and everyone I know in the computer field encounters the same problems in configuration, control and maintenance of systems over and over, and everyone hand-codes their own solutions instead of developing flexible, portable packages with generalized functions. These virtual filesystems I'm writing are an attempt to remedy that.As I speak I hear a co-worker in a nearby cubicle wailing over lost work due to a computer failure. Our company, like most others, has a backup policy, but like most others it's inadequate. Lack of resource control and quota options means backup is still usually an all-or-nothing proposition which either strains available resources or does too little to be useful.I tried working with Linux's kernel-level quota functions a while back, but I found them quite hard to configure, and of course the feature is perfectly non-portable. I worked with webDAV some time ago, and many people on the webDAV mailing list wanted to set up document repositories for individual users in their organizations, but they were struggling mightily with the same issues of access control and resource quotas, and there was no real answer for them. WebDAV has the same weaknesses as HTTP PUT and CVS before it, any alternative to strict read-only access is so dangerous that the tight control necessary greatly reduces the usefulness of the feature set.I'm developing this vfs as a building block to a personal backup system, but it should be applicable to a number of needs, including the ones suggested above. I find the tclvfs api very useful for dividing up development into easily-manageable modular chunks, and of course re-usability by others is pratically a given.I'm looking, like most people who work with Tcl, for flexible, portable, reliable systems. I envision using my vfs's in combination with tcllib's ftpd as a bridge to creating a virtual filesystem accessible to the operating system, since there are several ftp-aware OS-level virtual filesystem solutions on a range of platforms. The goal, as a means to solving the routine problems that shouldn't exist but are still showstoppers, is something that should be commonplace but is almost non-existent: scriptable OS-level virtual filesystems.SEH 8/13/04 - I had it just about working, then of course I decided to restructure it. The necessary functions are now contained in just two procedures, QuotaAdd and QuotaDelete.
# quotavfs.tcl --
#
# A quota-enforcing virtual filesystem.
#
# Quotas can be set on any value returned by [file stat] or [file attributes],
# plus the values set by this vfs, "filename" (equivalent to [file tail]) and
# "dirname" (equivalent to [file tail [file dirname]]).
#
# Two types of quota limits can be set: "total" and "number".
#
# A "total" quota can be set on a numerical stat value like 'size' and
# enforces a limit on the sum of all values of all files within the vfs space.
#
# A "number" quota can be set on any stat or attribute value, and enforces a limit on
# the number of files that have that value.
#
# Unlimited multiple quotas can be defined for separate values, types and locations.
# Each quota is set with a quota group (defined below).
#
# The quotas are enforced as a FIFO stack of files; that is, if a new file is copied to the vfs whose
# attributes exceed a quota, the file is not rejected, rather, the oldest files that contribute to
# the quota are deleted until there is room within the quota limit for the addition of the new file.
#
# Written by Stephen Huntley (stephen.huntley@alum.mit.edu)
#
# Install: This code requires that the template vfs (http://wiki.tcl.tk/11938) procedures have already
# been sourced into the interpreter.
#
# Usage: Mount <existing directory> <string of quota groups> <virtual versioning directory>
#
# Quota group syntax:
#
# -number: -item <value> -pattern <glob pattern>|-rule <proc> -quota <number> [-location <sub-directory>]
# "value" is any stat array index value or attribute name.
# "pattern" is a glob-style pattern applied to filename. If the pattern matches filename,
# the file will contribute to the quota. In addition to glob symbols, a "!" can be prepended
# to the pattern to indicate negation (filenames which don't match the pattern will count toward the quota)
# "proc" is a user-defined procedure which should return a boolean value. On open or close
# of the file "proc" is called with the file's quotaed value. If return is "true" the file
# contributes to the quota, otherwise not.
# "number" is the quota limit.
# "sub-directory" is a location within the vfs to which the quota can be restricted.
# A quota is valid for all subdirectories of the directory to which it is applied,
# thus quotas can't be nested without unpredictable results.
#
# -total: -item <value> -quota <number> [-location <sub-directory>]
# See above.
#
#
# Examples: to set a 10 MB size limit on your ftp upload directory
# Mount C:/temp/upload -total: -item size -quota 10000000 /ftp/pub
#
# To ban GIF files from your web site images directory
# Mount C:/Apache/htdocs -number: -item filename -pattern "*.gif *GIF" -quota 0 -location images /docroot
#
# To exclude all files which are not members of the Unix group called "admin" and
# delete files modified longer that a week ago
#
# First create a procedure to act as a rule:
# proc mcheck {value} {if {($value < [clock scan "7 days ago"]) || ([expr [clock seconds] - $value] < 10)} {return 1} else {return 0}}
#
# Mount /var/logs -number: -item -group -pattern !admin -quota 0 -number: -item mtime -rule mcheck -quota 1 /reports
package require vfs 1
namespace eval ::vfs::template::quota {}
proc ::vfs::template::quota::Mount {args} {
eval [info body ::vfs::template::Mount]
}
namespace eval ::vfs::template::quota {
proc MountProcedure {args} {
foreach templateProc "Mount Unmount CloseTrace handler" {
set infoArgs [info args ::vfs::template::$templateProc]
set infoBody [info body ::vfs::template::$templateProc]
proc $templateProc $infoArgs $infoBody
}
package require fileutil
set to [file normalize [lindex $args end]]
set args [lrange $args 0 end-1]
set path [file normalize [lindex $args 0]]
set args [lrange $args 1 end]
foreach existingMount [::vfs::filesystem info] {
if {![string first $existingMount/ $to/] && ![string equal $existingMount $to] && ![string first ::vfs::template::quota::handler [::vfs::filesystem info $existingMount]]} {
error "Can't nest a quota virtual filesystem within another. Use -location flag."
}
}
if [info exists ::vfs::_unmountCmd($to)] {::vfs::unmount $to}
if [file isfile $path/.quotavfs] {
set f [open $path/.quotavfs r]
while {![eof $f]} {
set arrayLine [gets $f]
if [string equal $arrayLine {}] {continue}
eval array set $arrayLine
}
close $f
file delete -force $path/.quotavfs
if ![string equal [array names ::vfs::template::quota::mtimesArray] {}] {
set mtimes [lindex [split [lindex [lindex [array names ::vfs::template::quota::mtimesArray] 0] 0] ,] 0]
foreach mIndex [lsort -dictionary [array names ::vfs::template::quota::mtimesArray]] {
set mIndex [lindex $mIndex 0]
set fileName [string range $mIndex [string length $mtimes,] end]
set mtime $::vfs::template::quota::mtimesArray($mIndex)
unset ::vfs::template::quota::mtimesArray($mIndex)
MTimeAdd $mtime $fileName $to
}
}
}
if [file isfile $path/.quotaconfig] {
set f [open $path/.quotaconfig r]
set args [concat $args [read $f]]
close $f
}
set location $to
set argsIndex [llength $args]
incr argsIndex -1
for {set i $argsIndex} {$i >= 0} {incr i -1} {
switch -- [lindex $args $i] {
-number: -
-total: {
catch {set location $itemSet(location)}
set item $itemSet(item)
array unset itemSet $item
set itemSet(type) [string range [lindex $args $i] 1 end-1]
lappend ::vfs::template::quota::quota($location) $item
set ::vfs::template::quota::quota($location) [lsort -unique $::vfs::template::quota::quota($location)]
catch {array set itemSet $::vfs::template::quota::${item}($location)}
set ::vfs::template::quota::${item}($location) [array get itemSet]
if ![info exists itemSet(current)] {set enforceQuota 1}
array unset itemSet
set location $to
}
-item {
set itemSet(item) [lindex $args [expr $i + 1]]
}
-location {
set itemSet(location) [lindex $args [expr $i + 1]]
if {[file pathtype $itemSet(location)] != "relative"} {
set itemSet(location) [file normalize $itemSet(location)]
} else {
set itemSet(location) [file normalize [file join $to $itemSet(location)]]
}
}
-pattern {
set itemSet(rule) "CheckPattern [list [lindex $args [expr $i + 1]]]"
}
-quota {
set itemSet(quota) [lindex $args [expr $i + 1]]
}
-rule {
set itemSet(rule) [lindex $args [expr $i + 1]]
}
}
}
set err [catch {file mkdir $path} result]
if [info exists enforceQuota] {
foreach {location items} [array get ::vfs::template::quota::quota] {
foreach item $items {
if ![info exists ::vfs::template::quota::${item}($location)] {
array unset ::vfs::template::quota::${item} $location
continue
}
array unset itemSet
array set itemSet [set ::vfs::template::quota::${item}($location)]
array set itemSet "current 0"
set ::vfs::template::quota::${item}($location) [array get itemSet]
}
}
catch {unset ::vfs::template::quota::mtimes}
::fileutil::find $path "::vfs::template::quota::QuotaAdd [list $path] [list $to] 0 {}"
}
lappend pathto $path
lappend pathto $to
return $pathto
}
proc UnmountProcedure {path to} {
set to [file normalize $to]
set f [open $path/.quotaconfig w]
puts -nonewline $f [ArgsWrite $path $to]
close $f
set f [open $path/.quotavfs w]
if ![catch {set mtimes $::vfs::template::quota::mtimes($to)}] {
puts $f "::vfs::template::quota::mtimesArray [list [array get ::vfs::template::quota::mtimesArray $mtimes,*]]"
array unset ::vfs::template::quota::mtimes $to
}
puts $f "::vfs::template::quota::quota [list [array get ::vfs::template::quota::quota]]"
foreach {location items} [array get ::vfs::template::quota::quota] {
foreach item $items {
puts $f "::vfs::template::quota::${item} [list [array get ::vfs::template::quota::${item}]]"
array unset ::vfs::template::quota::${item}
}
}
catch {close $f} result
return
}
proc Access {path root relative actualpath mode} {
set fileName [file join $path $relative]
if {($fileName == "$path/.quotaconfig") || ($fileName == "$path/.quotavfs")} {error "no such file or directory"}
set modeString [::vfs::accessMode $mode]
if {$modeString == "F"} {
if [file exists $fileName] {return}
error "no such file or directory"
}
set modeString [split $modeString {}]
set fileString {}
if {[string equal $modeString "R"] && [file readable $fileName]} {return}
if {[string equal $modeString "W"] && [file writable $fileName]} {return}
if {[string equal $modeString "X"] && [file executable $fileName]} {return}
file stat $fileName stat
foreach { mask pairs } {
00400 { 00400 r }
00200 { 00200 w }
04100 { 04100 s 04000 S 00100 x }
00040 { 00040 r }
00020 { 00020 w }
02010 { 02010 s 02000 S 00010 x }
00004 { 00004 r }
00002 { 00002 w }
01001 { 01001 t 01000 T 00001 x }
} {
set value [expr $stat(mode) & $mask]
set bit -
foreach { x b } $pairs {
if { $value == $x } {
set bit $b
}
}
append bitString $bit
}
set readable [regexp -all "r" $bitString]
set writable [regexp -all "w" $bitString]
set executable [regexp -all "x" $bitString]
foreach {mode count} "R $readable W $writable X $executable" {
if {([string first $mode $modeString] > -1) && !$count} {error "$mode access not allowed"}
}
if [string equal $modeString "X W"] {
if {($writable == 3) && ($executable == 3)} {
return
} elseif [file writable $fileName] {
if {[regexp -all "wx" $bitString] == $writable} {
return
} elseif [file executable $fileName] {
return
}
}
}
if [string equal $modeString "R W"] {
if {($writable == 3) && ($readable == 3)} {
return
} elseif [file writable $fileName] {
if {[regexp -all "rw" $bitString] == $writable} {
return
} elseif [file readable $fileName] {
return
}
}
}
if [string equal $modeString "R X"] {
if {($readable == 3) && ($executable == 3)} {
return
} elseif [file executable $fileName] {
if {[regexp -all {r[w-]x} $bitString] == $executable} {
return
} elseif [file readable $fileName] {
return
}
}
}
foreach mS $modeString {
set errorMessage "not [string map {R readable W writable X executable} $mS]"
if {[lsearch $fileString $mS] == -1} {error $errorMessage}
}
}
proc CreateDirectory {path root relative actualpath} {
set now [clock seconds]
array set stats "mtime $now atime $now type directory ctime $now dirname [file tail [file dirname [file join $root $relative]]]"
QuotaAdd $path $root $relative [array get stats]
QuotaDelete $path $root $relative [array get stats]
file mkdir [file join $path $relative]
array unset stats
file stat [file join $path $relative] stats
array set stats [file attributes [file join $path $relative]]
QuotaAdd $path $root $relative [array get stats]
}
proc DeleteFile {path root relative actualpath} {
QuotaDelete $path $root $relative
file delete [file join $path $relative]
}
proc FileAttributes {path root relative actualpath} {
set fileName [file join $path $relative]
file attributes $fileName
}
proc FileAttributesSet {path root relative actualpath attribute value} {
set fileName [file join $path $relative]
file attributes $fileName $attribute $value
}
proc MatchInDirectory {path root relative actualpath pattern types} {
if [::vfs::matchDirectories $types] {lappend typeString d}
if [::vfs::matchFiles $types] {lappend typeString f}
set globList [glob -directory [file join $path $relative] -nocomplain -types $typeString $pattern]
if [catch {::vfs::filesystem info $path}] {append globList " [glob -directory [file join $path $relative] -nocomplain -types "$typeString hidden" $pattern]"}
set pathLength [expr [string length $path] - 1]
set newGlobList {}
foreach gL $globList {
if {$gL == "$path/.quotavfs"} {continue}
if {$gL == "$path/.quotaconfig"} {continue}
set gL [eval file join \$root [lrange [file split $gL] [llength [file split $path]] end]]
lappend newGlobList $gL
}
return $newGlobList
}
proc Open {path root relative actualpath mode permissions} {
set fileName [file join $path $relative]
if [string equal $mode r] {return [open $fileName r]}
if [string equal $mode w] {set mode w+}
if ![file exists $fileName] {
set now [clock seconds]
array set stats "mtime $now atime $now mode $permissions type file ctime $now filename [file tail $fileName] dirname [file tail [file dirname [file join $root $relative]]] -permissions $permissions"
if {[string equal $relative $stats(filename)] && [string equal [file tail $path] $stats(dirname)]} {unset stats(dirname)}
QuotaAdd $path $root $relative [array get stats]
QuotaDelete $path $root $relative [array get stats]
set channelID [open $fileName $mode]
catch {file attributes $fileName -permissions $permissions}
} else {
set channelID [open $fileName $mode]
}
return $channelID
}
proc Close {channelID path root relative actualpath mode} {
# Do not close the channel in the close callback!
# It will crash Tcl! Honest!
# The core will close the channel after you've taken what info you need from it.
# close $channelID
if [string equal $mode r] {return}
set fileName [file join $path $relative]
fconfigure $channelID -translation binary
seek $channelID end
set fileSize [tell $channelID]
seek $channelID 0
file stat $fileName fs
array set fs [file attributes $fileName]
array set fs "filename [file tail $fileName] dirname [file tail [file dirname [file join $root $relative]]]"
if {[string equal $relative $fs(filename)] && [string equal [file tail $path] $fs(dirname)]} {unset fs(dirname)}
set fs(size) $fileSize
QuotaAdd $path $root $relative [array get fs]
return
}
proc RemoveDirectory {path root relative actualpath} {
if ![file exists [file join $path $relative]] {return}
while {[file exists [file join $path $relative]]} {file delete -force [file join $path $relative]}
QuotaDelete $path $root $relative
}
proc Stat {path root relative actualpath} {
file stat [file join $path $relative] fs
return [array get fs]
}
proc Utime {path root relative actualpath atime mtime} {
set fileName [file join $path $relative]
file atime $fileName $atime
file mtime $fileName $mtime
MTimeAdd $mtime [file join $root $relative] $root
}
proc ArgsWrite {path to} {
set returnValue {}
foreach {location items} [array get ::vfs::template::quota::quota] {
if [string first $to/ $location/] {continue}
set itemArgs {}
foreach item $items {
foreach {itemLocation itemSetValues} [array get ::vfs::template::quota::${item}] {
if [string first $to/ $itemLocation/] {continue}
array unset itemSet
array set itemSet $itemSetValues
if ![string equal $to $itemLocation] {set itemSet(location) $itemLocation}
lappend itemArgs "-$itemSet(type):"
lappend itemArgs -item
lappend itemArgs $itemSet(item)
if {$itemSet(type) == "number"} {
if {[lindex $itemSet(rule) 0] == "CheckPattern"} {
lappend itemArgs -pattern
lappend itemArgs [lindex $itemSet(rule) 1]
} else {
lappend itemArgs -rule
lappend itemArgs $itemSet(rule)
}
}
lappend itemArgs -quota
lappend itemArgs $itemSet(quota)
lappend itemArgs -current
lappend itemArgs $itemSet(current)
if [info exists itemSet(location)] {
lappend itemArgs -location
lappend itemArgs $itemSet(location)
}
append returnValue \n$itemArgs
unset itemArgs
}
}
}
return [string trim $returnValue]
}
proc CheckPattern {pattern value} {
foreach ptn $pattern {
set negate [string equal [string index $ptn 0] !]
if $negate {set ptn [string range $ptn 1 end]}
set match [string match $ptn $value]
if $negate {set match [expr !$match]}
if $match {return $match}
}
return 0
}
proc MTimeAdd {mtime fileName root} {
package require struct
if ![info exists ::vfs::template::quota::mtimes($root)] {
set ::vfs::template::quota::mtimes($root) [::struct::queue]
}
set mtimes $::vfs::template::quota::mtimes($root)
$mtimes put "$mtime [list $fileName]"
set ::vfs::template::quota::mtimesArray($mtimes,$fileName) $mtime
}
proc QuotaAdd {path root relative {stats {}} {file {}}} {
set fileName [file join $path $relative]
if {$file != {}} {
set fileName [file join [pwd] $file]
set relative [string range $fileName [string length $path/] end]
}
if [string equal $fileName $path/.quotaconfig] {return 0}
if [string equal $fileName $path/.quotavfs] {return 0}
if {$stats == {}} {
array set fs [QuotaStats $fileName $relative]
set stats [array get fs]
} else {
array set fs $stats
}
set overLimit {}
foreach quotaDir [lsort -decreasing [array names ::vfs::template::quota::quota]] {
if [string first $quotaDir/ [file join $root $relative]/] {continue}
foreach item $::vfs::template::quota::quota($quotaDir) {
if ![info exists fs($item)] {continue}
array unset itemSet
array set itemSet [set ::vfs::template::quota::${item}($quotaDir)]
if ![info exists itemSet(current)] {set current 0} else {set current $itemSet(current)}
if {($itemSet(type) == "total") || ([eval $itemSet(rule) \$fs(\$item)])} {
if {$itemSet(type) == "number"} {incr current} else {set current [expr $current + $fs($item)]}
}
array set itemSet "current $current"
if {$itemSet(current) > $itemSet(quota)} {
lappend overLimit "$item [list $quotaDir]"
set overLimit [lsort -unique $overLimit]
}
set ::vfs::template::quota::${item}($quotaDir) [array get itemSet]
}
}
MTimeAdd $fs(mtime) [file join $root $relative] $root
if {$file != {}} {return 0}
foreach oL $overLimit {
set item [lindex $oL 0]
set quotaDir [lindex $oL 1]
set underLimit 0
array unset itemSet
array set itemSet [set ::vfs::template::quota::${item}($quotaDir)]
set mtimes $::vfs::template::quota::mtimes($root)
foreach mT [lrange $::struct::queue::queues($mtimes) 0 end] {
set mTime [lindex $mT 0]
set mFile [lindex $mT 1]
if [string first $quotaDir/ $mFile/] {continue}
if {[lindex [array get ::vfs::template::quota::mtimesArray [lindex [array names ::vfs::template::quota::mtimesArray -exact $mtimes,$mFile] 0]] 1] != $mTime} {set cleanup 1 ; continue}
array unset itemSet
array set itemSet [set ::vfs::template::quota::${item}($quotaDir)]
set fileName $path/[string range $mFile [string length $root/] end]
array unset fs
if {$mFile == [file join $root $relative]} {
set reject 1
array set fs $stats
} else {
catch {array set fs [QuotaStats $fileName [string range $mFile [string length $root/] end]]}
}
if ![info exists fs($item)] {continue}
QuotaDelete $path $root [string range $mFile [string length $root/] end] [array get fs]
array set itemSet [set ::vfs::template::quota::${item}($quotaDir)]
if {$itemSet(current) <= $itemSet(quota)} {break}
}
}
if [info exists cleanup] {
$mtimes clear
foreach mIndex [array names ::vfs::template::quota::mtimesArray] {
set mIndex [lindex $mIndex 0]
set fileName [string range $mIndex [string length $mtimes,] end]
set mtime $::vfs::template::quota::mtimesArray($mIndex)
$mtimes put [list $mtime [list $fileName]]
}
set ::struct::queue::queues($mtimes) [lsort -dictionary $::struct::queue::queues($mtimes)]
}
if [info exists reject] {vfs::filesystem posixerror $::vfs::posix(EDQUOT) ; return -code error $::vfs::posix(EDQUOT)}
}
proc QuotaDelete {path root relative args} {
if ![info exists ::vfs::template::quota::mtimes($root)] {return}
set mtimes $::vfs::template::quota::mtimes($root)
set fileName [file join $path $relative]
if {$args != {}} {
eval array set fs $args
} else {
array set fs [QuotaStats $fileName $relative]
}
foreach quotaDir [lsort -decreasing [array names ::vfs::template::quota::quota]] {
if [string first $quotaDir/ [file join $root $relative]/] {continue}
foreach item $::vfs::template::quota::quota($quotaDir) {
if ![info exists fs($item)] {continue}
array unset itemSet
array set itemSet [set ::vfs::template::quota::${item}($quotaDir)]
if ![info exists itemSet(current)] {set current 0} else {set current $itemSet(current)}
if {($itemSet(type) == "total") || ([eval $itemSet(rule) \$fs(\$item)])} {
if {$fs(type) == "file"} {file delete -force $fileName} else {set deleteDir 1}
array unset ::vfs::template::quota::mtimesArray $mtimes,[file join $root $relative]
if {$itemSet(type) == "number"} {incr current -1} else {set current [expr $current - $fs($item)]}
}
array set itemSet "current $current"
set ::vfs::template::quota::${item}($quotaDir) [array get itemSet]
}
}
if [info exists deleteDir] {
set dirs {}
foreach mT [lrange $::struct::queue::queues($mtimes) 0 end] {
set mTime [lindex $mT 0]
set mFile [lindex $mT 1]
if [string first [file join $root $relative]/ $mFile] {continue}
if {[lindex [array get ::vfs::template::quota::mtimesArray [lindex [array names ::vfs::template::quota::mtimesArray -exact $mtimes,$mFile] 0]] 1] != $mTime} {continue}
if [file isdirectory $path/[string range $mFile [string length $root/] end]] {lappend dirs $mFile ; continue}
QuotaDelete $path $root [string range $mFile [string length $root/] end]
}
foreach dir [lsort -decreasing $dirs] {
QuotaDelete $path $root [string range $dir [string length $root/] end]
}
while {[file exists $fileName]} {file delete -force $fileName}
}
}
proc QuotaStats {fileName relative} {
file stat $fileName fs
array set fs [file attributes $fileName]
set fs(dirname) [file tail $fileName]
set fileSize $fs(size)
array unset fs size
if {$fs(type) != "directory"} {
set fs(dirname) [file tail [file dirname $relative]]
set fs(filename) [file tail $fileName]
set fs(size) $fileSize
unset fileSize
}
if {$fs(dirname) == "."} {array unset fs dirname}
array get fs
}
}
# end namespace eval vfs::template::quota