Memoize `bin-commit-counts' to reduce build times

1 files changed, 38 insertions, 1 deletions

diff --git a/haunt/pages/about.sxml b/haunt/pages/about.sxml
index 88dece2..7003d4a 100644
--- a/haunt/pages/about.sxml
+++ b/haunt/pages/about.sxml
@@ -227,6 +227,43 @@ If `end' is specified, return `#t' iff `date' is prior to `end'."
               (increment-date-by-month date))
         (reverse! (map string->number bin)))))
 
+(define bin-commit-count-cache-file-name "./.bin-commit-counts.sexp")
+(define* (bin-commit-counts-memoized repository-path #:key start end)
+  "Memoized (across multiple invocations of Haunt) `bin-commit-counts'
+
+Results are cached in an alist serialized to the path specified by
+`bin-commit-count-cache-file-name', and are invalidated when more than a week
+old."
+  (unless (file-exists? bin-commit-count-cache-file-name)
+    ;; Initialize the cache on disk with an empty alist if the cache file hasn't
+    ;; been created yet.
+    (call-with-output-file bin-commit-count-cache-file-name
+      (lambda (port) (write '() port))))
+  (let* ((cache (call-with-input-file bin-commit-count-cache-file-name read))
+         (key repository-path))
+    (define result
+      (match (assoc-ref cache key)
+        ((age-timestamp . result)
+         (if (<= age-timestamp
+                 ;; One week ago, as a UNIX timestamp.
+                 (time-second
+                  (subtract-duration
+                   (current-time 'time-utc)
+                   (make-time 'time-duration 0 (* 60 60 24 7)))))
+             (bin-commit-counts repository-path #:start start #:end end)
+             result))
+        (_ (bin-commit-counts repository-path #:start start #:end end))))
+    ;; When we've either retrieved or calculated the result, we'll update the
+    ;; cache on disk. It doesn't matter too much if we do this unconditionally
+    ;; because it isn't nearly as slow as walking the git logs.
+    (call-with-output-file bin-commit-count-cache-file-name
+      (lambda (port)
+        ;; Note that we use a UNIX timestamp rather than SRFI-19 time objects
+        ;; because the former is actually `read'able.
+        (let ((new-timestamp (time-second (current-time 'time-utc))))
+          (write (assoc-set! cache key (cons new-timestamp result)) port))))
+    result))
+
 (define* (render-histogram summary #:key (width 60) (height 25))
   "Render a list of intervals as an SVG histogram."
   ;; Assuming an interval lasts a month, I'm lucky to get 50 commits in.
@@ -267,7 +304,7 @@ If `end' is specified, return `#t' iff `date' is prior to `end'."
   (let ((start-date (date-of-first-commit repository-path)))
     `(tr (td ,(hyperlink url name))
          (td ,(lang-to-button lang))
-         (td ,(render-histogram (bin-commit-counts repository-path #:end end-date)))
+         (td ,(render-histogram (bin-commit-counts-memoized repository-path #:end end-date)))
          (td ,(if end-date
                   (format #f "~a - ~a"
                           (date->string start-date "~b ~e ~Y")