From 870286d860bf680faa6a376560be592c35b20a04 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 23 Sep 2026 15:49:51 -0400 Subject: [PATCH 1/4] 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 Date: Wed, 23 Sep 2026 15:50:47 -0400 Subject: [PATCH 2/4] 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 Date: Wed, 23 Sep 2026 15:51:16 -0400 Subject: [PATCH 3/4] 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 Date: Wed, 23 Sep 2026 15:51:31 -0400 Subject: [PATCH 4/4] 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))