#lang scheme
(require
 (planet untyped/unlib:3:20/enumeration)
 "../data.ss")

(define-enum touch-mode
  ([name   _ "name"]
   [length _ "length"]
   [mode   _ "type and permissions"]
   [mtime  _ "modification time"]
   [gid    _ "group identifier"]))

(define server-context%
  (class object%
    
    (super-new)
    
    (init-field user)
    
    (define/public-final (->user)
      user)
    
    (define/public (in-group? group)
      (string=? group user))
    
    (define/public (can-access? file mode)
      (let ([stat (send file read-stat this)]
            [mask (foldl
                   bitwise-ior 0
                   (enum-case open-direction (open-mode-direction mode)
                     [(r)   (access-flag e r)]
                     [(w)   (access-flag e w)]
                     [(r/w) (access-flag e r w)]
                     [(x)   (access-flag e x)]))])
        (= (bitwise-and
            ((cond
               [(string=? (stat-uid stat) (->user))
                file-mode-user]
               [(in-group? (stat-gid stat))
                file-mode-group]
               [else
                file-mode-others])
             (stat-mode stat))
            mask)
           mask)))
    
    (define/public (can-touch? file mode)
      (for/and ([mode (if (list? mode) (in-list mode) (in-value mode))])
        (enum-case touch-mode mode
          [(name)
           (can-access? (send file parent) (open-mode w))]
          [(length)
           (can-access? file (open-mode w))]
          [(mode)
           (and (string=? (stat-uid (send file read-stat this)) (->user))
                (can-access? (send file parent) (open-mode w)))]
          [(mtime)
           (and (string=? (stat-uid (send file read-stat this)) (->user))
                (can-access? file (open-mode w)))]
          [else
           #f])))
    
    (define/public (can-remove? file)
      (and (can-access? file (open-mode w))
           (can-access? (send file parent) (open-mode w))))
    
    ))

(provide
 touch-mode server-context%)