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.
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
}
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]
}
}
::fileutil::find $path "::vfs::template::quota::CalculateQuota [list $path] [list $to]"
}
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 "::vfs::template::quota::mtimes [list [array get ::vfs::template::quota::mtimes]]"
array 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} {
set dirName [file join $path $relative]
if [file isdirectory $dirName] {
file stat $dirName fs
array set fs [file attributes $dirName]
}
set fs(dirname) [file tail $relative]
set fs(location) [file dirname [file join $root $relative]]
EnforceQuota $path $root [array get fs]
file mkdir [file join $path $relative]
set mtime [clock seconds]
while {[info exists ::vfs::template::quota::mtimes($mtime)]} {incr mtime}
set ::vfs::template::quota::mtimes($mtime) [file join $root $relative]
}
proc DeleteFile {path root relative actualpath} {
set fileName [file join $path $relative]
file stat $fileName fs
array set fs [file attributes $fileName]
set fs(filename) [file tail $relative]
set fs(dirname) [file tail [file dirname [file join $root $relative]]]
set fs(location) [file dirname [file join $root $relative]]
file delete $fileName
QuotaReduce [array get fs]
}
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+}
set fs(location) [file dirname [file join $root $relative]]
if ![file exists $fileName] {
set channelID [open $fileName $mode]
catch {file attributes $fileName -permissions $permissions}
file stat $fileName fs
array set fs [file attributes $fileName]
set fs(filename) [file tail $relative]
set fs(dirname) [file tail [file dirname [file join $root $relative]]]
if [catch {EnforceQuota $path $root [array get fs]}] {
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}
if [string equal $mode w] {set mode w+}
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(alt_filename) [file tail $relative]
set fs(location) [file dirname [file join $root $relative]]
catch {EnforceQuota $path $root [array get fs]}
foreach mT [array names ::vfs::template::quota::mtimes] {
if [string equal $::vfs::template::quota::mtimes($mT) [file join $root $relative]] {
array unset ::vfs::template::quota::mtimes $mT
break
}
}
set mTime [clock seconds]
while {[info exists ::vfs::template::quota::mtimes($mTime)]} {incr mTime}
set ::vfs::template::quota::mtimes($mTime) [file join $root $relative]
return
}
proc RemoveDirectory {path root relative actualpath} {
set dirName [file join $path $relative]
file stat $dirName fs
array set fs [file attributes $dirName]
set fs(dirname) [file tail $relative]
set fs(location) [file dirname [file join $root $relative]]
file delete -force $dirName
QuotaReduce [array get fs]
}
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 CalculateQuota {path to name} {
if {[string map {.quotaconfig {} .quotavfs {}} $name] == {}} {return 0}
set pathName [file join [pwd] $name]
set locationName [file join $to [string range $pathName [string length $path/] end]]
file stat $name fs
array set fs [file attributes $name]
array set fs "dirname [list $name]"
array set fs "location [list $locationName]"
if {$fs(type) != "directory"} {
array set fs "filename [list $name]"
array set fs "dirname [list [file tail [file dirname $locationName]]]"
array set fs "location [list [file dirname $locationName]]"
}
while {[info exists ::vfs::template::quota::mtimes($fs(mtime))]} {incr fs(mtime)}
array set ::vfs::template::quota::mtimes "$fs(mtime) [list $locationName]"
QuotaCheck [array get fs]
return 0
}
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 EnforceQuota {path root args} {
eval array set fs $args
catch {set fs(alt_filename) $fs(filename)}
if ![info exists fs(alt_filename)] {set fs(alt_filename) {}}
set overLimit [QuotaCheck [array get fs]]
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 [lsort [array names ::vfs::template::quota::mtimes]] {
set mTFile $::vfs::template::quota::mtimes($mT)
if {$mTFile == [file join $fs(location) $fs(alt_filename)]} {continue}
array unset mTStat
set mTPathFile $path/[string range $mTFile [string length $root/] end]
if ![file exists $mTPathFile] {array unset ::vfs::template::quota::mtimes $mT ; continue}
file stat $mTPathFile mTStat
array set mTStat [file attributes $mTPathFile]
set mTStat(dirname) [file tail $mTFile]
set fileSize $mTStat(size)
array unset mTStat size
set mTStat(location) [file dirname $mTFile]
if {$mTStat(type) != "directory"} {
set mTStat(filename) [file tail $mTFile]
set mTStat(dirname) [file tail [file dirname $mTFile]]
set mTStat(size) $fileSize
}
if ![info exists mTStat($item)] {continue}
if [string first $quotaDir/ $mTFile/] {continue}
if {($itemSet(type) == "total") || ([eval $itemSet(rule) \$mTStat(\$item)])} {
file delete $mTPathFile
array unset ::vfs::template::quota::mtimes $mT
if {$itemSet(type) == "number"} {incr itemSet(current) -1} else {set itemSet(current) [expr $itemSet(current) - $mTStat($item)]}
QuotaReduce [array get mTStat]
}
if {$itemSet(current) <= $itemSet(quota)} {set underLimit 1 ; break}
}
if $underLimit {
set oLIndex [lsearch -exact $overLimit $oL]
set overLimit [lreplace $overLimit $oLIndex $oLIndex]
}
}
if ![llength $overLimit] {return}
foreach oL $overLimit {
set item [lindex $oL 0]
set quotaDir [lindex $oL 1]
if ![info exists fs($item)] {continue}
array unset itemSet
array set itemSet [set ::vfs::template::quota::${item}($quotaDir)]
if [string first $quotaDir/ [file join $fs(location) $fs(alt_filename)]] {continue}
if {($itemSet(type) == "total") || ([eval $itemSet(rule) \$fs(\$item)])} {
if {$itemSet(type) == "number"} {incr itemSet(current) -1} else {set itemSet(current) [expr $itemSet(current) - $fs($item)]}
set ::vfs::template::quota::${item}($quotaDir) [array get itemSet]
}
}
vfs::filesystem posixerror $::vfs::posix(EDQUOT) ; return -code error $::vfs::posix(EDQUOT)
}
proc QuotaCheck {args} {
eval array set fs $args
set location $fs(location)
set quotaCheck 0
set overLimit {}
foreach quotaDir [lsort -decreasing [array names ::vfs::template::quota::quota]] {
if [string first $quotaDir/ $location/] {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]
}
}
return $overLimit
}
proc QuotaReduce {args} {
eval array set fs $args
set location $fs(location)
set quotaCheck 0
foreach quotaDir [lsort -decreasing [array names ::vfs::template::quota::quota]] {
if [string first $quotaDir/ $location/] {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]
}
}
}
}
# end namespace eval vfs::template::quota[ Category VFS ]