Add some super crude JSON pages
Provide JSON versions of the existing HTML compare and compare/derivations pages. Refactor the code and extract some functions to make this a little less painful.
This commit is contained in:
parent
fd0bf340a7
commit
31737d32f9
GPG key ID:
5E28A33B0B84F577
1 changed files with 178 additions and 89 deletions
|
|
@ -51,100 +51,189 @@
|
||||||
;; (render-html (error-page message))))
|
;; (render-html (error-page message))))
|
||||||
)
|
)
|
||||||
|
|
||||||
|
(define (with-base-and-target-commits request conn f)
|
||||||
|
(let ((base-commit (-> request
|
||||||
|
request-uri
|
||||||
|
uri-query
|
||||||
|
parse-query-string
|
||||||
|
(cut assoc-ref <> "base_commit")))
|
||||||
|
(target-commit (-> request
|
||||||
|
request-uri
|
||||||
|
uri-query
|
||||||
|
parse-query-string
|
||||||
|
(cut assoc-ref <> "target_commit"))))
|
||||||
|
(f base-commit
|
||||||
|
(commit->revision-id conn base-commit)
|
||||||
|
target-commit
|
||||||
|
(commit->revision-id conn target-commit))))
|
||||||
|
|
||||||
|
(define (render-compare-unknown-commit content-type
|
||||||
|
conn
|
||||||
|
base-commit
|
||||||
|
base-revision-id
|
||||||
|
target-commit
|
||||||
|
target-revision-id)
|
||||||
|
(cond
|
||||||
|
((eq? content-type 'json)
|
||||||
|
(render-json
|
||||||
|
'((compare . #t))))
|
||||||
|
(else
|
||||||
|
(apply render-html
|
||||||
|
(compare-unknown-commit base-commit
|
||||||
|
target-commit
|
||||||
|
(if base-revision-id #t #f)
|
||||||
|
(if target-revision-id #t #f)
|
||||||
|
(select-job-for-commit conn
|
||||||
|
base-commit)
|
||||||
|
(select-job-for-commit conn
|
||||||
|
target-commit))))))
|
||||||
|
|
||||||
|
(define (render-compare content-type
|
||||||
|
conn
|
||||||
|
base-commit
|
||||||
|
base-revision-id
|
||||||
|
target-commit
|
||||||
|
target-revision-id)
|
||||||
|
(let-values
|
||||||
|
(((base-packages-vhash target-packages-vhash)
|
||||||
|
(package-data->package-data-vhashes
|
||||||
|
(package-differences-data conn
|
||||||
|
base-revision-id
|
||||||
|
target-revision-id))))
|
||||||
|
(let* ((new-packages
|
||||||
|
(package-data-vhashes->new-packages base-packages-vhash
|
||||||
|
target-packages-vhash))
|
||||||
|
(removed-packages
|
||||||
|
(package-data-vhashes->removed-packages base-packages-vhash
|
||||||
|
target-packages-vhash))
|
||||||
|
(version-changes
|
||||||
|
(package-data-version-changes base-packages-vhash
|
||||||
|
target-packages-vhash))
|
||||||
|
(other-changes
|
||||||
|
(package-data-other-changes base-packages-vhash
|
||||||
|
target-packages-vhash)))
|
||||||
|
(cond
|
||||||
|
((eq? content-type 'json)
|
||||||
|
(render-json
|
||||||
|
`((new-packages . ,new-packages)
|
||||||
|
(removed-packages . ,removed-packages)
|
||||||
|
(version-changes . ,version-changes)
|
||||||
|
(other-changes . ,other-changes))))
|
||||||
|
(else
|
||||||
|
(apply render-html
|
||||||
|
(compare base-commit
|
||||||
|
target-commit
|
||||||
|
new-packages
|
||||||
|
removed-packages
|
||||||
|
version-changes
|
||||||
|
other-changes)))))))
|
||||||
|
|
||||||
|
(define (render-compare/derivations content-type
|
||||||
|
conn
|
||||||
|
base-commit
|
||||||
|
base-revision-id
|
||||||
|
target-commit
|
||||||
|
target-revision-id)
|
||||||
|
(let-values
|
||||||
|
(((base-packages-vhash target-packages-vhash)
|
||||||
|
(package-data->package-data-vhashes
|
||||||
|
(package-differences-data conn
|
||||||
|
base-revision-id
|
||||||
|
target-revision-id))))
|
||||||
|
(let ((base-derivations
|
||||||
|
(package-data-vhash->derivations
|
||||||
|
conn
|
||||||
|
base-packages-vhash))
|
||||||
|
(target-derivations
|
||||||
|
(package-data-vhash->derivations
|
||||||
|
conn
|
||||||
|
target-packages-vhash)))
|
||||||
|
(cond
|
||||||
|
((eq? content-type 'json)
|
||||||
|
(render-json
|
||||||
|
`((base . ((commit . ,base-commit)
|
||||||
|
(derivations . ,base-derivations)))
|
||||||
|
(target . ((commit . ,target-commit)
|
||||||
|
(derivations . ,target-derivations))))))
|
||||||
|
(else
|
||||||
|
(apply render-html
|
||||||
|
(compare/derivations
|
||||||
|
base-commit
|
||||||
|
target-commit
|
||||||
|
base-derivations
|
||||||
|
target-derivations)))))))
|
||||||
|
|
||||||
(define (controller request body conn)
|
(define (controller request body conn)
|
||||||
(match-lambda
|
(match-lambda
|
||||||
((GET)
|
((GET)
|
||||||
(apply render-html (index (most-recent-n-guix-revisions conn 10))))
|
(apply render-html (index (most-recent-n-guix-revisions conn 10))))
|
||||||
((GET "compare")
|
((GET "compare")
|
||||||
(let ((base-commit (-> request
|
(with-base-and-target-commits
|
||||||
request-uri
|
request conn
|
||||||
uri-query
|
(lambda (base-commit base-revision-id target-commit target-revision-id)
|
||||||
parse-query-string
|
(if (not (and base-revision-id target-revision-id))
|
||||||
(cut assoc-ref <> "base_commit")))
|
(render-compare-unknown-commit 'html
|
||||||
(target-commit (-> request
|
conn
|
||||||
request-uri
|
base-commit
|
||||||
uri-query
|
base-revision-id
|
||||||
parse-query-string
|
target-commit
|
||||||
(cut assoc-ref <> "target_commit"))))
|
target-revision-id)
|
||||||
(let ((base-revision-id (commit->revision-id conn base-commit))
|
(render-compare 'html
|
||||||
(target-revision-id (commit->revision-id conn target-commit)))
|
conn
|
||||||
(cond
|
base-commit
|
||||||
((not (and base-revision-id target-revision-id))
|
base-revision-id
|
||||||
(apply render-html
|
target-commit
|
||||||
(compare-unknown-commit base-commit
|
target-revision-id)))))
|
||||||
target-commit
|
((GET "compare.json")
|
||||||
(if base-revision-id #t #f)
|
(with-base-and-target-commits
|
||||||
(if target-revision-id #t #f)
|
request conn
|
||||||
(select-job-for-commit conn
|
(lambda (base-commit base-revision-id target-commit target-revision-id)
|
||||||
base-commit)
|
(if (not (and base-revision-id target-revision-id))
|
||||||
(select-job-for-commit conn
|
(render-compare-unknown-commit 'json
|
||||||
target-commit))))
|
conn
|
||||||
(else
|
base-commit
|
||||||
(let-values
|
base-revision-id
|
||||||
(((base-packages-vhash target-packages-vhash)
|
target-commit
|
||||||
(package-data->package-data-vhashes
|
target-revision-id)
|
||||||
(package-differences-data conn
|
(render-compare 'json
|
||||||
base-revision-id
|
conn
|
||||||
target-revision-id))))
|
base-commit
|
||||||
(let* ((new-packages
|
base-revision-id
|
||||||
(package-data-vhashes->new-packages base-packages-vhash
|
target-commit
|
||||||
target-packages-vhash))
|
target-revision-id)))))
|
||||||
(removed-packages
|
|
||||||
(package-data-vhashes->removed-packages base-packages-vhash
|
|
||||||
target-packages-vhash))
|
|
||||||
(version-changes
|
|
||||||
(package-data-version-changes base-packages-vhash
|
|
||||||
target-packages-vhash))
|
|
||||||
(other-changes
|
|
||||||
(package-data-other-changes base-packages-vhash
|
|
||||||
target-packages-vhash)))
|
|
||||||
(apply render-html
|
|
||||||
(compare base-commit
|
|
||||||
target-commit
|
|
||||||
new-packages
|
|
||||||
removed-packages
|
|
||||||
version-changes
|
|
||||||
other-changes)))))))))
|
|
||||||
((GET "compare" "derivations")
|
((GET "compare" "derivations")
|
||||||
(let ((base-commit (-> request
|
(with-base-and-target-commits
|
||||||
request-uri
|
request conn
|
||||||
uri-query
|
(lambda (base-commit base-revision-id target-commit target-revision-id)
|
||||||
parse-query-string
|
(if (not (and base-revision-id target-revision-id))
|
||||||
(cut assoc-ref <> "base_commit")))
|
(render-compare-unknown-commit 'html
|
||||||
(target-commit (-> request
|
conn
|
||||||
request-uri
|
base-commit
|
||||||
uri-query
|
base-revision-id
|
||||||
parse-query-string
|
target-commit
|
||||||
(cut assoc-ref <> "target_commit"))))
|
target-revision-id)
|
||||||
(let ((base-revision-id (commit->revision-id conn base-commit))
|
(render-compare/derivations 'html
|
||||||
(target-revision-id (commit->revision-id conn target-commit)))
|
conn
|
||||||
(cond
|
base-commit
|
||||||
((not (and base-revision-id target-revision-id))
|
base-revision-id
|
||||||
(apply render-html
|
target-commit
|
||||||
(compare-unknown-commit base-commit
|
target-revision-id)))))
|
||||||
target-commit
|
((GET "compare" "derivations.json")
|
||||||
(if base-revision-id #t #f)
|
(with-base-and-target-commits
|
||||||
(if target-revision-id #t #f)
|
request conn
|
||||||
(select-job-for-commit conn
|
(lambda (base-commit base-revision-id target-commit target-revision-id)
|
||||||
base-commit)
|
(if (not (and base-revision-id target-revision-id))
|
||||||
(select-job-for-commit conn
|
(render-compare-unknown-commit 'json
|
||||||
target-commit))))
|
conn
|
||||||
(else
|
base-commit
|
||||||
(let-values
|
base-revision-id
|
||||||
(((base-packages-vhash target-packages-vhash)
|
target-commit
|
||||||
(package-data->package-data-vhashes
|
target-revision-id)
|
||||||
(package-differences-data conn
|
(render-compare/derivations 'json
|
||||||
base-revision-id
|
conn
|
||||||
target-revision-id))))
|
base-commit
|
||||||
(apply render-html
|
base-revision-id
|
||||||
(compare/derivations
|
target-commit
|
||||||
base-commit
|
target-revision-id)))))
|
||||||
target-commit
|
|
||||||
(package-data-vhash->derivations
|
|
||||||
conn
|
|
||||||
base-packages-vhash)
|
|
||||||
(package-data-vhash->derivations
|
|
||||||
conn
|
|
||||||
target-packages-vhash)))))))))
|
|
||||||
((GET path ...)
|
((GET path ...)
|
||||||
(render-static-asset request))))
|
(render-static-asset request))))
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue