SEH A quota-enforcing virtual filesystem.
Quotas can be set on any value returned by [file stat] or [file attributes], plus the special values filename and dirname. Two types of quota limits can be set: total and number.
A total quota can be set on a numerical value like 'size' and enforces a limit on the sum of all values of all files.
A number quota can be set on any value, and enforces a limit on the number of files whose given attribute matches a pattern or rule.
By default the quota applies to the whole mounted location, but separate sub-locations can be specified.
Unlimited multiple quotas can be defined for separate values, types and locations. Each quota is set with a quota group:
-number: -item <value> -pattern <glob pattern>|-rule <command> -quota <number> [-location <sub-directory>]
-total: -item <value> -quota <number> [-location <sub-directory>]
The string containing all quota groups is incorporated into the Mount command.
If a file add leads to a quota being exceeded, the oldest files matching the quota criterion are deleted until the quota limit is re-established.
Usage: Mount <existing directory> <string of quota groups> <virtual directory>
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 created longer that a week ago
First create a procedure to act as a rule:
proc ccheck {value} {if {$value < [clock scan "7 days ago"]} {return 1} else {return 0}}
Mount /var/logs -number: -item -group -pattern !admin -quota 0 -number: -item ctime -rule ccheck -quota 0 /reports
(the pattern is glob-style with the optional addition of ! at the beginning to indicate negative match)
Note that you can create a self-generating local cache with a collate/broadcast virtual filesystem, when daisy-chained with this VFS, you can restrict the cache size, among other things.
Based on a template virtual filesystem
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.
package require vfs 1
namespace eval ::vfs::template::quota {}
proc ::vfs::template::quota::Mount {args} {
set pathto [eval MountProcedure $args]
set path [lindex $pathto 0]
set to [lindex $pathto 1]
::vfs::filesystem mount $to [list ::vfs::template::quota::handler $path]
::vfs::RegisterMount $to [list ::vfs::template::quota::Unmount]
return $to
}
proc ::vfs::template::quota::Unmount {to} {
set path [lindex [::vfs::filesystem info $to] end]
UnmountProcedure $path $to
::vfs::filesystem unmount $to
}
proc ::vfs::template::quota::handler {path cmd root relative actualpath args} {
switch -- $cmd {
access {
set mode [lindex $args 0]
set error [catch {Access $path $root $relative $actualpath $mode}]
if $error {vfs::filesystem posixerror $::vfs::posix(EACCES) ; return -code error $::vfs::posix(EACCES)}
}
createdirectory {
CreateDirectory $path $root $relative $actualpath
}
deletefile {
DeleteFile $path $root $relative $actualpath
}
fileattributes {
set index [lindex $args 0]
set value [lindex $args 1]
array set attributes [FileAttributes $path $root $relative $actualpath]
if {$index == {}} {
return [lsort [array names attributes]]
}
set attribute [lindex [lsort [array names attributes]] $index]
if {$value == {}} {
return $attributes($attribute)
}
FileAttributesSet $path $root $relative $actualpath $attribute $value
}
matchindirectory {
set pattern [lindex $args 0]
set types [lindex $args 1]
return [MatchInDirectory $path $root $relative $actualpath $pattern $types]
} open {
set mode [lindex $args 0]
if {$mode == {}} {set mode r}
set permissions [lindex $args 1]
set channelID [Open $path $root $relative $actualpath $mode $permissions]
switch -glob -- $mode {
"" -
"r*" -
"w*" {
seek $channelID 0
}
"a*" {
seek $channelID 0 end
}
default {
::vfs::filesystem posixerror $::vfs::posix(EINVAL)
return -code error $::vfs::posix(EINVAL)
}
}
set result $channelID
lappend result [list ::vfs::template::quota::Close $channelID $path $root $relative $actualpath $mode]
return $result
}
removedirectory {
set recursive [lindex $args 0]
if !$recursive {
if {[MatchInDirectory $path $root $relative $actualpath * 0] != {}} {
::vfs::filesystem posixerror $::vfs::posix(EEXIST)
return -code error $::vfs::posix(EEXIST)
}
}
RemoveDirectory $path $root $relative $actualpath
}
stat {
return [Stat $path $root $relative $actualpath]
}
utime {
set atime [lindex $args 0]
set mtime [lindex $args 1]
Utime $path $root $relative $actualpath $atime $mtime
}
}
}
namespace eval ::vfs::template::quota {
proc MountProcedure {args} {
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]
if {![catch {vfs::filesystem info $to}]} {
# unmount old mount
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 $path/.quotavfs
set ::vfs::template::quota::mtimes $mtimes(content)
array unset mtimes
}
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]]
}
}
}
if [info exists enforceQuota] {
foreach {location items} [array get ::vfs::template::quota::quota] {
foreach item $items {
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 {}"
}
file mkdir $path
lappend pathto $path
lappend pathto $to
return $pathto
}
proc UnmountProcedure {path to} {
set to [file normalize $to]
ArgsWrite $path $to
set f [open $path/.quotavfs w]
puts $f "mtimes [list "content [list $::vfs::template::quota::mtimes]"]"
unset ::vfs::template::quota::mtimes
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}
}
}
array unset ::vfs::template::quota::quota
close $f
return
}
proc Access {path root relative actualpath mode} {
set modeString [::vfs::accessMode $mode]
if {$modeString == "F"} {set modeString RWX}
set modeString [split $modeString {}]
set fileName [file join $path $relative]
if [file readable $fileName] {lappend fileString R}
if [file writable $fileName] {lappend fileString W}
if [file executable $fileName] {lappend fileString X}
if {($fileName == "$path/.quotaconfig") || ($fileName == "$path/.quotavfs")} {set fileString {}}
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} {
file mkdir [file join $path $relative]
QuotaAdd $path $root $relative
}
proc DeleteFile {path root relative actualpath} {
QuotaDelete $path $root $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]
set pathLength [expr [string length $path] - 1]
set newGlobList {}
foreach gL $globList {
if {$gL == "$path/.quotavfs"} {continue}
if {$gL == "$path/.quotaconfig"} {continue}
set gL [string replace $gL 0 $pathLength $root]
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 channelID [open $fileName $mode]
catch {file attributes $fileName -permissions $permissions}
if [catch {QuotaAdd $path $root $relative} result] {
close $channelID
file delete $fileName
vfs::filesystem posixerror $::vfs::posix(EDQUOT) ; return -code error $::vfs::posix(EDQUOT)
}
} 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]
seek $channelID 0
fconfigure $channelID -translation binary
set fileConts [read $channelID]
set fileSize [string length $fileConts]
unset fileConts
set fs(size) $fileSize
set fs(type) file
set fs(mtime) [clock seconds]
QuotaAdd $path $root $relative [array get fs]
return
}
proc RemoveDirectory {path root relative actualpath} {
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
array set ::vfs::template::quota::mtimes "$mtime [file join $path $relative]"
}
proc ArgsWrite {path to} {
set f [open $path/.quotaconfig w]
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}] {
array unset itemSet
array set itemSet $itemSetValues
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)
}
puts $f $itemArgs
unset itemArgs
}
}
}
close $f
}
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 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]
} 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]
}
}
set mTEntry $fs(mtime)
lappend mTEntry [file join $root $relative]
if [catch {set fileIndex [llength $::vfs::template::quota::mtimes]}] {
set ::vfs::template::quota::mtimes {}
set fileIndex 0
}
incr fileIndex -1
set deleted 0
set added 0
for {set i $fileIndex} {$i >= 0} {incr i -1} {
set mT [lindex $::vfs::template::quota::mtimes $i]
set mTime [lindex $mT 0]
set mFile [lindex $mT 1]
if {$mFile == [file join $root $relative]} {
set ::vfs::template::quota::mtimes [lreplace $::vfs::template::quota::mtimes $i $i]
set deleted 1
}
if {$fs(mtime) < $mTime} {continue}
if !$added {set ::vfs::template::quota::mtimes [linsert $::vfs::template::quota::mtimes [expr $i + 1] $mTEntry]}
set added 1
if {$deleted && $added} {break}
}
if !$added {set ::vfs::template::quota::mtimes [linsert $::vfs::template::quota::mtimes 0 $mTEntry]}
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)]
foreach mT $::vfs::template::quota::mtimes {
set mTime [lindex $mT 0]
set mFile [lindex $mT 1]
if [string first $quotaDir/ $mFile/] {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
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]
if {$mFile == [file join $root $relative]} {set reject 1}
array set itemSet [set ::vfs::template::quota::${item}($quotaDir)]
if {$itemSet(current) <= $itemSet(quota)} {break}
}
}
if [info exists reject] {vfs::filesystem posixerror $::vfs::posix(EDQUOT) ; return -code error $::vfs::posix(EDQUOT)}
}
proc QuotaDelete {path root relative args} {
set fileName [file join $path $relative]
if {$args != {}} {
eval array set fs $args
} else {
array set fs [QuotaStats $fileName $relative]
}
if {$fs(type) == "directory"} {
set dirs {}
foreach mT $::vfs::template::quota::mtimes {
set mTime [lindex $mT 0]
set mFile [lindex $mT 1]
if [string first [file join $root $relative]/ $mFile] {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]
}
}
if [catch {file delete $fileName}] {return}
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 -1} else {set current [expr $current - $fs($item)]}
}
array set itemSet "current $current"
set ::vfs::template::quota::${item}($quotaDir) [array get itemSet]
}
}
if [catch {set fileIndex [llength $::vfs::template::quota::mtimes]}] {
set ::vfs::template::quota::mtimes {}
set fileIndex 0
}
incr fileIndex -1
for {set i 0} {$i <= $fileIndex} {incr i} {
set mT [lindex $::vfs::template::quota::mtimes $i]
set mTime [lindex $mT 0]
set mFile [lindex $mT 1]
if {$mFile == [file join $root $relative]} {
set ::vfs::template::quota::mtimes [lreplace $::vfs::template::quota::mtimes $i $i]
break
}
}
}
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[ Category VFS ]