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!
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 match $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 join $root $relative]
EnforceQuota $path $root [array get fs]
file mkdir [file join $path $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} {
if [string match $mode w] {set mode w+}
set fileName [file join $path $relative]
set newFile 0
if ![file exists $fileName] {
set newFile 1
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]]
EnforceQuota $path $root [array get fs]
}
set channelID [open $fileName $mode]
if $newFile {catch {file attributes $fileName -permissions $permissions}}
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
set fileName [file join $path $relative]
seek $channelID 0
fconfigure $channelID -translation binary
set fileConts [read $channelID]
set fileSize [string length $fileConts]
unset fileConts
file stat $fileName fs
array set fs [file attributes $fileName]
set fs(size) $fileSize
set fs(alt_filename) [file tail $relative]
set fs(location) [file dirname [file join $root $relative]]
EnforceQuota $path $root [array get fs]
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 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]
if {$mTStat(type) != "directory"} {
set mTStat(filename) [file tail $mTFile]
set mTStat(dirname) [file tail [file dirname $mTFile]]
}
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) - $fs($item)]}
}
if {$itemSet(current) <= $itemSet(quota)} {set underLimit 1 ; break}
}
if $underLimit {
set oLIndex [lsearch -exact $overLimit $oL]
set overLimit [lreplace $overLimit $oLIndex $oLIndex]
}
set ::vfs::template::quota::${item}($quotaDir) [array get itemSet]
}
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(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 ]