# quotavfs.tcl --
 #
 #        A quota-enforcing virtual filesystem.
 #
 # Quotas can be set on any value returned by [file stat] or [file attributes],
 # plus the values set by this vfs, "filename" (equivalent to [file tail]) and
 # "dirname" (equivalent to [file tail [file dirname]]).
 #
 # Two types of quota limits can be set: "total" and "number".
 #
 # A "total" quota can be set on a numerical stat value like 'size' and
 # enforces a limit on the sum of all values of all files within the vfs space.
 #
 # A "number" quota can be set on any stat or attribute value, and enforces a limit on
 # the number of files that have that value.
 #
 # Unlimited multiple quotas can be defined for separate values, types and locations.
 # Each quota is set with a quota group (defined below).
 # 
 # The quotas are enforced as a FIFO stack of files; that is, if a new file is copied to the vfs whose
 # attributes exceed a quota, the file is not rejected, rather, the oldest files that contribute to
 # the quota are deleted until there is room within the quota limit for the addition of the new file.
 #
 # Written by Stephen Huntley ([email protected])
 #
 # Install: This code requires that the template vfs (https://wiki.tcl-lang.org/11938) procedures have already
 # been sourced into the interpreter.
 #
 # Usage: Mount <existing directory> <string of quota groups> <virtual versioning directory>
 #
 # Quota group syntax:
 #
 # -number: -item <value> -pattern <glob pattern>|-rule <proc> -quota <number> [-location <sub-directory>]
 #        "value" is any stat array index value or attribute name.
 #        "pattern" is a glob-style pattern applied to filename. If the pattern matches filename,
 #                the file will contribute to the quota.  In addition to glob symbols, a "!" can be prepended
 #                to the pattern to indicate negation (filenames which don't match the pattern will count toward the quota)
 #        "proc" is a user-defined procedure which should return a boolean value.  On open or close
 #                of the file "proc" is called with the file's quotaed value. If return is "true" the file
 #                 contributes to the quota, otherwise not.
 #        "number" is the quota limit.
 #        "sub-directory" is a location within the vfs to which the quota can be restricted.
 #                A quota is valid for all subdirectories of the directory to which it is applied,
 #                thus quotas can't be nested without unpredictable results.
 #
 # -total: -item <value> -quota <number> [-location <sub-directory>]
 #        See above.
 #
 #
 # 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 modified longer that a week ago
 #
 # First create a procedure to act as a rule:
 # proc mcheck {value} {if {($value < [clock scan "7 days ago"]) || ([expr [clock seconds] - $value] < 10)} {return 1} else {return 0}}
 #
 # Mount /var/logs -number: -item -group -pattern !admin -quota 0 -number: -item mtime -rule mcheck -quota 1 /reports

 package require vfs 1

 namespace eval ::vfs::template::quota {}

 proc ::vfs::template::quota::Mount {args} {
        eval [info body ::vfs::template::Mount]
 }

 namespace eval ::vfs::template::quota {

 proc MountProcedure {args} {
        foreach templateProc "Mount Unmount CloseTrace handler" {
                set infoArgs [info args ::vfs::template::$templateProc]
                set infoBody [info body ::vfs::template::$templateProc]
                proc $templateProc $infoArgs $infoBody
        }

        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]

        foreach existingMount [::vfs::filesystem info] {
                if {![string first $existingMount/ $to/] && ![string equal $existingMount $to] && ![string first ::vfs::template::quota::handler [::vfs::filesystem info $existingMount]]} {
                        error "Can't nest a quota virtual filesystem within another.  Use -location flag."
                }
        }

        if [info exists ::vfs::_unmountCmd($to)] {::vfs::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 -force $path/.quotavfs

                if ![string equal [array names ::vfs::template::quota::mtimesArray] {}] {
                        set mtimes [lindex [split [lindex [lindex [array names ::vfs::template::quota::mtimesArray] 0] 0] ,] 0]
                        foreach mIndex [lsort -dictionary [array names ::vfs::template::quota::mtimesArray]] {
                                set mIndex [lindex $mIndex 0]
                                set fileName [string range $mIndex [string length $mtimes,] end]
                                set mtime $::vfs::template::quota::mtimesArray($mIndex)
                                unset ::vfs::template::quota::mtimesArray($mIndex)
                                MTimeAdd $mtime $fileName $to
                        }
                }
        }

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

        set err [catch {file mkdir $path} result]

        if [info exists enforceQuota] {
                foreach {location items} [array get ::vfs::template::quota::quota] {
                        foreach item $items {
                                if ![info exists ::vfs::template::quota::${item}($location)] {
                                        array unset ::vfs::template::quota::${item} $location
                                        continue
                                }
                                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 {}"
        }

        lappend pathto $path
        lappend pathto $to
        return $pathto
 }

 proc UnmountProcedure {path to} {
        set to [file normalize $to]
        set f [open $path/.quotaconfig w]
        puts -nonewline $f [ArgsWrite $path $to]
        close $f

        set f [open $path/.quotavfs w]

        if ![catch {set mtimes $::vfs::template::quota::mtimes($to)}] {
                puts $f "::vfs::template::quota::mtimesArray [list [array get ::vfs::template::quota::mtimesArray $mtimes,*]]"
                array unset ::vfs::template::quota::mtimes $to
        }
        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}
                }
        }
        catch {close $f} result
        return
 }

 proc Access {path root relative actualpath mode} {
        set fileName [file join $path $relative]
        if {($fileName == "$path/.quotaconfig") || ($fileName == "$path/.quotavfs")} {error "no such file or directory"}
        set modeString [::vfs::accessMode $mode]
        if {$modeString == "F"} {
                if [file exists $fileName] {return}
                error "no such file or directory"
        }
        set modeString [split $modeString {}]
        set fileString {}
        if {[string equal $modeString "R"] && [file readable $fileName]} {return}
        if {[string equal $modeString "W"] && [file writable $fileName]} {return}
        if {[string equal $modeString "X"] && [file executable $fileName]} {return}
        file stat $fileName stat
        foreach { mask pairs } {
                00400 { 00400 r }
                00200 { 00200 w }
                04100 { 04100 s 04000 S 00100 x }
                00040 { 00040 r }
                00020 { 00020 w }
                02010 { 02010 s 02000 S 00010 x }
                00004 { 00004 r }
                00002 { 00002 w }
                01001 { 01001 t 01000 T 00001 x }
            } {
                set value [expr $stat(mode) & $mask]
                set bit -
                foreach { x b } $pairs {
                    if { $value == $x } {
                        set bit $b
                    }
                }
                append bitString $bit
      }
        set readable [regexp -all "r" $bitString]
        set writable [regexp -all "w" $bitString]
        set executable [regexp -all "x" $bitString]
        foreach {mode count} "R $readable W $writable X $executable" {
                if {([string first $mode $modeString] > -1) && !$count} {error "$mode access not allowed"}
        }
        if [string equal $modeString "X W"] {
                if {($writable == 3) && ($executable == 3)} {
                        return
                } elseif [file writable $fileName] {
                        if {[regexp -all "wx" $bitString] == $writable} {
                                return
                        } elseif [file executable $fileName] {
                                return
                        }
                }
        }
        if [string equal $modeString "R W"] {
                if {($writable == 3) && ($readable == 3)} {
                        return
                } elseif [file writable $fileName] {
                        if {[regexp -all "rw" $bitString] == $writable} {
                                return
                        } elseif [file readable $fileName] {
                                return
                        }
                }
        }
        if [string equal $modeString "R X"] {
                if {($readable == 3) && ($executable == 3)} {
                        return
                } elseif [file executable $fileName] {
                        if {[regexp -all {r[w-]x} $bitString] == $executable} {
                                return
                        } elseif [file readable $fileName] {
                                return
                        }
                }
        }

        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 now [clock seconds]
        array set stats "mtime $now atime $now type directory ctime $now dirname [file tail [file dirname [file join $root $relative]]]"
        QuotaAdd $path $root $relative [array get stats]
        QuotaDelete $path $root $relative [array get stats]
        file mkdir [file join $path $relative]
        array unset stats
        file stat [file join $path $relative] stats
        array set stats [file attributes [file join $path $relative]]
        QuotaAdd $path $root $relative [array get stats]
 }

 proc DeleteFile {path root relative actualpath} {
        QuotaDelete $path $root $relative
        file delete [file join $path $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]
        if [catch {::vfs::filesystem info $path}] {append globList " [glob -directory [file join $path $relative] -nocomplain -types "$typeString hidden" $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 [eval file join \$root [lrange [file split $gL] [llength [file split $path]] end]]
                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 now [clock seconds]
                array set stats "mtime $now atime $now mode $permissions type file ctime $now filename [file tail $fileName] dirname [file tail [file dirname [file join $root $relative]]] -permissions $permissions"

                if {[string equal $relative $stats(filename)] && [string equal [file tail $path] $stats(dirname)]} {unset stats(dirname)}

                QuotaAdd $path $root $relative [array get stats]
                QuotaDelete $path $root $relative [array get stats]

                set channelID [open $fileName $mode]
                catch {file attributes $fileName -permissions $permissions}
        } 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]

        fconfigure $channelID -translation binary
        seek $channelID end
        set fileSize [tell $channelID]
        seek $channelID 0

        file stat $fileName fs
        array set fs [file attributes $fileName]
        array set fs "filename [file tail $fileName] dirname [file tail [file dirname [file join $root $relative]]]"
        if {[string equal $relative $fs(filename)] && [string equal [file tail $path] $fs(dirname)]} {unset fs(dirname)}

        set fs(size) $fileSize
        QuotaAdd $path $root $relative [array get fs]
        return
 }

 proc RemoveDirectory {path root relative actualpath} {
        if ![file exists [file join $path $relative]] {return}
        while {[file exists [file join $path $relative]]} {file delete -force [file join $path $relative]}
        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
        MTimeAdd $mtime [file join $root $relative] $root
 }

 proc ArgsWrite {path to} {
        set returnValue {}
        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}] {
                                if [string first $to/ $itemLocation/] {continue}
                                array unset itemSet
                                array set itemSet $itemSetValues
                                if ![string equal $to $itemLocation] {set itemSet(location) $itemLocation}
                                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)
                                }
                                append returnValue \n$itemArgs
                                unset itemArgs
                        }
                }
        }
        return [string trim $returnValue]
 }

 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 MTimeAdd {mtime fileName root} {
        package require struct
        if ![info exists ::vfs::template::quota::mtimes($root)] {
                set ::vfs::template::quota::mtimes($root) [::struct::queue]
        }
        set mtimes $::vfs::template::quota::mtimes($root)
        $mtimes put "$mtime [list $fileName]"
        set ::vfs::template::quota::mtimesArray($mtimes,$fileName) $mtime
 }

 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]
                set stats [array get fs]
        } 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]
                }
        }
        MTimeAdd $fs(mtime) [file join $root $relative] $root
        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)]
                set mtimes $::vfs::template::quota::mtimes($root)
                foreach mT [lrange $::struct::queue::queues($mtimes) 0 end] {
                        set mTime [lindex $mT 0]
                        set mFile [lindex $mT 1]
                        if [string first $quotaDir/ $mFile/] {continue}

                        if {[lindex [array get ::vfs::template::quota::mtimesArray [lindex [array names ::vfs::template::quota::mtimesArray -exact $mtimes,$mFile] 0]] 1] != $mTime} {set cleanup 1 ; 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

                        if {$mFile == [file join $root $relative]} {
                                set reject 1
                                array set fs $stats
                        } else {
                                catch {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]
                        array set itemSet [set ::vfs::template::quota::${item}($quotaDir)]
                        if {$itemSet(current) <= $itemSet(quota)} {break}
                }
        }
        if [info exists cleanup] {
                $mtimes clear
                foreach mIndex [array names ::vfs::template::quota::mtimesArray] {
                        set mIndex [lindex $mIndex 0]
                        set fileName [string range $mIndex [string length $mtimes,] end]
                        set mtime $::vfs::template::quota::mtimesArray($mIndex)
                        $mtimes put [list $mtime [list $fileName]]
                }
                set ::struct::queue::queues($mtimes) [lsort -dictionary $::struct::queue::queues($mtimes)]
        }
        if [info exists reject] {vfs::filesystem posixerror $::vfs::posix(EDQUOT) ; return -code error $::vfs::posix(EDQUOT)}
 }

 proc QuotaDelete {path root relative args} {
        if ![info exists ::vfs::template::quota::mtimes($root)] {return}
        set mtimes $::vfs::template::quota::mtimes($root)
        set fileName [file join $path $relative]
        if {$args != {}} {
                eval array set fs $args
        } else {
                array set fs [QuotaStats $fileName $relative]
        }
        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 {$fs(type) == "file"} {file delete -force $fileName} else {set deleteDir 1}
                                array unset ::vfs::template::quota::mtimesArray $mtimes,[file join $root $relative]
                                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 [info exists deleteDir] {
                set dirs {}
                foreach mT [lrange $::struct::queue::queues($mtimes) 0 end] {
                        set mTime [lindex $mT 0]
                        set mFile [lindex $mT 1]
                        if [string first [file join $root $relative]/ $mFile] {continue}
                        if {[lindex [array get ::vfs::template::quota::mtimesArray [lindex [array names ::vfs::template::quota::mtimesArray -exact $mtimes,$mFile] 0]] 1] != $mTime} {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]
                }
                while {[file exists $fileName]} {file delete -force $fileName}
        }
 }

 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