cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Add some super crude JSON pages

Browse source 
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:
Christopher Baines 2019-02-25 22:07:26 +00:00
parent fd0bf340a7
commit 31737d32f9
Signed by: cbaines
GPG key ID: 5E28A33B0B84F577
1 changed files with 178 additions and 89 deletions
Download patch file Download diff file Expand all files Collapse all files

167
guix-data-service/web/controller.scm
View file

@ -51,11 +51,7 @@
;; (render-html (error-page message))))
)
(define (controller request body conn)
(match-lambda
((GET)
(apply render-html (index (most-recent-n-guix-revisions conn 10))))
((GET "compare")
(define (with-base-and-target-commits request conn f)
(let ((base-commit (-> request
request-uri
uri-query
@ -66,10 +62,22 @@
uri-query
parse-query-string
(cut assoc-ref <> "target_commit"))))
(let ((base-revision-id (commit->revision-id conn base-commit))
(target-revision-id (commit->revision-id conn 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
((not (and base-revision-id target-revision-id))
((eq? content-type 'json)
(render-json
'((compare . #t))))
(else
(apply render-html
(compare-unknown-commit base-commit
target-commit
@ -78,8 +86,14 @@
(select-job-for-commit conn
base-commit)
(select-job-for-commit conn
target-commit))))
(else
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
@ -98,53 +112,128 @@
(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)))))))))
((GET "compare" "derivations")
(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"))))
(let ((base-revision-id (commit->revision-id conn base-commit))
(target-revision-id (commit->revision-id conn target-commit)))
(cond
((not (and base-revision-id target-revision-id))
(apply render-html
(compare-unknown-commit base-commit
other-changes)))))))
(define (render-compare/derivations content-type
conn
base-commit
base-revision-id
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))))
(else
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
(package-data-vhash->derivations
base-derivations
target-derivations)))))))
(define (controller request body conn)
(match-lambda
((GET)
(apply render-html (index (most-recent-n-guix-revisions conn 10))))
((GET "compare")
(with-base-and-target-commits
request conn
(lambda (base-commit base-revision-id target-commit target-revision-id)
(if (not (and base-revision-id target-revision-id))
(render-compare-unknown-commit 'html
conn
base-packages-vhash)
(package-data-vhash->derivations
base-commit
base-revision-id
target-commit
target-revision-id)
(render-compare 'html
conn
target-packages-vhash)))))))))
base-commit
base-revision-id
target-commit
target-revision-id)))))
((GET "compare.json")
(with-base-and-target-commits
request conn
(lambda (base-commit base-revision-id target-commit target-revision-id)
(if (not (and base-revision-id target-revision-id))
(render-compare-unknown-commit 'json
conn
base-commit
base-revision-id
target-commit
target-revision-id)
(render-compare 'json
conn
base-commit
base-revision-id
target-commit
target-revision-id)))))
((GET "compare" "derivations")
(with-base-and-target-commits
request conn
(lambda (base-commit base-revision-id target-commit target-revision-id)
(if (not (and base-revision-id target-revision-id))
(render-compare-unknown-commit 'html
conn
base-commit
base-revision-id
target-commit
target-revision-id)
(render-compare/derivations 'html
conn
base-commit
base-revision-id
target-commit
target-revision-id)))))
((GET "compare" "derivations.json")
(with-base-and-target-commits
request conn
(lambda (base-commit base-revision-id target-commit target-revision-id)
(if (not (and base-revision-id target-revision-id))
(render-compare-unknown-commit 'json
conn
base-commit
base-revision-id
target-commit
target-revision-id)
(render-compare/derivations 'json
conn
base-commit
base-revision-id
target-commit
target-revision-id)))))
((GET path ...)
(render-static-asset request))))