From 870286d860bf680faa6a376560be592c35b20a04 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@iu.edu>
Date: Wed, 23 Sep 2026 15:49:51 -0400
Subject: [PATCH 1/7] Add `path-prefix-split`

Callers that move a path between build roots explode both paths, compare
the first elements, and strip them. This helper does that once, and the
next commits use it.
---
 path-utils.rkt | 24 ++++++++++++++++++++++++
 1 file changed, 24 insertions(+)

diff --git a/path-utils.rkt b/path-utils.rkt
index 55ad0bc..3d111b6 100644
--- a/path-utils.rkt
+++ b/path-utils.rkt
@@ -46,7 +46,19 @@
       pth-string
       (path->string pth-string)))
 
+;; If `pth` is `root` or lies under it, the path elements below `root`;
+;; otherwise #f.
+(define (path-prefix-split pth root)
+  (define root-parts (explode-path root))
+  (define pth-parts (explode-path pth))
+  (define root-len (length root-parts))
+  (and ((length pth-parts) . >= . root-len)
+       (equal? (for/list ([p (in-list pth-parts)] [_ (in-range root-len)]) p)
+               root-parts)
+       (list-tail pth-parts root-len)))
+
 (provide/contract
+ [path-prefix-split (path-string? path-string? . -> . (or/c false/c (listof path?)))]
  [current-temporary-directory (parameter/c (or/c false/c path-string?))]
  [safely-delete-directory (path-string? . -> . void)]
  [directory-list->directory-list* ((listof path?) . -> . (listof path?))]
@@ -55,3 +67,15 @@
  [make-parent-directory (path-string? . -> . void)]
  [rebase-path (path-string? path-string? . -> . (path-string? . -> . path?))]
  [path->string* (path-string? . -> . string?)])
+
+(module+ test
+  (require rackunit)
+
+  (check-equal? (path-prefix-split "/opt/plt/builds/73400/logs" "/opt/plt/builds")
+                (map string->path '("73400" "logs")))
+  (check-equal? (path-prefix-split "/extra/builds/55389/logs" "/extra/builds")
+                (map string->path '("55389" "logs")))
+  (check-equal? (path-prefix-split "/opt/plt/builds" "/opt/plt/builds") '())
+  ;; a different prefix of the same length does not match
+  (check-false (path-prefix-split "/opt/plt/other/73400" "/opt/plt/builds"))
+  (check-false (path-prefix-split "/opt/plt" "/opt/plt/builds")))

From 66ed2279660b062169ca9853f0ef9566a9f97377 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@iu.edu>
Date: Wed, 23 Sep 2026 15:50:47 -0400
Subject: [PATCH 2/7] Check the prefix that archive lookups strip, and let
 callers set it

An archive records the root its build had when the archive was created.
`archive-extract-path` dropped as many leading elements from a query as
that root has, without comparing them, so a query under any other root
of the same length resolved to an entry at the wrong level. A build that
has aged out to the extra build directory lives under such a root.

Compare the prefix instead, and add a `#:base` argument so that a caller
that knows where the build lives now can say so. cache.rkt passes the
build's current directory.

Primary builds behave as before. Archived builds still fail, as they do
today, because `path->revision` cannot parse their paths; the next commit
fixes that.
---
 archive-test.rkt | 17 +++++++++++++++
 archive.rkt      | 55 +++++++++++++++++++++++++-----------------------
 cache.rkt        | 12 +++++------
 3 files changed, 52 insertions(+), 32 deletions(-)

diff --git a/archive-test.rkt b/archive-test.rkt
index 40a38d3..824ac1f 100644
--- a/archive-test.rkt
+++ b/archive-test.rkt
@@ -39,3 +39,20 @@
 (check-false (archive-directory-exists? archive (build-path (current-directory) "unknown")))
 (check-false (archive-directory-exists? archive (build-path (current-directory) "archive-test.rkt")))
 
+;; A path under a different root with the same number of elements must not
+;; resolve; stripping elements without comparing them used to read an entry
+;; from the wrong level.
+(define cwd-parts (explode-path (current-directory)))
+(define bogus-root
+  (apply build-path (car cwd-parts)
+         (for/list ([_ (in-list (cdr cwd-parts))] [n (in-naturals)])
+           (string->path-element (format "bogus~a" n)))))
+(check-false (archive-directory-exists? archive (build-path bogus-root "static")))
+(check-exn #rx"not in the archive"
+           (lambda () (archive-extract-file archive (build-path bogus-root "archive-test.rkt"))))
+
+;; With `#:base`, a path under the new root finds the entry the archive
+;; recorded under the old one.
+(check-equal? (archive-extract-file archive (build-path bogus-root "archive-test.rkt")
+                                    #:base bogus-root)
+              (file->bytes "archive-test.rkt"))
diff --git a/archive.rkt b/archive.rkt
index 3f68bbe..22ad61c 100644
--- a/archive.rkt
+++ b/archive.rkt
@@ -50,8 +50,10 @@
     (if (? v) v
         (err))))
 
-(define (archive-extract-path archive-path p)
-  (define ps (explode-path p))
+;; `p` names an entry relative to `base`, which defaults to the root the
+;; archive recorded when it was created. A build that has moved since then
+;; lives under a different root, so callers pass that root as `base`.
+(define (archive-extract-path archive-path p #:base [base #f])
   (define (not-in-archive)
     (error 'archive-extract-path "~e is not in the archive" p))
   (define (bad-archive)
@@ -64,12 +66,10 @@
           (lambda ()
             (define root-string (read/? fport string? bad-archive))
             (define root (string->path root-string))
-            (define roots (explode-path root))
-            (define root-len (length roots))
-            (unless (root-len . <= . (length ps))
+            (define ps-roots (path-prefix-split p (or base root)))
+            (unless ps-roots
               (not-in-archive))
-            (local [(define ps-roots (list-tail ps root-len))
-                    (define root-table-bytes (read/? fport bytes? bad-archive))
+            (local [(define root-table-bytes (read/? fport bytes? bad-archive))
                     (define root-table (bytes->value root-table-bytes hash? bad-archive))
                     (define heap-start (file-position fport))
                     (define (extract-bytes t p)
@@ -99,58 +99,61 @@
           (lambda ()
             (close-input-port fport))))))
 
-(define (archive-extract-file archive-path fp)
-  (define-values (dir? bs) (archive-extract-path archive-path fp))
+(define (archive-extract-file archive-path fp #:base [base #f])
+  (define-values (dir? bs) (archive-extract-path archive-path fp #:base base))
   (if dir?
     (error 'archive-extract-file "~e is not a file" fp)
     bs))
 
-(define (archive-directory-list archive-path fp)
+(define (archive-directory-list archive-path fp #:base [base #f])
   (define (bad-archive)
     (error 'archive-directory-list "~e is not a valid archive" archive-path))
-  (define-values (dir? bs) (archive-extract-path archive-path fp))
+  (define-values (dir? bs) (archive-extract-path archive-path fp #:base base))
   (if dir?
     (for/list ([k (in-hash-keys (bytes->value bs hash? bad-archive))])
       (build-path k))
     (error 'archive-directory-list "~e is not a directory" fp)))
 
-(define (archive-directory-exists? archive-path fp)
+(define (archive-directory-exists? archive-path fp #:base [base #f])
   (define-values (dir? _)
     (with-handlers ([exn:fail? (lambda (x) (values #f #f))])
-      (archive-extract-path archive-path fp)))
+      (archive-extract-path archive-path fp #:base base)))
   dir?)
 
-(define (archive-extract-to archive-file-path archive-inner-path to)
+(define (archive-extract-to archive-file-path archive-inner-path to #:base [base #f])
   (printf "~a " to)
   (cond
-    [(archive-directory-exists? archive-file-path archive-inner-path)
+    [(archive-directory-exists? archive-file-path archive-inner-path #:base base)
      (printf "D\n")
      (make-directory* to)
-     (for ([p (in-list (archive-directory-list archive-file-path archive-inner-path))])
+     (for ([p (in-list (archive-directory-list archive-file-path archive-inner-path
+                                               #:base base))])
        (archive-extract-to archive-file-path
                            (build-path archive-inner-path p)
-                           (build-path to p)))]
+                           (build-path to p)
+                           #:base base))]
     [else
      (printf "F\n")
      (unless (file-exists? to)
        (with-output-to-file to
          #:exists 'error
          (λ ()
-           (write-bytes (archive-extract-file archive-file-path archive-inner-path)))))]))
+           (write-bytes (archive-extract-file archive-file-path archive-inner-path
+                                              #:base base)))))]))
 
 (provide/contract
  [create-archive
   (-> path-string? path-string?
       void)]
  [archive-extract-to
-  (-> path-string? path-string? path-string?
-      void)]
+  (->* (path-string? path-string? path-string?) (#:base (or/c #f path-string?))
+       void)]
  [archive-extract-file
-  (-> path-string? path-string?
-      bytes?)]
+  (->* (path-string? path-string?) (#:base (or/c #f path-string?))
+       bytes?)]
  [archive-directory-list
-  (-> path-string? path-string?
-      (listof path?))]
+  (->* (path-string? path-string?) (#:base (or/c #f path-string?))
+       (listof path?))]
  [archive-directory-exists?
-  (-> path-string? path-string?
-      boolean?)])
+  (->* (path-string? path-string?) (#:base (or/c #f path-string?))
+       boolean?)])
diff --git a/cache.rkt b/cache.rkt
index 751d31f..96d270f 100644
--- a/cache.rkt
+++ b/cache.rkt
@@ -36,22 +36,22 @@
 (require "archive.rkt"
          "dirstruct.rkt")
 
+;; `pth` is relative to where the build lives now, which need not be where
+;; it lived when its archive was created.
 (define (consult-archive pth)
   (define rev (path->revision pth))
-  (define archive-path (revision-archive rev))
   (define file-bytes
-    (archive-extract-file archive-path pth))
+    (archive-extract-file (revision-archive rev) pth #:base (revision-dir rev)))
   (with-input-from-bytes file-bytes read))
 
 (define (consult-archive/directory-list* pth)
   (define rev (path->revision pth))
-  (define archive-path (revision-archive rev))
-  (directory-list->directory-list* (archive-directory-list archive-path pth)))
+  (directory-list->directory-list*
+   (archive-directory-list (revision-archive rev) pth #:base (revision-dir rev))))
 
 (define (consult-archive/directory-exists? pth)
   (define rev (path->revision pth))
-  (define archive-path (revision-archive rev))
-  (archive-directory-exists? archive-path pth))
+  (archive-directory-exists? (revision-archive rev) pth #:base (revision-dir rev)))
 
 (define (cached-directory-list* dir-pth)
   (if (directory-exists? dir-pth)

From 8c79e65aa8fcf3e5b793ad447491413f39fe1d3c Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@iu.edu>
Date: Wed, 23 Sep 2026 15:51:16 -0400
Subject: [PATCH 3/7] Fix revision lookup for builds moved to the extra
 directory

`path->revision` indexed into an exploded path at the length of the
primary build directory. Builds that have aged out live under the extra
build directory, which is one element shorter in production, so the index
landed on "logs" and `string->number` returned #f, breaking the function's
contract. `cached-directory-exists?` caught that exception and reported
the build as absent, so `find-previous-rev` walked backwards one revision
at a time, and every other archive lookup during a render failed the same
way. A page for an archived revision spent about 42 seconds of CPU to
conclude "Not Found"; with this change it renders in about 0.2 seconds.

Because every file page links to "next change" for its revision, those
pages also trapped crawlers: for an archived revision the link redirected
back to the page itself.

Match a root prefix against either build directory instead.
---
 dirstruct.rkt | 36 ++++++++++++++++++++++++++++++++----
 1 file changed, 32 insertions(+), 4 deletions(-)

diff --git a/dirstruct.rkt b/dirstruct.rkt
index 888b16e..dfc4d79 100644
--- a/dirstruct.rkt
+++ b/dirstruct.rkt
@@ -113,11 +113,16 @@
 (define (revision-commit-msg rev)
   (build-path (revision-dir rev) "commit-msg"))
 
+;; A build lives under the primary build directory until it ages out to
+;; the extra one, and the two roots need not have the same depth.
 (define (path->revision pth)
-  (define builds (explode-path (plt-build-directory)))
-  (define builds-len (length builds))
-  (define pths (explode-path pth))
-  (string->number (path->string* (list-ref pths builds-len))))
+  (define (revision-under root)
+    (define below (and root (path-prefix-split pth root)))
+    (and (pair? below)
+         (string->number (path->string* (car below)))))
+  (or (revision-under (plt-build-directory))
+      (revision-under (extra-build-directory))
+      (error 'path->revision "no revision in ~e" pth)))
 
 (define (revision-archive rev)
   (build-path (revision-dir rev) "archive.db"))
@@ -178,3 +183,26 @@
  [revision-archive (exact-nonnegative-integer? . -> . path?)]
  [path->revision (path-string? . -> . exact-nonnegative-integer?)]
  [plt-new-pushes-file (-> path-string?)])
+
+(module+ test
+  (require rackunit)
+
+  (define-syntax-rule (with-roots primary extra body ...)
+    (parameterize ([plt-directory primary] [extra-build-directory extra])
+      body ...))
+
+  ;; The production layout: the extra root is one element shorter.
+  (with-roots "/opt/plt" "/extra/builds"
+    (check-equal? (path->revision "/opt/plt/builds/73400/logs/pkgs/base") 73400)
+    (check-equal? (path->revision "/extra/builds/55389/logs") 55389)
+    (check-equal? (path->revision "/extra/builds/55389/logs/pkgs/base") 55389)
+    (check-exn exn:fail? (lambda () (path->revision "/elsewhere/55389/logs")))
+    (check-exn exn:fail? (lambda () (path->revision "/opt/plt/builds"))))
+
+  ;; An extra root deeper than the primary one.
+  (with-roots "/opt/plt" "/mnt/a/b/c/builds"
+    (check-equal? (path->revision "/mnt/a/b/c/builds/50001/logs") 50001))
+
+  (with-roots "/opt/plt" #f
+    (check-equal? (path->revision "/opt/plt/builds/73400/logs") 73400)
+    (check-exn exn:fail? (lambda () (path->revision "/extra/builds/55389/logs")))))

From 2cdaead6b2aaa0dd761d5a95c8018f60c1380398 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@iu.edu>
Date: Wed, 23 Sep 2026 15:51:31 -0400
Subject: [PATCH 4/7] Repair archives of builds in the extra directory

archive-repair looked up a build's current directory inside its archive,
but the archive names its contents by the directory the build had when
the archive was created. For a build that has moved to the extra build
directory the two differ, and the repair failed. Pass the current
directory as `#:base`.
---
 archive-repair.rkt | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/archive-repair.rkt b/archive-repair.rkt
index 6643b5d..c87fbf2 100644
--- a/archive-repair.rkt
+++ b/archive-repair.rkt
@@ -13,6 +13,7 @@
                 #:args (n) (string->number n)))
 
 (when (file-exists? (revision-archive rev))
-  (archive-extract-to (revision-archive rev) (revision-dir rev) (revision-dir rev))
+  (archive-extract-to (revision-archive rev) (revision-dir rev) (revision-dir rev)
+                      #:base (revision-dir rev))
   (delete-file (revision-archive rev))
   (make-archive rev))

From fc0a82e74e3bc4be2ae778c2a48bc7795cec9c2a Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@iu.edu>
Date: Wed, 23 Sep 2026 15:52:44 -0400
Subject: [PATCH 5/7] Signal a cache miss with its own exception type

render.rkt recognized a cache miss by matching the text of an error
raised in cache.rkt, so rewording that error would silently break the
handlers. Raise `exn:fail:not-cached` for misses in cache.rkt,
archive.rkt and `path->revision`, and test for that type instead.

The handlers that matched "No cache available" now also catch a miss
that `read-cache` raises inside the call they guard. Such a miss used to
escape as an internal error; now the page reports the file or directory
as not found.
---
 archive.rkt    |  5 +++--
 cache.rkt      |  9 +++++----
 dirstruct.rkt  |  7 ++++---
 not-cached.rkt | 29 +++++++++++++++++++++++++++++
 render.rkt     | 22 ++++++++--------------
 5 files changed, 49 insertions(+), 23 deletions(-)
 create mode 100644 not-cached.rkt

diff --git a/archive.rkt b/archive.rkt
index 22ad61c..2b8bbbc 100644
--- a/archive.rkt
+++ b/archive.rkt
@@ -5,7 +5,8 @@
          racket/local
          racket/match
          racket/contract/base
-         "path-utils.rkt")
+         "path-utils.rkt"
+         "not-cached.rkt")
 
 (define (value->bytes v)
   (with-output-to-bytes (lambda () (write v))))
@@ -55,7 +56,7 @@
 ;; lives under a different root, so callers pass that root as `base`.
 (define (archive-extract-path archive-path p #:base [base #f])
   (define (not-in-archive)
-    (error 'archive-extract-path "~e is not in the archive" p))
+    (raise-not-cached "archive-extract-path: ~e is not in the archive" p))
   (define (bad-archive)
     (error 'archive-extract-path "~e is not a valid archive" archive-path))
   (call-with-input-file
diff --git a/cache.rkt b/cache.rkt
index 96d270f..8def9c7 100644
--- a/cache.rkt
+++ b/cache.rkt
@@ -2,7 +2,8 @@
 (require racket/port
          racket/file
          racket/contract/base
-         "path-utils.rkt")
+         "path-utils.rkt"
+         "not-cached.rkt")
 
 ; (symbols 'always 'cache 'no-cache)
 (define cache/file-mode (make-parameter 'cache))
@@ -19,7 +20,7 @@
          ([exn:fail?
            (lambda (x)
              (case mode
-               [(no-cache) (error 'cache/file "No cache available: ~a" pth)]
+               [(no-cache) (raise-not-cached "cache/file: No cache available: ~a" pth)]
                [(cache always)
                 #;(printf "cache/file: running ~S for ~a\n" thnk pth)
                 (recompute!)]))])
@@ -57,7 +58,7 @@
   (if (directory-exists? dir-pth)
       (directory-list* dir-pth)
       (or (with-handlers ([exn:fail? (lambda _ #f)]) (consult-archive/directory-list* dir-pth))
-          (error 'cached-directory-list* "Directory list is not cached: ~e" dir-pth))))
+          (raise-not-cached "cached-directory-list*: Directory list is not cached: ~e" dir-pth))))
 
 (define (cached-directory-exists? dir-pth)
   (if (file-exists? dir-pth)
@@ -69,7 +70,7 @@
   (if (file-exists? pth)
       (file->value pth)
       (or (with-handlers ([exn:fail? (lambda _ #f)]) (consult-archive pth))
-          (error 'read-cache "File is not cached: ~e" pth))))
+          (raise-not-cached "read-cache: File is not cached: ~e" pth))))
 (define (read-cache* pth)
   (with-handlers ([exn:fail? (lambda (x) #f)])
     (read-cache pth)))
diff --git a/dirstruct.rkt b/dirstruct.rkt
index dfc4d79..270cca1 100644
--- a/dirstruct.rkt
+++ b/dirstruct.rkt
@@ -1,7 +1,8 @@
 #lang racket/base
 (require racket/bool
          racket/contract/base
-         "path-utils.rkt")
+         "path-utils.rkt"
+         "not-cached.rkt")
 
 (define number-of-cpus
   (make-parameter 1))
@@ -122,7 +123,7 @@
          (string->number (path->string* (car below)))))
   (or (revision-under (plt-build-directory))
       (revision-under (extra-build-directory))
-      (error 'path->revision "no revision in ~e" pth)))
+      (raise-not-cached "path->revision: no revision in ~e" pth)))
 
 (define (revision-archive rev)
   (build-path (revision-dir rev) "archive.db"))
@@ -196,7 +197,7 @@
     (check-equal? (path->revision "/opt/plt/builds/73400/logs/pkgs/base") 73400)
     (check-equal? (path->revision "/extra/builds/55389/logs") 55389)
     (check-equal? (path->revision "/extra/builds/55389/logs/pkgs/base") 55389)
-    (check-exn exn:fail? (lambda () (path->revision "/elsewhere/55389/logs")))
+    (check-exn exn:fail:not-cached? (lambda () (path->revision "/elsewhere/55389/logs")))
     (check-exn exn:fail? (lambda () (path->revision "/opt/plt/builds"))))
 
   ;; An extra root deeper than the primary one.
diff --git a/not-cached.rkt b/not-cached.rkt
new file mode 100644
index 0000000..59221c8
--- /dev/null
+++ b/not-cached.rkt
@@ -0,0 +1,29 @@
+#lang racket/base
+;; The exception for "this is not cached", as opposed to a bug. Callers
+;; test for it by type, so they do not depend on how another module words
+;; its errors.
+(require racket/contract/base)
+
+(struct exn:fail:not-cached exn:fail ())
+
+(define (raise-not-cached fmt . args)
+  (raise (exn:fail:not-cached (apply format fmt args) (current-continuation-marks))))
+
+;; A lookup legitimately fails when the data is absent: the file is
+;; missing, or the archive does not hold the path.
+(define (not-cached? x)
+  (or (exn:fail:not-cached? x) (exn:fail:filesystem? x)))
+
+(provide (struct-out exn:fail:not-cached))
+(provide/contract [raise-not-cached (->* (string?) () #:rest (listof any/c) none/c)]
+                  [not-cached? (-> any/c boolean?)])
+
+(module+ test
+  (require rackunit)
+
+  (check-exn exn:fail:not-cached? (lambda () (raise-not-cached "~a is gone" "x")))
+  (check-exn #rx"x is gone" (lambda () (raise-not-cached "~a is gone" "x")))
+  (check-true (not-cached? (exn:fail:not-cached "m" (current-continuation-marks))))
+  (check-true (not-cached? (exn:fail:filesystem "m" (current-continuation-marks))))
+  ;; a bug is not a miss, however it is worded
+  (check-false (not-cached? (exn:fail:contract "is not cached" (current-continuation-marks)))))
diff --git a/render.rkt b/render.rkt
index 4de8c82..36a3c46 100644
--- a/render.rkt
+++ b/render.rkt
@@ -14,6 +14,7 @@
          "diff.rkt"
          "list-count.rkt"
          "cache.rkt"
+         "not-cached.rkt"
          (except-in "dirstruct.rkt"
                     revision-trunk-dir)
          "status.rkt"
@@ -1013,8 +1014,7 @@ in.}
                                     (td ([class "author"]) ,committer)))
                              (parameterize ([current-rev rev])
                                (with-handlers 
-                                   ([(lambda (x)
-                                       (regexp-match #rx"No cache available" (exn-message x)))
+                                   ([exn:fail:not-cached?
                                      (lambda (x)
                                        (no-rendering-row))])
                                  ;; XXX One function to generate
@@ -1074,8 +1074,7 @@ in.}
   (define log-dir (revision-log-dir rev))
   (parameterize ([current-rev rev]
                  [previous-rev (find-previous-rev rev)])
-    (with-handlers ([(lambda (x)
-                       (regexp-match #rx"No cache available" (exn-message x)))
+    (with-handlers ([exn:fail:not-cached?
                      (lambda (x)
                        (eprintf "show-revision: No cache for rev ~a: ~a\n" rev (exn-message x))
                        (rev-not-found log-dir rev))])
@@ -1140,8 +1139,7 @@ in.}
         (define log-pth
           (apply build-path log-dir path-to-file))
         (match 
-            (with-handlers ([(lambda (x)
-                               (regexp-match #rx"No cache available" (exn-message x)))
+            (with-handlers ([exn:fail:not-cached?
                              (lambda (x)
                                #f)])
               (log-rendering log-pth))
@@ -1161,15 +1159,13 @@ in.}
     (if (member "" path-to-file)
         (local [(define dir-pth
                   (apply build-path log-dir (all-but-last path-to-file)))]
-          (with-handlers ([(lambda (x)
-                             (regexp-match #rx"No cache available" (exn-message x)))
+          (with-handlers ([exn:fail:not-cached?
                            (lambda (x)
                              (dir-not-found dir-pth))])
             (render-logs/dir dir-pth)))
         (local [(define file-pth
                   (apply build-path log-dir path-to-file))]
-          (with-handlers ([(lambda (x)
-                             (regexp-match #rx"No cache available" (exn-message x)))
+          (with-handlers ([exn:fail:not-cached?
                            (lambda (x)
                              (file-not-found file-pth))])
             (render-log file-pth))))))
@@ -1302,16 +1298,14 @@ in.}
 
 (define (show-diff req r1 r2 f)
   (define f1 (apply build-path (revision-log-dir r1) f))
-  (with-handlers ([(lambda (x)
-                     (regexp-match #rx"File is not cached" (exn-message x)))
+  (with-handlers ([exn:fail:not-cached?
                    (lambda (x)
                      ;; XXX Make a little nicer
                      (parameterize ([current-rev r1])
                        (file-not-found f1)))])
     (define l1 (status-output-log (read-cache f1)))
     (define f2 (apply build-path (revision-log-dir r2) f))
-    (with-handlers ([(lambda (x)
-                       (regexp-match #rx"File is not cached" (exn-message x)))
+    (with-handlers ([exn:fail:not-cached?
                      (lambda (x)
                        ;; XXX Make a little nicer
                        (parameterize ([current-rev r2])

From 4f572e26ef45e0530711b6742520f470f416e503 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@iu.edu>
Date: Wed, 23 Sep 2026 15:53:47 -0400
Subject: [PATCH 6/7] Report unexpected exceptions that the cache lookups
 swallow

The cache lookups caught every `exn:fail?` and returned "not cached", so
the contract violation that `path->revision` raised for every archived
build looked like an ordinary miss for months. Add `swallow` to
notify.rkt: it returns a fallback as before, but it logs a `drdr`
warning for any exception its caller has not declared expected. The
renderer's service unit sets PLTSTDERR=warning, so these warnings reach
its journal.

Use it in the cache lookups and in `archive-directory-exists?`, where a
missing file or a missing archive entry stays quiet. `read-cache*` now
also reports a corrupt cache file, which `file->value` rejects.
---
 archive.rkt |  8 +++++--
 cache.rkt   | 46 +++++++++++++++++++++++++++++++-------
 notify.rkt  | 64 +++++++++++++++++++++++++++++++++++++++++++++++++++--
 3 files changed, 106 insertions(+), 12 deletions(-)

diff --git a/archive.rkt b/archive.rkt
index 2b8bbbc..f21baf8 100644
--- a/archive.rkt
+++ b/archive.rkt
@@ -6,6 +6,7 @@
          racket/match
          racket/contract/base
          "path-utils.rkt"
+         "notify.rkt"
          "not-cached.rkt")
 
 (define (value->bytes v)
@@ -117,8 +118,11 @@
 
 (define (archive-directory-exists? archive-path fp #:base [base #f])
   (define-values (dir? _)
-    (with-handlers ([exn:fail? (lambda (x) (values #f #f))])
-      (archive-extract-path archive-path fp #:base base)))
+    ;; a missing archive or entry means "no"; a malformed archive is a bug
+    (swallow 'archive-directory-exists? fp
+             (lambda () (archive-extract-path archive-path fp #:base base))
+             #:expected? not-cached?
+             #:on-fail (lambda () (values #f #f))))
   dir?)
 
 (define (archive-extract-to archive-file-path archive-inner-path to #:base [base #f])
diff --git a/cache.rkt b/cache.rkt
index 8def9c7..0847e5f 100644
--- a/cache.rkt
+++ b/cache.rkt
@@ -35,7 +35,13 @@
   (void))
 
 (require "archive.rkt"
-         "dirstruct.rkt")
+         "dirstruct.rkt"
+         "notify.rkt")
+
+;; A lookup whose data is absent is an ordinary miss; anything else, such
+;; as a contract violation or a malformed archive, is a bug to report.
+(define (miss-on-failure who pth thunk)
+  (swallow who pth thunk #:expected? not-cached?))
 
 ;; `pth` is relative to where the build lives now, which need not be where
 ;; it lived when its archive was created.
@@ -57,28 +63,31 @@
 (define (cached-directory-list* dir-pth)
   (if (directory-exists? dir-pth)
       (directory-list* dir-pth)
-      (or (with-handlers ([exn:fail? (lambda _ #f)]) (consult-archive/directory-list* dir-pth))
+      (or (miss-on-failure 'cached-directory-list* dir-pth
+                           (lambda () (consult-archive/directory-list* dir-pth)))
           (raise-not-cached "cached-directory-list*: Directory list is not cached: ~e" dir-pth))))
 
 (define (cached-directory-exists? dir-pth)
   (if (file-exists? dir-pth)
       #f
       (or (directory-exists? dir-pth)
-          (with-handlers ([exn:fail? (lambda _ #f)]) (consult-archive/directory-exists? dir-pth)))))
+          (miss-on-failure 'cached-directory-exists? dir-pth
+                           (lambda () (consult-archive/directory-exists? dir-pth))))))
 
 (define (read-cache pth)
   (if (file-exists? pth)
       (file->value pth)
-      (or (with-handlers ([exn:fail? (lambda _ #f)]) (consult-archive pth))
+      (or (miss-on-failure 'read-cache pth (lambda () (consult-archive pth)))
           (raise-not-cached "read-cache: File is not cached: ~e" pth))))
 (define (read-cache* pth)
-  (with-handlers ([exn:fail? (lambda (x) #f)])
-    (read-cache pth)))
+  ;; also reports a corrupt cache file, which `file->value` rejects
+  (miss-on-failure 'read-cache* pth (lambda () (read-cache pth))))
 (define (write-cache! pth v)
   (write-to-file* v pth))
 (define (delete-cache! pth)
-  (with-handlers ([exn:fail? void])
-    (delete-file pth)))
+  (swallow 'delete-cache! pth (lambda () (delete-file pth))
+           #:expected? exn:fail:filesystem?)
+  (void))
 
 (provide/contract
  [cache/file-mode (parameter/c (symbols 'always 'cache 'no-cache))]
@@ -90,3 +99,24 @@
  [read-cache* (path-string? . -> . any/c)]
  [write-cache! (path-string? any/c . -> . void)]
  [delete-cache! (path-string? . -> . void)])
+
+(module+ test
+  (require rackunit
+           (submod "notify.rkt" test-support))
+
+  (define (warnings-for thunk)
+    (warnings-during (lambda () (check-false (miss-on-failure 'test "/x" thunk)))))
+
+  ;; ordinary misses are quiet
+  (check-equal? (warnings-for (lambda () (call-with-input-file "/no/such/file" read))) '())
+  (check-equal? (warnings-for (lambda () (raise-not-cached "~e is not in the archive" "/x")))
+                '())
+
+  ;; a bug is reported however it is worded, including the contract
+  ;; violation `path->revision` used to raise for every archived build
+  (check-equal? (length (warnings-for (lambda () (error 'oops "is not in the archive")))) 1)
+  (check-equal? (length (warnings-for
+                         (lambda ()
+                           (raise (exn:fail:contract "path->revision: broke its own contract"
+                                                     (current-continuation-marks))))))
+                1))
diff --git a/notify.rkt b/notify.rkt
index bba02f0..dd74d25 100644
--- a/notify.rkt
+++ b/notify.rkt
@@ -10,9 +10,69 @@
   (parameterize ([date-display-format 'iso-8601])
     (date->string (seconds->date secs) #t)))
 
+(define-logger drdr)
+
+;; Run `thunk`, and return `(on-fail)` if it raises. A handler that
+;; discards every exception makes a bug look like the ordinary case its
+;; fallback stands for, so log each exception that `expected?` rejects.
+(define (swallow who context thunk
+                 #:expected? [expected? (lambda (x) #f)]
+                 #:on-fail [on-fail (lambda () #f)])
+  (with-handlers ([exn:fail?
+                   (lambda (x)
+                     (unless (expected? x)
+                       (log-drdr-warning "~a: swallowed exception for ~e: ~a"
+                                         who context (exn-message x)))
+                     (on-fail))])
+    (thunk)))
+
 (provide/contract
  [seconds->string (-> number? string?)]
- [notify! ((string?) () #:rest (listof any/c) . ->* . void)])
+ [notify! ((string?) () #:rest (listof any/c) . ->* . void)]
+ [swallow (->* (any/c any/c (-> any))
+               (#:expected? (-> exn:fail? boolean?) #:on-fail (-> any))
+               any)])
+
+(module test-support racket/base
+  (require racket/logging)
+  (provide warnings-during)
+  ;; the `drdr` warnings logged while `thunk` runs
+  (define (warnings-during thunk)
+    (define msgs '())
+    (with-intercepted-logging
+      (lambda (l) (set! msgs (cons (vector-ref l 1) msgs)))
+      thunk
+      'warning 'drdr)
+    (reverse msgs)))
 
 (module+ test
-  (seconds->string (current-seconds)))
+  (require rackunit
+           (submod ".." test-support))
+
+  (seconds->string (current-seconds))
+
+  (check-equal? (swallow 'test "ctx" (lambda () 'ok)) 'ok)
+
+  ;; an unexpected failure is logged, and the fallback returned
+  (let ([msgs (warnings-during
+               (lambda ()
+                 (check-equal? (swallow 'test "ctx"
+                                        (lambda () (error 'boom "went wrong"))
+                                        #:on-fail (lambda () 'fallback))
+                               'fallback)))])
+    (check-equal? (length msgs) 1)
+    (check-regexp-match #rx"test: swallowed exception for \"ctx\": boom: went wrong"
+                        (car msgs)))
+
+  ;; an expected failure is not
+  (check-equal? (warnings-during
+                 (lambda ()
+                   (swallow 'test "ctx"
+                            (lambda () (raise (exn:fail:filesystem
+                                               "gone" (current-continuation-marks))))
+                            #:expected? exn:fail:filesystem?)))
+                '())
+
+  ;; only `exn:fail?` is caught
+  (check-exn (lambda (x) (eq? x 'not-a-failure))
+             (lambda () (swallow 'test "ctx" (lambda () (raise 'not-a-failure))))))

From ea3b3c68cd52006fd561510cb25d3cf9ace21316 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@iu.edu>
Date: Wed, 23 Sep 2026 15:55:26 -0400
Subject: [PATCH 7/7] Report unexpected exceptions swallowed outside the cache

Apply `swallow` where DrDr substitutes a default for a failed lookup:
analyze's committer, diff, changed? and commit-author fallbacks,
gather-logs, `safely-delete-directory`, `check-xvfb-info`, and render's
build timestamps and previous-revision comparison. A failure in
`check-xvfb-info`, for example, would silently run GUI tests without
Xvfb.

The committer lookup now calls `read-cache` rather than `read-cache*`.
The latter turns a miss into #f, which then breaks `scm-commit-author`'s
contract and would be reported as a bug instead of as the missing commit
message it is.
---
 analyze.rkt     | 50 ++++++++++++++++++++++++++++---------------------
 gather-logs.rkt | 10 +++++++---
 path-utils.rkt  |  8 +++++---
 plt-build.rkt   | 25 +++++++++++++------------
 render.rkt      | 33 +++++++++++++++++++-------------
 5 files changed, 74 insertions(+), 52 deletions(-)

diff --git a/analyze.rkt b/analyze.rkt
index 5a8ba0f..72c8087 100644
--- a/analyze.rkt
+++ b/analyze.rkt
@@ -10,6 +10,7 @@
          "list-count.rkt"
          "notify.rkt"
          "cache.rkt"
+         "not-cached.rkt"
          "dirstruct.rkt"
          "status.rkt"
          "metadata.rkt"
@@ -147,14 +148,19 @@
         ["nobody" "drdr-nobody"]
         [x x])))
   (define committer
-    (with-handlers ([exn:fail? (lambda (x) #f)])
-      (scm-commit-author 
-       (read-cache*
-        (revision-commit-msg cur-rev)))))
+    (swallow 'notify/committer cur-rev
+             #:expected? not-cached?
+             (lambda ()
+               (scm-commit-author 
+                (read-cache
+                 (revision-commit-msg cur-rev))))))
   (define diff
-    (with-handlers ([exn:fail? (lambda (x) #t)])
-      (define old (rev->responsible-ht (previous-rev)))
-      (responsible-ht-difference old responsible-ht)))
+    (swallow 'notify/diff (previous-rev)
+             #:expected? not-cached?
+             #:on-fail (lambda () #t)
+             (lambda ()
+               (define old (rev->responsible-ht (previous-rev)))
+               (responsible-ht-difference old responsible-ht))))
   (define include-committer?
     (and ; The committer can be found
      committer 
@@ -308,16 +314,16 @@
             (define changed?
               (if (and (previous-rev)
                        (not random?))
-                  (with-handlers ([exn:fail? 
-                                   ;; This #f means that new files are
-                                   ;; NOT considered changed
-                                   (lambda (x) #f)])
-                    (define prev-log-pth
-                      ((rebase-path (revision-log-dir (current-rev)) 
-                                    (revision-log-dir (previous-rev)))
-                       log-pth))
-                    (log-different? output-log
-                                    (status-output-log (read-cache prev-log-pth))))
+                  ;; The #f fallback means that new files are NOT considered changed.
+                  (swallow 'analyze/changed? log-pth
+                           #:expected? not-cached?
+                           (lambda ()
+                             (define prev-log-pth
+                               ((rebase-path (revision-log-dir (current-rev)) 
+                                             (revision-log-dir (previous-rev)))
+                                log-pth))
+                             (log-different? output-log
+                                             (status-output-log (read-cache prev-log-pth)))))
                   #f))
             (define responsible 
               (or (calculate-responsible output-log)
@@ -385,10 +391,12 @@
                  
                  (or
                   (and committer? 
-                       (with-handlers ([exn:fail? (lambda (x) #f)])
-                         (scm-commit-author
-                          (read-cache 
-                           (revision-commit-msg (current-rev))))))
+                       (swallow 'analyze/commit-author (current-rev)
+                                #:expected? not-cached?
+                                (lambda ()
+                                  (scm-commit-author
+                                   (read-cache 
+                                    (revision-commit-msg (current-rev)))))))
                   "")
                  
                  empty
diff --git a/gather-logs.rkt b/gather-logs.rkt
index 50fde24..c754d8e 100644
--- a/gather-logs.rkt
+++ b/gather-logs.rkt
@@ -2,6 +2,8 @@
 (require racket/match
          "config.rkt"
          "cache.rkt"
+         "not-cached.rkt"
+         "notify.rkt"
          "replay.rkt"
          "status.rkt")
 
@@ -27,9 +29,11 @@
     (for ([rev (in-range start (add1 end))])
       (printf " ~a" rev) (flush-output)
       (define v
-        (with-handlers ([exn:fail? (λ (x) #f)])
-          (define p (format "/opt/plt/builds/~a/logs/~a" rev pth))
-          (read-cache p)))
+        (swallow 'gather-logs rev
+                 #:expected? not-cached?
+                 (lambda ()
+                   (define p (format "/opt/plt/builds/~a/logs/~a" rev pth))
+                   (read-cache p))))
       (with-output-to-file (build-path the-dir (format "~a.log" rev))
         (λ ()
           (match v
diff --git a/path-utils.rkt b/path-utils.rkt
index 3d111b6..7ee71f4 100644
--- a/path-utils.rkt
+++ b/path-utils.rkt
@@ -2,7 +2,8 @@
 (require racket/list
          racket/path
          racket/contract/base
-         racket/file)
+         racket/file
+         "notify.rkt")
 
 (define current-temporary-directory
   (make-parameter #f))
@@ -21,8 +22,9 @@
   (directory-list->directory-list* (directory-list pth)))
 
 (define (safely-delete-directory pth)
-  (with-handlers ([exn:fail? (lambda (x) (void))])
-    (delete-directory/files pth)))
+  (swallow 'safely-delete-directory pth (lambda () (delete-directory/files pth))
+           #:expected? exn:fail:filesystem?)
+  (void))
 
 (define (make-parent-directory pth)  
   (define pth-dir (path-only pth))
diff --git a/plt-build.rkt b/plt-build.rkt
index 5a1c388..39eb8de 100644
--- a/plt-build.rkt
+++ b/plt-build.rkt
@@ -29,18 +29,19 @@
   (define ndir (normalize-info-path dir))
   (unless (hash-ref xvfb-info-done ndir #f)
     (hash-set! xvfb-info-done ndir #t)
-    (with-handlers ([exn:fail? (lambda (_) (void))])
-      (define info (get-info/full dir))
-      (when info
-        (define v (info 'test-xvfb-paths (lambda () '())))
-        (when (list? v)
-          (for ([i (in-list v)])
-            (when (path-string? i)
-              (define p (normalize-info-path (path->complete-path i dir)))
-              (define dp (if (directory-exists? p)
-                             (path->directory-path p)
-                             p))
-              (hash-set! xvfb-paths dp #t))))))))
+    (swallow 'check-xvfb-info dir
+             (lambda ()
+               (define info (get-info/full dir))
+               (when info
+                 (define v (info 'test-xvfb-paths (lambda () '())))
+                 (when (list? v)
+                   (for ([i (in-list v)])
+                     (when (path-string? i)
+                       (define p (normalize-info-path (path->complete-path i dir)))
+                       (define dp (if (directory-exists? p)
+                                      (path->directory-path p)
+                                      p))
+                       (hash-set! xvfb-paths dp #t)))))))))
 
 (define (path-needs-xvfb? pth trunk-dir)
   (define-values (base name dir?) (split-path pth))
diff --git a/render.rkt b/render.rkt
index 36a3c46..53a000e 100644
--- a/render.rkt
+++ b/render.rkt
@@ -15,6 +15,7 @@
          "list-count.rkt"
          "cache.rkt"
          "not-cached.rkt"
+         "notify.rkt"
          (except-in "dirstruct.rkt"
                     revision-trunk-dir)
          "status.rkt"
@@ -188,11 +189,14 @@
 (define (format-commit-msg)
   (define pth (revision-commit-msg (current-rev)))
   (define (timestamp pth)
-    (with-handlers ([exn:fail? (lambda (x) "")])
-      (define secs (read-cache
-                    (build-path (revision-dir (current-rev)) pth)))
-      (define utc-time-str (date->string (seconds->date secs) #t))
-      (make-timestamp-span utc-time-str secs)))
+    (swallow 'render/timestamp pth
+             #:expected? not-cached?
+             #:on-fail (lambda () "")
+             (lambda ()
+               (define secs (read-cache
+                             (build-path (revision-dir (current-rev)) pth)))
+               (define utc-time-str (date->string (seconds->date secs) #t))
+               (make-timestamp-span utc-time-str secs))))
   (define bdate/s (timestamp "checkout-done"))
   (define bdate/e (timestamp "integrated"))
   (match (read-cache* pth)
@@ -606,14 +610,17 @@
                    ,(local [(define responsible->problems
                               (rendering->responsible-ht (current-rev) pth-rendering))
                             (define last-responsible->problems
-                              (with-handlers ([exn:fail? (lambda (x) (make-hash))])
-                                (define prev-dir-pth ((rebase-path (revision-log-dir (current-rev))
-                                                                   (revision-log-dir (previous-rev)))
-                                                      dir-pth))
-                                (define previous-pth-rendering
-                                  (parameterize ([current-rev (previous-rev)])
-                                    (dir-rendering prev-dir-pth)))
-                                (rendering->responsible-ht (previous-rev) previous-pth-rendering)))
+                              (swallow 'last-responsible->problems (previous-rev)
+                                       #:expected? not-cached?
+                                       #:on-fail make-hash
+                                       (lambda ()
+                                         (define prev-dir-pth ((rebase-path (revision-log-dir (current-rev))
+                                                                            (revision-log-dir (previous-rev)))
+                                                               dir-pth))
+                                         (define previous-pth-rendering
+                                           (parameterize ([current-rev (previous-rev)])
+                                             (dir-rendering prev-dir-pth)))
+                                         (rendering->responsible-ht (previous-rev) previous-pth-rendering))))
                             (define new-responsible->problems
                               (responsible-ht-difference last-responsible->problems responsible->problems))