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/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..f21baf8 100644 --- a/archive.rkt +++ b/archive.rkt @@ -5,7 +5,9 @@ racket/local racket/match racket/contract/base - "path-utils.rkt") + "path-utils.rkt" + "notify.rkt" + "not-cached.rkt") (define (value->bytes v) (with-output-to-bytes (lambda () (write v)))) @@ -50,10 +52,12 @@ (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)) + (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 @@ -64,12 +68,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 +101,64 @@ (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))) + ;; 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) +(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..0847e5f 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!)]))]) @@ -34,50 +35,59 @@ (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. (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) (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)))) + (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)) - (error 'read-cache "File is not cached: ~e" 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))] @@ -89,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/dirstruct.rkt b/dirstruct.rkt index 888b16e..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)) @@ -113,11 +114,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)) + (raise-not-cached "path->revision: no revision in ~e" pth))) (define (revision-archive rev) (build-path (revision-dir rev) "archive.db")) @@ -178,3 +184,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: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. + (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/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/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/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)))))) diff --git a/path-utils.rkt b/path-utils.rkt index 55ad0bc..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)) @@ -46,7 +48,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 +69,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"))) 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 4de8c82..53a000e 100644 --- a/render.rkt +++ b/render.rkt @@ -14,6 +14,8 @@ "diff.rkt" "list-count.rkt" "cache.rkt" + "not-cached.rkt" + "notify.rkt" (except-in "dirstruct.rkt" revision-trunk-dir) "status.rkt" @@ -187,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) @@ -605,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)) @@ -1013,8 +1021,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 +1081,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 +1146,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 +1166,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 +1305,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])