From cf47a199bebff462912e044f073d2d1dc4b6eeeb Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 28 Sep 2026 12:31:25 -0400 Subject: [PATCH] Accept only revisions with builds in URLs, and bound revision walks `find-previous-rev` counted down one number at a time until it found a revision with logs, and the URL rules took any integer as a revision. A request whose revision was a Unix timestamp, such as /1489401258/..., therefore walked about 1.5 billion numbers, checking each one's directories and archive; four such requests kept the renderer at a full core for days, slowing every build by about 5%. The builds below 70000 cannot change, so write down what the renderer can show: every push from 50000 has a build with logs (in a "logs" directory or an archive), except for 13 missing ones. Newer pushes are checked against the build directories. A new URL argument, `known-rev-arg`, matches only a revision with a build, so any other number matches no rule and gets a 404, and `find-previous-rev` stops at the oldest build and answers from the static history without touching the filesystem. The rendering tests used revisions 100-104, which the static history rules out, so they now use 70100-70104. --- render.rkt | 93 ++++++++++++++++++++++++++++++++++++++++------ test-rendering.rkt | 67 ++++++++++++++++++--------------- 2 files changed, 119 insertions(+), 41 deletions(-) diff --git a/render.rkt b/render.rkt index 991e8e3..52c9a8d 100644 --- a/render.rkt +++ b/render.rkt @@ -939,6 +939,7 @@ in.} (require web-server/servlet-env web-server/http web-server/dispatch + web-server/dispatch/extend "scm.rkt") (define how-many-revs 45) (define (show-revisions req) @@ -1129,13 +1130,36 @@ in.} "Push #" ,(number->string (current-rev)) " does not exist or has not been tested.") ,(footer)))))) +;; What builds the renderer can show below `static-history-end` cannot +;; change, so it is written down here: every push from `oldest-build` on +;; has a build, with logs in a "logs" directory or an archive, except +;; `missing-builds` (57109-57119 are from the April 2021 disk trouble). +;; Older pushes, 20000-49999, are kept only in tarballs under +;; /opt/plt/archived (see s3upload.sh), which the renderer does not read. +;; Newer pushes are checked against the build directories, so a number +;; too large to be a push, such as a timestamp, has no build. +(define oldest-build 50000) +(define static-history-end 70000) +(define missing-builds + '(56034 56035 + 57109 57110 57111 57112 57113 57114 57115 57116 57117 57118 57119)) + +(define (known-revision? rev) + (cond + [(rev . < . oldest-build) #f] + [(rev . < . static-history-end) (not (memv rev missing-builds))] + [else (directory-exists? (revision-dir rev))])) + +;; The newest revision below `this-rev` that has logs, where `this-rev` is +;; a known revision or one past it (define (find-previous-rev this-rev) - (if (zero? this-rev) - #f - (local [(define maybe (sub1 this-rev))] - (if (cached-directory-exists? (revision-log-dir maybe)) - maybe - (find-previous-rev maybe))))) + (let loop ([rev (sub1 this-rev)]) + (cond + [(rev . < . oldest-build) #f] + [(rev . < . static-history-end) + (if (known-revision? rev) rev (loop (sub1 rev)))] + [(cached-directory-exists? (revision-log-dir rev)) rev] + [else (loop (sub1 rev))]))) (define (show-file/prev-change req rev path-to-file) (show-file/change -1 rev path-to-file)) @@ -1355,19 +1379,33 @@ in.} `(tr (td ([colspan "2"]) ,(render-event e)))])))) ,(footer)))))))) +;; A revision in a URL comes from outside, so it must name a build: any +;; other number, such as a timestamp, matches no rule. Otherwise a handler +;; could walk from it, as `find-previous-rev` does. +(define (string->known-revision s) + (define rev (string->number s)) + (unless (and (exact-nonnegative-integer? rev) (known-revision? rev)) + (error 'string->known-revision "not a revision with a build: ~e" s)) + rev) +(define-coercion-match-expander known-rev-in/m + (make-coerce-safe? string->known-revision) string->known-revision) +(define-coercion-match-expander known-rev-out/m + exact-nonnegative-integer? number->string) +(define-bidi-match-expander known-rev-arg known-rev-in/m known-rev-out/m) + (define-values (top-dispatch top-url) (dispatch-rules [("help") show-help] [("") show-revisions] - [("diff" (integer-arg) (integer-arg) (string-arg) ...) show-diff] + [("diff" (known-rev-arg) (known-rev-arg) (string-arg) ...) show-diff] [("file-history" (string-arg) ...) show-file-history] [("json" "timing" (string-arg) ...) json-timing] - [("previous-change" (integer-arg) (string-arg) ...) show-file/prev-change] - [("next-change" (integer-arg) (string-arg) ...) show-file/next-change] + [("previous-change" (known-rev-arg) (string-arg) ...) show-file/prev-change] + [("next-change" (known-rev-arg) (string-arg) ...) show-file/next-change] [("current" "") show-revision/current] [("current" (string-arg) ...) show-file/current] - [((integer-arg) "") show-revision] - [((integer-arg) (string-arg) ...) show-file])) + [((known-rev-arg) "") show-revision] + [((known-rev-arg) (string-arg) ...) show-file])) (require (only-in net/url url->string)) (define (log-dispatch req) @@ -1413,7 +1451,38 @@ in.} #:extra-files-paths (list static))) (module+ test - (require rackunit) + (require rackunit + racket/file) + + ;; Historical builds are known statically, newer ones from the build + ;; directory, so a number that is not a push, such as a timestamp, is + ;; rejected at once; walking to the previous revision stops at the + ;; oldest build + (let () + (define primary (make-temporary-directory)) + (define (make-build! rev #:logs? [logs? #t]) + (make-directory* (build-path primary "builds" (number->string rev) + (if logs? "logs" "analyze")))) + (make-build! 70000) + (make-build! 70001 #:logs? #f) + (make-build! 70002) + (parameterize ([plt-directory primary] [extra-build-directory #f]) + (check-true (known-revision? 50000)) + (check-true (known-revision? 69999)) + (check-true (known-revision? 70001)) + (check-false (known-revision? 49999)) + (check-false (known-revision? 56034)) + (check-false (known-revision? 70003)) + (check-false (known-revision? 1489401258)) + (check-equal? (find-previous-rev 70002) 70000) + (check-equal? (find-previous-rev 70000) 69999) + (check-equal? (find-previous-rev 56036) 56033) + (check-equal? (find-previous-rev 57120) 57108) + (check-false (find-previous-rev 50000)) + (check-equal? (match "70002" [(known-rev-in/m r) r] [_ #f]) 70002) + (check-false (match "1489401258" [(known-rev-in/m r) r] [_ #f])) + (check-false (match "x" [(known-rev-in/m r) r] [_ #f]))) + (delete-directory/files primary)) ;; Test the make-timestamp-span helper function (check-equal? (make-timestamp-span "2023-12-25 10:30:45" 1703505045) diff --git a/test-rendering.rkt b/test-rendering.rkt index e394ce4..8dd3e49 100644 --- a/test-rendering.rkt +++ b/test-rendering.rkt @@ -12,6 +12,7 @@ web-server/test web-server/http web-server/servlet-dispatch + (only-in web-server/dispatchers/dispatch exn:dispatcher?) "dirstruct.rkt" "rendering.rkt" "status.rkt" @@ -94,10 +95,10 @@ (make-directory* (plt-data-directory)) ;; Use 'cache mode during setup so analyze-logs can write cache files (cache/file-mode 'cache) - (make-test-revision 100 #:status 'success #:duration-ms 3200 #:author "alice") - (make-test-revision 101 #:status 'success #:duration-ms 3400 #:changed? #t #:author "bob") - (make-test-revision 102 #:status 'failure #:duration-ms 4100 #:changed? #t #:author "alice") - (make-test-revision 103 #:status 'timeout #:duration-ms 90000 #:changed? #t #:author "bob") + (make-test-revision 70100 #:status 'success #:duration-ms 3200 #:author "alice") + (make-test-revision 70101 #:status 'success #:duration-ms 3400 #:changed? #t #:author "bob") + (make-test-revision 70102 #:status 'failure #:duration-ms 4100 #:changed? #t #:author "alice") + (make-test-revision 70103 #:status 'timeout #:duration-ms 90000 #:changed? #t #:author "bob") ;; Switch to 'no-cache for tests, matching the web server's mode (cache/file-mode 'no-cache)) thunk @@ -135,25 +136,25 @@ (define resp (dispatch-request "http://localhost/")) (check-equal? (response-code resp) 200) (define body (response-body resp)) - (check-regexp-match #rx"103" body) - (check-regexp-match #rx"102" body) - (check-regexp-match #rx"101" body) - (check-regexp-match #rx"100" body) + (check-regexp-match #rx"70103" body) + (check-regexp-match #rx"70102" body) + (check-regexp-match #rx"70101" body) + (check-regexp-match #rx"70100" body) (check-regexp-match #rx"alice" body) (check-regexp-match #rx"bob" body)))) (test-case "revision page shows directory listing" (call-with-test-data (lambda () - (define resp (dispatch-request "http://localhost/101/")) + (define resp (dispatch-request "http://localhost/70101/")) (check-equal? (response-code resp) 200) (define body (response-body resp)) (check-regexp-match #rx"bob" body) - (check-regexp-match #rx"Test commit for rev 101" body)))) + (check-regexp-match #rx"Test commit for rev 70101" body)))) (test-case "file result page shows test output" (call-with-test-data (lambda () (define resp - (dispatch-request (format "http://localhost/101/~a" test-file-path))) + (dispatch-request (format "http://localhost/70101/~a" test-file-path))) (check-equal? (response-code resp) 200) (define body (response-body resp)) (check-regexp-match #rx"all tests passed" body) @@ -163,7 +164,7 @@ (test-case "failure file result shows stderr" (call-with-test-data (lambda () (define resp - (dispatch-request (format "http://localhost/102/~a" test-file-path))) + (dispatch-request (format "http://localhost/70102/~a" test-file-path))) (check-equal? (response-code resp) 200) (define body (response-body resp)) (check-regexp-match #rx"FAILURE" body) @@ -172,7 +173,7 @@ (test-case "timeout file result shows timeout" (call-with-test-data (lambda () (define resp - (dispatch-request (format "http://localhost/103/~a" test-file-path))) + (dispatch-request (format "http://localhost/70103/~a" test-file-path))) (check-equal? (response-code resp) 200) (define body (response-body resp)) (check-regexp-match #rx"timeout exceeded" body) @@ -185,9 +186,17 @@ (define body (response-body resp)) (check-regexp-match #rx"What is DrDr" body)))) + (test-case "a revision that names no build matches no rule" + (call-with-test-data + (lambda () + (for ([url (in-list '("http://localhost/1489401258/" + "http://localhost/1489401258/pkgs/x.rkt" + "http://localhost/previous-change/1489401258/pkgs/x.rkt"))]) + (check-exn exn:dispatcher? (lambda () (dispatch-request url))))))) + (test-case "nonexistent file returns not found message" (call-with-test-data (lambda () - (define resp (dispatch-request "http://localhost/101/no/such/file.rkt")) + (define resp (dispatch-request "http://localhost/70101/no/such/file.rkt")) (check-equal? (response-code resp) 200) (define body (response-body resp)) (check-regexp-match #rx"does not exist" body)))) @@ -200,10 +209,10 @@ (check-equal? (response-code resp) 200) (define body (response-body resp)) (check-regexp-match #rx"File History" body) - (check-regexp-match #rx"100" body) - (check-regexp-match #rx"101" body) - (check-regexp-match #rx"102" body) - (check-regexp-match #rx"103" body)))) + (check-regexp-match #rx"70100" body) + (check-regexp-match #rx"70101" body) + (check-regexp-match #rx"70102" body) + (check-regexp-match #rx"70103" body)))) (test-case "file history page shows status for each revision" (call-with-test-data (lambda () @@ -218,7 +227,7 @@ (test-case "file history page shows stderr status for exit-0 with stderr" (call-with-test-data (lambda () (parameterize ([cache/file-mode 'cache]) - (make-test-revision 104 #:status 'stderr #:author "carol")) + (make-test-revision 70104 #:status 'stderr #:author "carol")) (define resp (dispatch-request (format "http://localhost/file-history/~a" test-file-path))) @@ -254,22 +263,22 @@ (test-case "file history page shows pending for incomplete revisions" (call-with-test-data (lambda () ;; Create a revision directory with no "analyzed" marker - (make-directory* (revision-log-dir 104)) - (make-directory* (revision-analyze-dir 104)) + (make-directory* (revision-log-dir 70104)) + (make-directory* (revision-analyze-dir 70104)) (define resp (dispatch-request (format "http://localhost/file-history/~a" test-file-path))) (define body (response-body resp)) - (check-regexp-match #rx"104" body) + (check-regexp-match #rx"70104" body) (check-regexp-match #rx"Pending" body) - ;; Should NOT show "Missing" for rev 104 + ;; Should NOT show "Missing" for rev 70104 ;; (Missing should only appear for completed rev 99 if present) ))) (test-case "file result page links to file history" (call-with-test-data (lambda () (define resp - (dispatch-request (format "http://localhost/101/~a" test-file-path))) + (dispatch-request (format "http://localhost/70101/~a" test-file-path))) (define body (response-body resp)) (check-regexp-match #rx"file-history" body) (check-regexp-match #rx"All results for this file" body)))) @@ -280,13 +289,13 @@ ;; marker files, which fails after archiving deletes them. The fix is to ;; use read-cache* which falls through to the archive. (call-with-test-data (lambda () - ;; Archive revs 101, 102, 103 (101 is success, - ;; 102 is failure, 103 is timeout). Rev 100 is + ;; Archive revs 70101, 70102, 70103 (70101 is success, + ;; 70102 is failure, 70103 is timeout). Rev 70100 is ;; skipped because make-archive doesn't archive ;; multiples of 100. - (make-archive 101) - (make-archive 102) - (make-archive 103) + (make-archive 70101) + (make-archive 70102) + (make-archive 70103) (define resp (dispatch-request (format "http://localhost/file-history/~a" test-file-path)))