Fix revision lookup for builds moved to the extra build directory

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))

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"))

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?)])

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)

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")))))

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")))