Skip to content

Accept only revisions with builds in URLs, and bound revision walks #21

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
samth merged 1 commit into from
Sep 28, 2026
Merged

Accept only revisions with builds in URLs, and bound revision walks #21

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
93 changes: 81 additions & 12 deletions render.rkt
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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))
Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -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)
Expand Down
67 changes: 38 additions & 29 deletions test-rendering.rkt
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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"
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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)
Expand All @@ -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)
Expand All @@ -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)
Expand All @@ -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))))
Expand All @@ -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 ()
Expand All @@ -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)))
Expand Down Expand Up @@ -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))))
Expand All @@ -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)))
Expand Down
Loading