Version 7 of A quota-enforcing virtual filesystem

Updated 2004-08-07 02:35:45 by SEH

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.


 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 ]