[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] ]]