cache template paths

pollen/cache.rkt

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

pollen/private/cache-utils.rkt

@@ -22,7 +22,9 @@
 ;; because we don't want to attach a mod date
 ;; 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)
-(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
     (list* source-path
            ;; 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 path+mod-time-pairs
     (for/list ([ps (in-list path-strings-to-track)])
-              (cond
-                [ps (define cp (->complete-path ps))
+              (match ps
+                [(? symbol? sym) sym]
+                [#false #false]
+                [_ (define cp (->complete-path ps))
                     (unless (file-exists? 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)))]
-                [else #false])))
-  (list* env-rec poly-flag (and output-path (path->string output-path)) path+mod-time-pairs))
+                    (cons (path->string cp) (file-or-directory-modify-seconds cp #false (λ () 0)))])))
+  (list* cache-type 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->output-path key) (third key))
+(define (key->source-path key) (car (fifth key)))
+(define (key->output-path key) (fourth key))
+(define (key->type key) (car key))
 
 (module-test-internal
  (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)
 
@@ -94,11 +98,11 @@
   (values cache-dir private-cache-dir))
 
 (define (cache-ref! key path-hash-thunk
-                    #:dest-path [path-for-dest 'source]
                     #:notify-cache-use [notify-proc void])
-  (define dest-path ((case path-for-dest
-                       [(source) key->source-path]
-                       [(output) key->output-path]) key))
+  (define dest-path ((match (key->type key)
+                       ['source key->source-path]
+                       ['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 (dest-path-dir dest-path-filename _) (split-path dest-path))
   (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"
                        "cache attempt failed: could not acquire shared lock") (void)]
                   [_ (log-pollen-error str)])))
-  (deserialize (file->value dest-file)))
+  (deserialize (file->value dest-file)))

pollen/private/preheat-cache.rkt

@@ -14,7 +14,7 @@
   (define-values (_ private-cache-dir) (make-cache-dirs path))
   (define cache-db-file (build-path private-cache-dir "cache.rktd"))
   (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])
   (unless (and (path-string? starting-dir) (directory-exists? starting-dir))
@@ -69,11 +69,11 @@
                (loop rest (cons wpidx actives))])]
            [(list wpidx wp 'job-finished path 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))))
             (loop paths (remq wpidx actives))])))]
     [else (for ([path (in-list uncached-paths)])
                (message (format "caching: ~a" (find-relative-path starting-dir path)))
                (match (with-handlers ([exn:fail? (λ (e) #f)]) (path->hash 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))]))]))

pollen/private/ts.rktd

@@ -1 +1 @@
-1580599066
+1580709571

pollen/render.rkt

@@ -42,10 +42,10 @@
 ;; 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.
 (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)
-  (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)
   ;; 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)
     (for/fold ([usps null]
                [pcjs null])
-              ([path (in-list source-paths-in)])
+              ([source-path (in-list source-paths-in)])
       (match (let/ec exit
-               ;; todo: faster test
-               ;; the problem with this test is that it's not cheap for uncached files:
-               ;; it ultimatedly calls get-template-for,
-               ;; which looks in metas, so the file ends up being compiled anyhow.
-               (render-to-file-if-needed path #f #f (λ () (exit 'cache-miss))))
-        ['cache-miss (values (cons path usps) pcjs)]
-        [_ (values usps (cons (cons path #true) pcjs))])))
+               (define exiter (λ () (exit 'cache-miss)))
+               (define output-path (or (->output-path source-path) #false))
+               (define template-path
+                 (cache-ref! (template-cache-key source-path output-path) exiter))
+               (render-to-file-if-needed source-path template-path output-path exiter))
+        ['cache-miss (values (cons source-path usps) pcjs)]
+        [_ (values usps (cons (cons source-path #true) pcjs))])))
   
   (define job-count
     (min
@@ -74,22 +74,22 @@
   ;; initialize the workers
   (define worker-evts
     (for/list ([wpidx (in-range job-count)])
-              (define wp (place ch
-                                (let loop ()
-                                  (match-define (cons path poly-target)
-                                    (place-channel-put/get ch (list 'wants-job)))
-                                  (parameterize ([current-poly-target poly-target])
-                                    (place-channel-put/get ch (list 'wants-lock (->output-path path)))
-                                    ;; 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.
-                                    (with-handlers ([exn:fail? (λ (e) (place-channel-put ch (list 'crashed-job path #f)))])
-                                      (match-define-values (_ _ ms _)
-                                        ;; 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
-                                        (time-apply render-to-file (list path)))
-                                      (place-channel-put ch (list 'finished-job path ms))))
-                                  (loop))))
-              (handle-evt wp (λ (val) (list* wpidx wp val)))))
+      (define wp (place ch
+                        (let loop ()
+                          (match-define (cons path poly-target)
+                            (place-channel-put/get ch (list 'wants-job)))
+                          (parameterize ([current-poly-target poly-target])
+                            (place-channel-put/get ch (list 'wants-lock (->output-path path)))
+                            ;; 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.
+                            (with-handlers ([exn:fail? (λ (e) (place-channel-put ch (list 'crashed-job path #f)))])
+                              (match-define-values (_ _ ms _)
+                                ;; 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
+                                (time-apply render-to-file (list path)))
+                              (place-channel-put ch (list 'finished-job path ms))))
+                          (loop))))
+      (handle-evt wp (λ (val) (list* wpidx wp val)))))
      
   (define poly-target (current-poly-target))
 
@@ -127,7 +127,7 @@
        ;; crashed jobs are completed jobs that weren't finished
        (for/list ([(path finished?) (in-dict completed-jobs)]
                   #:unless finished?)
-                 path)]
+         path)]
       [else
        (match (apply sync worker-evts)
          [(list wpidx wp 'wants-job)
@@ -240,14 +240,13 @@
     (define render-result
       (cond
         [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
                     ;; within a session, this will prevent repeat players like "template.html.p"
                     ;; from hitting the file cache repeatedly
                     key
                     (cache-ref! key
                                 render-thunk
-                                #:dest-path 'output
                                 #:notify-cache-use
                                 (λ (str)
                                   (message (format "from cache /~a"
@@ -312,7 +311,6 @@
 (define (render-null-source source-path . ignored-paths)
   ;((complete-path?) #:rest any/c . ->* . bytes?)
   ;; 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))
 
 (define-namespace-anchor render-module-ns)
@@ -383,7 +381,7 @@
 (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))]
                         #:when (file-exists? (proc path)))
-                       path)))
+              path)))
 
 (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
@@ -406,22 +404,35 @@
        (build-path (current-server-extras-path)
                    (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])
   ((complete-path?)((or/c #f complete-path?)) . ->* . (or/c #f complete-path?))
-  (match source-path
-    [(or (? markup-source?) (? markdown-source?))
-     (define output-path (cond
-                           [maybe-output-path]
-                           [(->output-path source-path)]
-                           [else #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]))
+  (define output-path (cond
+                        [maybe-output-path]
+                        [(->output-path source-path)]
+                        [else #false]))
+  (define key (template-cache-key source-path output-path))
+  (hash-ref! template-ram-cache
+             ;; within a session, this will prevent repeat players like "template.html.p"
+             ;; from hitting the file cache repeatedly
+             key
+             (cache-ref! key
+                         (λ ()  
+                           (match source-path
+                             [(or (? markup-source?) (? markdown-source?))
+                              ;; 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
  (require pollen/setup sugar/file sugar/coerce)