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