source: project/release/4/ugarit/trunk/directory-rules.scm @ 25521

Last change on this file since 25521 was 20325, checked in by Alaric Snell-Pym, 11 years ago

ugarit: Added missing directory-rules.scm, README updates

File size: 6.9 KB
Line 
1(module directory-rules
2        (call-with-context-support call-with-context object-matches make-filesystem-object-pattern-checker)
3
4(import scheme)
5(import chicken)
6(import regex)
7(import srfi-18)
8(import files)
9(import extras)
10
11(use srfi-1)
12(use srfi-13)
13(use posix)
14(use matchable)
15
16;; Philosophy:
17;; Directory rules are either triggered by relative patterns, global patterns, or general patterns
18;; A relative pattern is a path relative to the rules file, to a directory, then a object-pattern to apply there.
19;; A global pattern is an absolute path to a directory, then a object-pattern to apply there.
20;; A general pattern is just a object-pattern that is applied to this directory and any under it.
21;;
22;; 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>).
23;;
24;; Rules are specified in a global file (in which relative patterns are not permitted), or in local files in the
25;; directories being considered
26;;
27;; Each rule consists of a pattern, then some action expression.
28;; Rule files consist of s-expressions of the form (pattern action).
29;; Eg:
30;; ("foo/bar/baz" (glob "*.gz") <action>)
31;; ("/etc" (or (name "passwd") (name "shadow")) <action>)
32;; (* (glob "*~") <action>)
33
34(define-record anchored-rule
35   path ; Always an absolute path
36   object-pattern
37   action)
38
39(define-record-printer (anchored-rule x out)
40   (fprintf out "(anchored-rule ~S ~S ~S)"
41      (anchored-rule-path x)
42      (anchored-rule-object-pattern x)
43      (anchored-rule-action x)))
44
45(define-record general-rule
46   object-pattern
47   action)
48
49(define-record-printer (general-rule x out)
50   (fprintf out "(general-rule ~S ~S)"
51      (general-rule-object-pattern x)
52      (general-rule-action x)))
53
54(define-record context
55   all-rules
56   local-rules) ; anchored rules that apply to the current location converted to general rules, plus general rules, in specificity order
57
58(define *context* (make-parameter #f))
59
60(define (parse-top-level-context rules)
61   (let next ((parsed-rules '())
62              (unparsed-rules rules))
63      (match unparsed-rules
64         (() (make-context parsed-rules '()))
65         ((('* object-pattern . action) . more)
66            (next (cons (make-general-rule object-pattern action) parsed-rules) more))
67         (((path object-pattern . action) . more)
68            (if (string-prefix? "/" path)
69               (next (cons (make-anchored-rule path object-pattern action) parsed-rules)
70                  more)
71               (error "Paths in global rules must be absolute" path)))
72         (else (error "Invalid syntax in global rules" unparsed-rules)))))
73
74;; Declare an outermost dynamic scope for processing, with an initial list of global and general pattern rules
75(define (call-with-context-support global-rules thunk)
76   (let ((top-level-context (parse-top-level-context global-rules)))
77      (parameterize ((*context* top-level-context)) (thunk))))
78
79(define (choose-local-rules path all-rules)
80   (map (lambda (rule)
81      (if (anchored-rule? rule)
82         (make-general-rule (anchored-rule-object-pattern rule) (anchored-rule-action rule))
83         rule))
84     
85      (filter (lambda (rule)
86         (if (anchored-rule? rule)
87            (string=? path (anchored-rule-path rule))
88            #t))
89         
90         all-rules)))
91
92(define (parse-local-context basepath parent-context rules)
93   (let next ((parsed-rules (context-all-rules parent-context))
94              (unparsed-rules rules))
95      (match unparsed-rules
96         (() (make-context parsed-rules (choose-local-rules basepath parsed-rules)))
97         ((('* object-pattern . action) . more)
98            (next (cons (make-general-rule object-pattern action) parsed-rules) more))
99         (((path object-pattern . action) . more)
100            (if (string-prefix? "/" path)
101               (next (cons (make-anchored-rule path object-pattern action) parsed-rules)
102                  more)
103               (next (cons (make-anchored-rule (make-absolute-pathname basepath path) object-pattern action) parsed-rules)
104                  more)))
105         (else (error "Invalid syntax in local rules" unparsed-rules)))))
106
107;; Declare an inner dynamic scope, with the supplied path, and zero or more extra rules relative to that path
108;; Valid only within call-woth-context-support or another call-with-context
109(define (call-with-context rules path thunk)
110   (let ((local-context (parse-local-context path (*context*) rules)))
111      (parameterize ((*context* local-context)) (thunk))))
112
113(define (check-object-pattern object-pattern-checker object object-pattern)
114   (match object-pattern
115      (('not pattern)
116         (not (check-object-pattern object-pattern-checker object pattern)))
117      (('and . patterns)
118         (every (cut check-object-pattern object-pattern-checker object <>) patterns))
119      (('or . patterns)
120         (any (cut check-object-pattern object-pattern-checker object <>) patterns))
121      (pattern (object-pattern-checker object pattern))))
122
123;; Check if an object matches, within the current context
124;; Does not care with the object is; caller provides an object-pattern-checker,
125;; that being a procedure that takes an object and a basic object-pattern (and/or/not is handled automatically)
126;; and returns #t/#f
127;; Returns a list of matching actions, with the most specific at the head of the list.
128;; Valid only within call-with-context
129(define (object-matches object object-pattern-checker)
130   (let next ((rules (context-local-rules (*context*))))
131      (if (null? rules)
132         '() ; All done, recurse back up
133         (let ((rule (car rules)))
134            (if (check-object-pattern object-pattern-checker object (general-rule-object-pattern rule))
135               (cons (general-rule-action rule) (next (cdr rules)))
136               (next (cdr rules)))))))
137
138(define (modification-age filepath)
139   (- (time->seconds (current-time)) (file-modification-time filepath)))
140
141;; Implements filesystem object patterns, as described in the comment at the top of this file
142;; Objects are taken as filenames, without any directory components, valid within the specified directory
143;; (name "<name>"), (glob "<glob>"), (modified-within <n> <seconds|minutes|hours|days>)
144(define ((make-filesystem-object-pattern-checker directory-absolute-path) object pattern)
145   (match pattern
146      (('name name) (string=? object name))
147      (('glob glob-pattern) (string-match (regexp (glob->regexp glob-pattern)) object))
148      (('modified-within n 'seconds)
149         (< (modification-age (make-absolute-pathname directory-absolute-path object)) n))
150      (('modified-within n 'minutes)
151         (< (modification-age (make-absolute-pathname directory-absolute-path object)) (* n 60)))
152      (('modified-within n 'hours)
153         (< (modification-age (make-absolute-pathname directory-absolute-path object)) (* n 3600)))
154      (('modified-within n 'days)
155         (< (modification-age (make-absolute-pathname directory-absolute-path object)) (* n 86400)))
156      (else (error "Unknown object pattern" pattern))))
157
158)
Note: See TracBrowser for help on using the repository browser.