(module directory-rules
	(call-with-context-support call-with-context object-matches make-filesystem-object-pattern-checker)

(import scheme)
(import chicken)
(import regex)
(import srfi-18)
(import files)
(import extras)

(use srfi-1)
(use srfi-13)
(use posix)
(use matchable)

;; Philosophy:
;; Directory rules are either triggered by relative patterns, global patterns, or general patterns
;; A relative pattern is a path relative to the rules file, to a directory, then a object-pattern to apply there.
;; A global pattern is an absolute path to a directory, then a object-pattern to apply there.
;; A general pattern is just a object-pattern that is applied to this directory and any under it.
;; 
;; A object-pattern is either (name "<name>"), (glob "<glob>"), (modified-within <n> <seconds|minutes|hours|days>), (not <object-pattern>), (and <object-pattern>...), or (or <object-pattern>).
;;
;; Rules are specified in a global file (in which relative patterns are not permitted), or in local files in the
;; directories being considered
;;
;; Each rule consists of a pattern, then some action expression.
;; Rule files consist of s-expressions of the form (pattern action).
;; Eg:
;; ("foo/bar/baz" (glob "*.gz") <action>)
;; ("/etc" (or (name "passwd") (name "shadow")) <action>)
;; (* (glob "*~") <action>)

(define-record anchored-rule
   path ; Always an absolute path
   object-pattern
   action)

(define-record-printer (anchored-rule x out)
   (fprintf out "(anchored-rule ~S ~S ~S)"
      (anchored-rule-path x)
      (anchored-rule-object-pattern x)
      (anchored-rule-action x)))

(define-record general-rule
   object-pattern
   action)

(define-record-printer (general-rule x out)
   (fprintf out "(general-rule ~S ~S)"
      (general-rule-object-pattern x)
      (general-rule-action x)))

(define-record context
   all-rules
   local-rules) ; anchored rules that apply to the current location converted to general rules, plus general rules, in specificity order

(define *context* (make-parameter #f))

(define (parse-top-level-context rules)
   (let next ((parsed-rules '())
              (unparsed-rules rules))
      (match unparsed-rules
         (() (make-context parsed-rules '()))
         ((('* object-pattern . action) . more)
            (next (cons (make-general-rule object-pattern action) parsed-rules) more))
         (((path object-pattern . action) . more)
            (if (string-prefix? "/" path)
               (next (cons (make-anchored-rule path object-pattern action) parsed-rules)
                  more)
               (error "Paths in global rules must be absolute" path)))
         (else (error "Invalid syntax in global rules" unparsed-rules)))))

;; Declare an outermost dynamic scope for processing, with an initial list of global and general pattern rules
(define (call-with-context-support global-rules thunk)
   (let ((top-level-context (parse-top-level-context global-rules)))
      (parameterize ((*context* top-level-context)) (thunk))))

(define (choose-local-rules path all-rules)
   (map (lambda (rule)
      (if (anchored-rule? rule)
         (make-general-rule (anchored-rule-object-pattern rule) (anchored-rule-action rule))
         rule))
      
      (filter (lambda (rule)
         (if (anchored-rule? rule)
            (string=? path (anchored-rule-path rule))
            #t))
         
         all-rules)))

(define (parse-local-context basepath parent-context rules)
   (let next ((parsed-rules (context-all-rules parent-context))
              (unparsed-rules rules))
      (match unparsed-rules
         (() (make-context parsed-rules (choose-local-rules basepath parsed-rules)))
         ((('* object-pattern . action) . more)
            (next (cons (make-general-rule object-pattern action) parsed-rules) more))
         (((path object-pattern . action) . more)
            (if (string-prefix? "/" path)
               (next (cons (make-anchored-rule path object-pattern action) parsed-rules)
                  more)
               (next (cons (make-anchored-rule (make-absolute-pathname basepath path) object-pattern action) parsed-rules)
                  more)))
         (else (error "Invalid syntax in local rules" unparsed-rules)))))

;; Declare an inner dynamic scope, with the supplied path, and zero or more extra rules relative to that path
;; Valid only within call-woth-context-support or another call-with-context
(define (call-with-context rules path thunk)
   (let ((local-context (parse-local-context path (*context*) rules)))
      (parameterize ((*context* local-context)) (thunk))))

(define (check-object-pattern object-pattern-checker object object-pattern)
   (match object-pattern
      (('not pattern)
         (not (check-object-pattern object-pattern-checker object pattern)))
      (('and . patterns)
         (every (cut check-object-pattern object-pattern-checker object <>) patterns))
      (('or . patterns)
         (any (cut check-object-pattern object-pattern-checker object <>) patterns))
      (pattern (object-pattern-checker object pattern))))

;; Check if an object matches, within the current context
;; Does not care with the object is; caller provides an object-pattern-checker,
;; that being a procedure that takes an object and a basic object-pattern (and/or/not is handled automatically)
;; and returns #t/#f
;; Returns a list of matching actions, with the most specific at the head of the list.
;; Valid only within call-with-context
(define (object-matches object object-pattern-checker)
   (let next ((rules (context-local-rules (*context*))))
      (if (null? rules)
         '() ; All done, recurse back up
         (let ((rule (car rules)))
            (if (check-object-pattern object-pattern-checker object (general-rule-object-pattern rule))
               (cons (general-rule-action rule) (next (cdr rules)))
               (next (cdr rules)))))))

(define (modification-age filepath)
   (- (time->seconds (current-time)) (file-modification-time filepath)))

;; Implements filesystem object patterns, as described in the comment at the top of this file
;; Objects are taken as filenames, without any directory components, valid within the specified directory
;; (name "<name>"), (glob "<glob>"), (modified-within <n> <seconds|minutes|hours|days>)
(define ((make-filesystem-object-pattern-checker directory-absolute-path) object pattern)
   (match pattern
      (('name name) (string=? object name))
      (('glob glob-pattern) (string-match (regexp (glob->regexp glob-pattern)) object))
      (('modified-within n 'seconds)
         (< (modification-age (make-absolute-pathname directory-absolute-path object)) n))
      (('modified-within n 'minutes)
         (< (modification-age (make-absolute-pathname directory-absolute-path object)) (* n 60)))
      (('modified-within n 'hours)
         (< (modification-age (make-absolute-pathname directory-absolute-path object)) (* n 3600)))
      (('modified-within n 'days)
         (< (modification-age (make-absolute-pathname directory-absolute-path object)) (* n 86400)))
      (else (error "Unknown object pattern" pattern))))

)