Report unexpected exceptions that DrDr swallows

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

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

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

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