resource.rkt (12620B)
1 #lang racket/base 2 3 ;; Resources are renderable & referrable objects, (most are html pages). 4 5 ;; (resource path renderer) creates and returns a new "resource" value. The 6 ;; arguments are: 7 ;; - `path': the path of the output file, relative to the working directory, 8 ;; indicating where the resource file should be put at, also corresponding to 9 ;; the URL it will be found at. It must be a `/'-separated relative string, 10 ;; no `..', `.', or `//', and it can end in `/' (which will turn to 11 ;; "index.html"). 12 ;; - `renderer': a unary function that renders the resource, receiving the path 13 ;; for the file to be created as an argument. This path will be different 14 ;; than the `path' argument because this function is invoked in the target 15 ;; directory. 16 ;; The resulting resource value is a function that returns the URL for the 17 ;; resource. The function takes in an optional boolean which defaults to #f, 18 ;; and when #t is given, the result will be an absolute full URL. Note that 19 ;; the function can be used as a value for output, which will use it as a thunk 20 ;; (that renders as the relative URL for the resource). The default relative 21 ;; resulting URL is, of course, a value that depends on the currently rendered 22 ;; resource that uses this value. Creating a resource registers the `renderer' 23 ;; to be executed when rendering is initiated by `render-all'. Note that more 24 ;; resources can be created while rendering; they will also be rendered in turn 25 ;; until no more new resources are created. 26 27 (require scribble/text) 28 29 ;; default file, urls to it will point to its directory instead, a 30 ;; /-suffixed path will render to this file, and `url-roots' entries 31 ;; with 'index will append this file name to a rewritten path that 32 ;; otherwise ends in / 33 (define default-file "index.html") 34 35 ;; the currently rendered directory, as a list 36 (define rendered-dirpath (make-parameter '())) 37 38 ;; A mapping from path prefixes to urls (actually, any string) -- when two 39 ;; paths are in the same prefix, links from one to the other are relative 40 ;; (unless absolute links are requested) , but if they're in different 41 ;; prefixes, the url will be used instead; the roots are expected to be 42 ;; disjoint (= no "/foo" and "/foo/bar" roots). Additionally, optional symbol 43 ;; flags can appear in each entry, currently only 'abs is used below for roots 44 ;; that should always use absolute links (needed for some skeleton pages that 45 ;; are used in nested subdirectories). 46 (provide url-roots) 47 (define url-roots (make-parameter #f)) 48 49 (define cached-roots '(#f . #f)) 50 (define (current-url-roots) 51 ;; takes `url-roots', a (listof (list prefix-string url-string . flags)), and 52 ;; produces an alist with lists of strings for the keys; the prefix-strings 53 ;; are split on "/"s, and the url-strings can be anything at all actually 54 ;; (they are put as-is before the path with a "/" between them). 55 (define roots (url-roots)) 56 (unless (eq? roots (car cached-roots)) 57 (set! cached-roots 58 (cons roots 59 (and (list? roots) (pair? roots) 60 (map (lambda (root) 61 (list* (regexp-match* #rx"[^/]+" (car root)) 62 (regexp-replace #rx"/$" (cadr root) "") 63 (cddr root))) 64 roots))))) 65 (cdr cached-roots)) 66 67 ;; a utility for relative paths, taking the above `default-file' and 68 ;; `url-roots' into consideration. 69 (define (relativize file tgtdir curdir) 70 (define file* (if (equal? file default-file) "" file)) 71 (define roots (current-url-roots)) 72 (define (find-root path mode) 73 (ormap (lambda (root+url+flags) 74 (let loop ([r (car root+url+flags)] [p path]) 75 (if (pair? r) 76 (and (pair? p) (equal? (car p) (car r)) 77 (loop (cdr r) (cdr p))) 78 (case mode 79 [(get-path) `(,(cadr root+url+flags) 80 ,@p 81 ,(if (and (equal? file* "") 82 (memq 'index (cddr root+url+flags))) 83 default-file 84 file*))] 85 [(get-abs-or-true) 86 (if (memq 'abs (cddr root+url+flags)) `("" ,@p) #t)] 87 [else (error 'relativize "internal error: ~e" mode)])))) 88 roots)) 89 (define result 90 (let loop ([t tgtdir] [c curdir] [pfx '()]) 91 (cond 92 ;; find shared prefix 93 [(and (pair? t) (pair? c) (equal? (car t) (car c))) 94 (loop (cdr t) (cdr c) (cons (car t) pfx))] 95 ;; done with the shared prefix, deal with the root now 96 ;; no roots => always use a relative path (useful for debugging) 97 [(not roots) `(,@(map (lambda (_) "..") c) ,@t ,file*)] 98 ;; share a root => use a relative path unless its an absolute root 99 [(find-root (reverse pfx) 'get-abs-or-true) 100 => (lambda (abs/true) 101 `(;; rel. => as above 102 ,@(if (list? abs/true) abs/true (map (lambda (_) "..") c)) 103 ,@t ,file*))] 104 ;; different roots => use the one for the target 105 [(find-root tgtdir 'get-path)] 106 ;; if there isn't any, throw an error 107 [else (error 'relativize "target url is not in any known root: ~a" 108 (string-join `(,@tgtdir ,file*) "/"))]))) 109 (if (equal? '("") result) "." (string-join result "/"))) 110 111 #; 112 (module+ test 113 (require tests/eli-tester) 114 (define R relativize) 115 (let () 116 (test do (test (R "bleh.txt" '() '() ) => "bleh.txt" 117 (R "bleh.txt" '("x") '() ) => "x/bleh.txt" 118 (R "bleh.txt" '("x" "y") '() ) => "x/y/bleh.txt" 119 (R "bleh.txt" '() '("x") ) => "../bleh.txt" 120 (R "bleh.txt" '("x") '("x") ) => "bleh.txt" 121 (R "bleh.txt" '("x" "y") '("x") ) => "y/bleh.txt" 122 (R "bleh.txt" '() '("x" "y")) => "../../bleh.txt" 123 (R "bleh.txt" '("x") '("x" "y")) => "../bleh.txt" 124 (R "bleh.txt" '("x" "y") '("x" "y")) => "bleh.txt" 125 (R "bleh.txt" '("x" "y") '("y" "x")) => "../../x/y/bleh.txt" 126 (R "index.html" '() '() ) => "." 127 (R "index.html" '("x") '() ) => "x/" 128 (R "index.html" '("x" "y") '() ) => "x/y/" 129 (R "index.html" '() '("x") ) => "../" 130 (R "index.html" '("x") '("x") ) => "." 131 (R "index.html" '("x" "y") '("x") ) => "y/" 132 (R "index.html" '() '("x" "y")) => "../../" 133 (R "index.html" '("x") '("x" "y")) => "../" 134 (R "index.html" '("x" "y") '("x" "y")) => "." 135 (R "index.html" '("x" "y") '("y" "x")) => "../../x/y/") 136 do (parameterize ([url-roots '(["/x" "/X/"] ["/y" "/Y/"])]) 137 (test (R "bleh.txt" '() '() ) =error> "not in any" 138 (R "bleh.txt" '("x") '() ) => "/X/bleh.txt" 139 (R "bleh.txt" '("x" "y") '() ) => "/X/y/bleh.txt" 140 (R "bleh.txt" '() '("x") ) =error> "not in any" 141 (R "bleh.txt" '("x") '("x") ) => "bleh.txt" 142 (R "bleh.txt" '("x" "y") '("x") ) => "y/bleh.txt" 143 (R "bleh.txt" '() '("x" "y")) =error> "not in any" 144 (R "bleh.txt" '("x") '("x" "y")) => "../bleh.txt" 145 (R "bleh.txt" '("x" "y") '("x" "y")) => "bleh.txt" 146 (R "bleh.txt" '("x" "y") '("y" "x")) => "/X/y/bleh.txt" 147 (R "index.html" '() '() ) =error> "not in any" 148 (R "index.html" '("x") '() ) => "/X/" 149 (R "index.html" '("x" "y") '() ) => "/X/y/" 150 (R "index.html" '() '("x") ) =error> "not in any" 151 (R "index.html" '("x") '("x") ) => "." 152 (R "index.html" '("x" "y") '("x") ) => "y/" 153 (R "index.html" '() '("x" "y")) =error> "not in any" 154 (R "index.html" '("x") '("x" "y")) => "../" 155 (R "index.html" '("x" "y") '("x" "y")) => "." 156 (R "index.html" '("x" "y") '("y" "x")) => "/X/y/")) 157 do (parameterize ([url-roots '(["/x" "/X/"] ["/y" "/Y/" abs])]) 158 (test (R "foo.txt" '("x" "1") '("x" "2")) => "../1/foo.txt" 159 (R "foo.txt" '("y" "1") '("y" "2")) => "/1/foo.txt"))))) 160 161 ;; utility for keeping a list of renderer thunks 162 (define-values [add-renderer get/reset-renderers] 163 (let ([l '()] [s (make-semaphore 1)]) 164 ;; map paths to #t -- used to avoid overwriting files 165 (define t (make-hash)) 166 (define-syntax-rule (S body) (call-with-semaphore s (lambda () body))) 167 (values (lambda (path renderer) 168 (S (if (hash-ref t path #f) 169 (error 'resource "path used for two resources: ~e" path) 170 (begin (hash-set! t path #t) (set! l (cons renderer l)))))) 171 (lambda () (S (begin0 (reverse l) (set! l '()))))))) 172 173 ;; `#:exists' determines what happens when the render destination exists, it 174 ;; can be one of: #f (do nothing), 'delete-file (delete if a file exists, error 175 ;; if exists as a directory) 176 (provide resource resource?) 177 ;; use a struct to make resources identifiable as such 178 (struct resource (url) #:constructor-name make-resource 179 #:property prop:procedure 0 #:omit-define-syntaxes) 180 (define (resource path0 renderer #:exists [exists 'delete-file]) 181 (define (bad reason) (error 'resource "bad path, ~a: ~e" reason path0)) 182 (unless (string? path0) (bad "must be a string")) 183 (for ([x (in-list '([#rx"^/" "must be relative"] 184 [#rx"//" "must not have empty elements"] 185 [#rx"(?:^|/)[.][.]?(?:/|$)" 186 "must not contain `.' or `..'"]))]) 187 (when (regexp-match? (car x) path0) (bad (cadr x)))) 188 (define path (regexp-replace #rx"(?<=^|/)$" path0 default-file)) 189 (define-values [dirpathlist filename] 190 (let-values ([(l r) (split-at-right (regexp-split #rx"/" path) 1)]) 191 (values l (car r)))) 192 (define (render) 193 (let loop ([ps dirpathlist]) 194 (if (pair? ps) 195 (begin (unless (directory-exists? (car ps)) 196 (if (or (file-exists? (car ps)) (link-exists? (car ps))) 197 (bad "exists as a file/link") 198 (make-directory (car ps)))) 199 (parameterize ([current-directory (car ps)]) 200 (loop (cdr ps)))) 201 (begin (cond [(not exists)] ; do nothing 202 [(or (file-exists? filename) (link-exists? filename)) 203 (delete-file filename)] 204 [(directory-exists? filename) 205 (bad "exists as directory")]) 206 (parameterize ([rendered-dirpath dirpathlist]) 207 (printf " ~a\n" path) 208 (renderer filename)))))) 209 (define absolute-url 210 (lazy (define url (relativize filename dirpathlist '())) 211 (if (url-roots) 212 url 213 ;; we're in local build mode, and insist on an absolute url, so 214 ;; construct a `file://' result 215 (list* "file://" (current-directory) url)))) 216 (when renderer 217 (add-renderer path render)) 218 (define (url [absolute? #f]) 219 ;; be conservative, in case it needs to be extended in the future 220 (case absolute? 221 [(#f) (relativize filename dirpathlist (rendered-dirpath))] 222 [(#t) (force absolute-url)] 223 [else (error 'resource "bad absolute flag value: ~e" absolute?)])) 224 (make-resource url)) 225 226 ;; a convenient utility to create renderers from some output function (like 227 ;; `output-xml' or `display') and some content 228 (provide file-writer) 229 (define ((file-writer writer content) file) 230 (call-with-output-file file (lambda (o) (writer content o)))) 231 232 ;; runs all renderers, and any renderers that might have been added on the way 233 (provide render-all) 234 (define (render-all) 235 (printf "Rendering...\n") 236 (define todo (get/reset-renderers)) 237 (if (null? todo) 238 (printf " Warning: no content to render\n") 239 (let loop ([todo todo]) 240 (unless (null? todo) 241 (for-each (lambda (r) (r)) todo) 242 (loop (get/reset-renderers))))) ; if more were created 243 (printf "Rendering done.\n"))