mbutterick
/
pollen
3
3
Fork 0
Code Issues 1 Pull Requests Projects Releases Wiki Activity

cache template paths

Browse Source
pull/218/head
Matthew Butterick 4 years ago
parent ea25058349
commit da2f6313e7
5 changed files with 79 additions and 64 deletions
Show Stats Download Patch File Download Diff File

2
pollen/cache.rkt
Unescape Escape View File

@ -46,7 +46,7 @@
(raise-argument-error caller-name "path to existing file" path-or-path-string)) (raise-argument-error caller-name "path to existing file" path-or-path-string))
(cond (cond
[(setup:compile-cache-active path) [(setup:compile-cache-active path)
(define key (paths->key path)) (define key (paths->key 'source path))
(define (convert-path-to-cache-record) (define (convert-path-to-cache-record)
(when (let ([crs (current-render-source)]) (when (let ([crs (current-render-source)])
(and crs (not (equal? crs path)))) (and crs (not (equal? crs path))))

32
pollen/private/cache-utils.rkt
Unescape Escape View File

@ -22,7 +22,9 @@
;; because we don't want to attach a mod date ;; because we don't want to attach a mod date
;; because cache validity is not sensitive to mod date of output path ;; because cache validity is not sensitive to mod date of output path
;; (in fact we would expect it to be earlier, since we want to rely on an earlier version) ;; (in fact we would expect it to be earlier, since we want to rely on an earlier version)
(define (paths->key source-path [template-path #false] [output-path #false]) (define (paths->key cache-type source-path [template-path #false] [output-path #false])
(unless (symbol? cache-type)
(raise-argument-error 'paths->key "symbol" cache-type))
(define path-strings-to-track (define path-strings-to-track
(list* source-path (list* source-path
;; if template has a source file, track that instead ;; if template has a source file, track that instead
@ -38,20 +40,22 @@
(define poly-flag (and (has-inner-poly-ext? source-path) (current-poly-target))) (define poly-flag (and (has-inner-poly-ext? source-path) (current-poly-target)))
(define path+mod-time-pairs (define path+mod-time-pairs
(for/list ([ps (in-list path-strings-to-track)]) (for/list ([ps (in-list path-strings-to-track)])
(cond (match ps
[ps (define cp (->complete-path ps)) [(? symbol? sym) sym]
[#false #false]
[_ (define cp (->complete-path ps))
(unless (file-exists? cp) (unless (file-exists? cp)
(message (format "watchlist file /~a does not exist" (find-relative-path (current-project-root) cp)))) (message (format "watchlist file /~a does not exist" (find-relative-path (current-project-root) cp))))
(cons (path->string cp) (file-or-directory-modify-seconds cp #false (λ () 0)))] (cons (path->string cp) (file-or-directory-modify-seconds cp #false (λ () 0)))])))
[else #false]))) (list* cache-type env-rec poly-flag (and output-path (path->string output-path)) path+mod-time-pairs))
(list* env-rec poly-flag (and output-path (path->string output-path)) path+mod-time-pairs))
(define (key->source-path key) (car (fourth key))) (define (key->source-path key) (car (fifth key)))
(define (key->output-path key) (third key)) (define (key->output-path key) (fourth key))
(define (key->type key) (car key))
(module-test-internal (module-test-internal
(define ps "/users/nobody/project/source.html.pm") (define ps "/users/nobody/project/source.html.pm")
(check-equal? (key->source-path (paths->key ps)) ps)) (check-equal? (key->source-path (paths->key 'source ps)) ps))
(define-namespace-anchor cache-utils-module-ns) (define-namespace-anchor cache-utils-module-ns)
@ -94,11 +98,11 @@
(values cache-dir private-cache-dir)) (values cache-dir private-cache-dir))
(define (cache-ref! key path-hash-thunk (define (cache-ref! key path-hash-thunk
#:dest-path [path-for-dest 'source]
#:notify-cache-use [notify-proc void]) #:notify-cache-use [notify-proc void])
(define dest-path ((case path-for-dest (define dest-path ((match (key->type key)
[(source) key->source-path] ['source key->source-path]
[(output) key->output-path]) key)) ['output key->output-path]
['template (λ (k) (path-add-extension (key->source-path key) (string->bytes/utf-8 (format ".~a-template" (current-poly-target)))))]) key))
(define-values (cache-dir private-cache-dir) (make-cache-dirs dest-path)) (define-values (cache-dir private-cache-dir) (make-cache-dirs dest-path))
(define-values (dest-path-dir dest-path-filename _) (split-path dest-path)) (define-values (dest-path-dir dest-path-filename _) (split-path dest-path))
(define dest-file (build-path cache-dir (format "~a.rktd" dest-path-filename))) (define dest-file (build-path cache-dir (format "~a.rktd" dest-path-filename)))
@ -124,4 +128,4 @@
[(or "cache attempt failed: could not acquire exclusive lock" [(or "cache attempt failed: could not acquire exclusive lock"
"cache attempt failed: could not acquire shared lock") (void)] "cache attempt failed: could not acquire shared lock") (void)]
[_ (log-pollen-error str)]))) [_ (log-pollen-error str)])))
(deserialize (file->value dest-file))) (deserialize (file->value dest-file)))

6
pollen/private/preheat-cache.rkt
Unescape Escape View File

@ -14,7 +14,7 @@
(define-values (_ private-cache-dir) (make-cache-dirs path)) (define-values (_ private-cache-dir) (make-cache-dirs path))
(define cache-db-file (build-path private-cache-dir "cache.rktd")) (define cache-db-file (build-path private-cache-dir "cache.rktd"))
(and (file-exists? cache-db-file) (and (file-exists? cache-db-file)
(hash-has-key? (file->value cache-db-file) (paths->key path)))) (hash-has-key? (file->value cache-db-file) (paths->key 'source path))))
(define (preheat-cache starting-dir [wants-parallel-setup? #false] [wants-dry-run? #false]) (define (preheat-cache starting-dir [wants-parallel-setup? #false] [wants-dry-run? #false])
(unless (and (path-string? starting-dir) (directory-exists? starting-dir)) (unless (and (path-string? starting-dir) (directory-exists? starting-dir))
@ -69,11 +69,11 @@
(loop rest (cons wpidx actives))])] (loop rest (cons wpidx actives))])]
[(list wpidx wp 'job-finished path result) [(list wpidx wp 'job-finished path result)
(if result (if result
(cache-ref! (paths->key path) (λ () result)) (cache-ref! (paths->key 'source path) (λ () result))
(message (format "caching failed on job ~a: ~a" (add1 wpidx) (find-relative-path starting-dir path)))) (message (format "caching failed on job ~a: ~a" (add1 wpidx) (find-relative-path starting-dir path))))
(loop paths (remq wpidx actives))])))] (loop paths (remq wpidx actives))])))]
[else (for ([path (in-list uncached-paths)]) [else (for ([path (in-list uncached-paths)])
(message (format "caching: ~a" (find-relative-path starting-dir path))) (message (format "caching: ~a" (find-relative-path starting-dir path)))
(match (with-handlers ([exn:fail? (λ (e) #f)]) (path->hash path)) (match (with-handlers ([exn:fail? (λ (e) #f)]) (path->hash path))
[#false (message (format "caching failed: ~a" (find-relative-path starting-dir path)))] [#false (message (format "caching failed: ~a" (find-relative-path starting-dir path)))]
[result (cache-ref! (paths->key path) (λ () result))]))])) [result (cache-ref! (paths->key 'source path) (λ () result))]))]))

2
pollen/private/ts.rktd
Unescape Escape View File

@ -1 +1 @@
1580599066 1580709571

101
pollen/render.rkt
Unescape Escape View File

@ -42,10 +42,10 @@
;; create a new key with current files. If the key is in the hash, the render has happened. ;; create a new key with current files. If the key is in the hash, the render has happened.
;; if not, a new render is needed. ;; if not, a new render is needed.
(define (update-mod-date-hash! source-path template-path) (define (update-mod-date-hash! source-path template-path)
(hash-set! mod-date-hash (paths->key source-path template-path) #true)) (hash-set! mod-date-hash (paths->key 'output source-path template-path) #true))
(define (mod-date-missing-or-changed? source-path template-path) (define (mod-date-missing-or-changed? source-path template-path)
(not (hash-has-key? mod-date-hash (paths->key source-path template-path)))) (not (hash-has-key? mod-date-hash (paths->key 'output source-path template-path))))
(define (parallel-render source-paths-in job-count-arg) (define (parallel-render source-paths-in job-count-arg)
;; if jobs are already in the cache, pull them out before assigning workers ;; if jobs are already in the cache, pull them out before assigning workers
@ -53,15 +53,15 @@
(define-values (uncached-source-paths previously-cached-jobs) (define-values (uncached-source-paths previously-cached-jobs)
(for/fold ([usps null] (for/fold ([usps null]
[pcjs null]) [pcjs null])
([path (in-list source-paths-in)]) ([source-path (in-list source-paths-in)])
(match (let/ec exit (match (let/ec exit
;; todo: faster test (define exiter (λ () (exit 'cache-miss)))
;; the problem with this test is that it's not cheap for uncached files: (define output-path (or (->output-path source-path) #false))
;; it ultimatedly calls get-template-for, (define template-path
;; which looks in metas, so the file ends up being compiled anyhow. (cache-ref! (template-cache-key source-path output-path) exiter))
(render-to-file-if-needed path #f #f (λ () (exit 'cache-miss)))) (render-to-file-if-needed source-path template-path output-path exiter))
['cache-miss (values (cons path usps) pcjs)] ['cache-miss (values (cons source-path usps) pcjs)]
[_ (values usps (cons (cons path #true) pcjs))]))) [_ (values usps (cons (cons source-path #true) pcjs))])))
(define job-count (define job-count
(min (min
@ -74,22 +74,22 @@
;; initialize the workers ;; initialize the workers
(define worker-evts (define worker-evts
(for/list ([wpidx (in-range job-count)]) (for/list ([wpidx (in-range job-count)])
(define wp (place ch (define wp (place ch
(let loop () (let loop ()
(match-define (cons path poly-target) (match-define (cons path poly-target)
(place-channel-put/get ch (list 'wants-job))) (place-channel-put/get ch (list 'wants-job)))
(parameterize ([current-poly-target poly-target]) (parameterize ([current-poly-target poly-target])
(place-channel-put/get ch (list 'wants-lock (->output-path path))) (place-channel-put/get ch (list 'wants-lock (->output-path path)))
;; trap any exceptions and pass them back as crashed jobs. ;; trap any exceptions and pass them back as crashed jobs.
;; otherwise, a crashed rendering place can't recover, and the parallel job will be stuck. ;; otherwise, a crashed rendering place can't recover, and the parallel job will be stuck.
(with-handlers ([exn:fail? (λ (e) (place-channel-put ch (list 'crashed-job path #f)))]) (with-handlers ([exn:fail? (λ (e) (place-channel-put ch (list 'crashed-job path #f)))])
(match-define-values (_ _ ms _) (match-define-values (_ _ ms _)
;; we don't use `render-to-file-if-needed` because we've already checked the render cache ;; we don't use `render-to-file-if-needed` because we've already checked the render cache
;; if we reached this point, we know we need a render ;; if we reached this point, we know we need a render
(time-apply render-to-file (list path))) (time-apply render-to-file (list path)))
(place-channel-put ch (list 'finished-job path ms)))) (place-channel-put ch (list 'finished-job path ms))))
(loop)))) (loop))))
(handle-evt wp (λ (val) (list* wpidx wp val))))) (handle-evt wp (λ (val) (list* wpidx wp val)))))
(define poly-target (current-poly-target)) (define poly-target (current-poly-target))
@ -127,7 +127,7 @@
;; crashed jobs are completed jobs that weren't finished ;; crashed jobs are completed jobs that weren't finished
(for/list ([(path finished?) (in-dict completed-jobs)] (for/list ([(path finished?) (in-dict completed-jobs)]
#:unless finished?) #:unless finished?)
path)] path)]
[else [else
(match (apply sync worker-evts) (match (apply sync worker-evts)
[(list wpidx wp 'wants-job) [(list wpidx wp 'wants-job)
@ -240,14 +240,13 @@
(define render-result (define render-result
(cond (cond
[render-cache-activated? [render-cache-activated?
(define key (paths->key source-path template-path output-path)) (define key (paths->key 'output source-path template-path output-path))
(hash-ref! render-ram-cache (hash-ref! render-ram-cache
;; within a session, this will prevent repeat players like "template.html.p" ;; within a session, this will prevent repeat players like "template.html.p"
;; from hitting the file cache repeatedly ;; from hitting the file cache repeatedly
key key
(cache-ref! key (cache-ref! key
render-thunk render-thunk
#:dest-path 'output
#:notify-cache-use #:notify-cache-use
(λ (str) (λ (str)
(message (format "from cache /~a" (message (format "from cache /~a"
@ -312,7 +311,6 @@
(define (render-null-source source-path . ignored-paths) (define (render-null-source source-path . ignored-paths)
;((complete-path?) #:rest any/c . ->* . bytes?) ;((complete-path?) #:rest any/c . ->* . bytes?)
;; All this does is copy the source. Hence, "null". ;; All this does is copy the source. Hence, "null".
;; todo: add test to avoid copying if unnecessary (good idea in case the file is large)
(file->bytes source-path)) (file->bytes source-path))
(define-namespace-anchor render-module-ns) (define-namespace-anchor render-module-ns)
@ -383,7 +381,7 @@
(define (file-exists-or-has-source? path) ; path could be #f (define (file-exists-or-has-source? path) ; path could be #f
(and path (for/first ([proc (in-list (list values ->preproc-source-path ->null-source-path))] (and path (for/first ([proc (in-list (list values ->preproc-source-path ->null-source-path))]
#:when (file-exists? (proc path))) #:when (file-exists? (proc path)))
path))) path)))
(define (get-template-from-metas source-path output-path-ext) (define (get-template-from-metas source-path output-path-ext)
(with-handlers ([exn:fail:contract? (λ (e) #f)]) ; in case source-path doesn't work with cached-require (with-handlers ([exn:fail:contract? (λ (e) #f)]) ; in case source-path doesn't work with cached-require
@ -406,22 +404,35 @@
(build-path (current-server-extras-path) (build-path (current-server-extras-path)
(add-ext (setup:fallback-template-prefix source-path) output-path-ext)))) (add-ext (setup:fallback-template-prefix source-path) output-path-ext))))
(define template-ram-cache (make-hash))
(define (template-cache-key source-path output-path)
(paths->key 'template source-path (current-poly-target) output-path))
(define+provide/contract (get-template-for source-path [maybe-output-path #f]) (define+provide/contract (get-template-for source-path [maybe-output-path #f])
((complete-path?)((or/c #f complete-path?)) . ->* . (or/c #f complete-path?)) ((complete-path?)((or/c #f complete-path?)) . ->* . (or/c #f complete-path?))
(match source-path (define output-path (cond
[(or (? markup-source?) (? markdown-source?)) [maybe-output-path]
(define output-path (cond [(->output-path source-path)]
[maybe-output-path] [else #false]))
[(->output-path source-path)] (define key (template-cache-key source-path output-path))
[else #false])) (hash-ref! template-ram-cache
;; output-path may not have an extension ;; within a session, this will prevent repeat players like "template.html.p"
(define output-path-ext (cond ;; from hitting the file cache repeatedly
[(get-ext output-path)] key
[(current-poly-target)] (cache-ref! key
[else #false])) (λ ()
(for/or ([proc (list get-template-from-metas get-default-template get-fallback-template)]) (match source-path
(file-exists-or-has-source? (proc source-path output-path-ext)))] [(or (? markup-source?) (? markdown-source?))
[_ #false])) ;; output-path may not have an extension
(define output-path-ext (cond
[(get-ext output-path)]
[(current-poly-target)]
[else #false]))
(for/or ([proc (list get-template-from-metas
get-default-template
get-fallback-template)])
(file-exists-or-has-source? (proc source-path output-path-ext)))]
[_ #false])))))
(module-test-external (module-test-external
(require pollen/setup sugar/file sugar/coerce) (require pollen/setup sugar/file sugar/coerce)

Write Preview
Loading…
Cancel
Save