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

Make some pages around revisions more generic

Browse source 
So that they can also be used for the /branch/foo/latest-processed-revision
pages. The content is the same, but the title, link, and some of the links on
the page are different.
This commit is contained in:
Christopher Baines 2019-06-16 10:27:14 +01:00
parent 33956b394f
commit de8858c274
2 changed files with 107 additions and 44 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -92,9 +92,12 @@
target-commit target-commit
(commit->revision-id conn target-commit)))) (commit->revision-id conn target-commit))))
(define (render-view-revision mime-types (define* (render-view-revision mime-types
conn conn
commit-hash) commit-hash
#:key path-base
(header-text
`("Revision " (samp ,commit-hash))))
(let ((packages-count (let ((packages-count
(count-packages-in-revision conn commit-hash)) (count-packages-in-revision conn commit-hash))
(git-repositories-and-branches (git-repositories-and-branches
@ -121,7 +124,9 @@
commit-hash commit-hash
packages-count packages-count
git-repositories-and-branches git-repositories-and-branches
derivations-counts) derivations-counts
#:path-base path-base
#:header-text header-text)
#:extra-headers http-headers-for-unchanging-content))))) #:extra-headers http-headers-for-unchanging-content)))))
(define (texinfo->variants-alist s) (define (texinfo->variants-alist s)
@ -148,10 +153,16 @@
(select-job-for-commit (select-job-for-commit
conn commit-hash)))))) conn commit-hash))))))
(define (render-revision-packages mime-types (define* (render-revision-packages mime-types
conn conn
commit-hash commit-hash
query-parameters) query-parameters
#:key
(path-base "/revision/")
(header-text
`("Revision " (samp ,commit-hash)))
(header-link
(string-append "/revision/" commit-hash)))
(if (any-invalid-query-parameters? query-parameters) (if (any-invalid-query-parameters? query-parameters)
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
@ -238,14 +249,24 @@
query-parameters query-parameters
packages packages
git-repositories git-repositories
show-next-page?) show-next-page?
#:path-base path-base
#:header-text header-text
#:header-link header-link)
#:extra-headers http-headers-for-unchanging-content)))))) #:extra-headers http-headers-for-unchanging-content))))))
(define (render-revision-package mime-types (define* (render-revision-package mime-types
conn conn
commit-hash commit-hash
name name
version) version
#:key
(header-text
`("Revision "
(samp ,commit-hash)))
(header-link
(string-append
"/revision/" commit-hash)))
(let ((metadata (let ((metadata
(select-package-metadata-by-revision-name-and-version (select-package-metadata-by-revision-name-and-version
conn conn
@ -288,7 +309,9 @@
version version
metadata metadata
derivations derivations
git-repositories) git-repositories
#:header-text header-text
#:header-link header-link)
#:extra-headers http-headers-for-unchanging-content))))) #:extra-headers http-headers-for-unchanging-content)))))
(define (render-compare-unknown-commit mime-types (define (render-compare-unknown-commit mime-types
@ -586,6 +609,9 @@
uri-query uri-query
parse-query-string)) parse-query-string))
(define path
(uri-path (request-uri request)))
(match method-and-path-components (match method-and-path-components
((GET) ((GET)
(render-html (render-html
@ -617,7 +643,8 @@
((GET "revision" commit-hash) (if (guix-commit-exists? conn commit-hash) ((GET "revision" commit-hash) (if (guix-commit-exists? conn commit-hash)
(render-view-revision mime-types (render-view-revision mime-types
conn conn
commit-hash) commit-hash
#:path-base path)
(render-unknown-revision mime-types (render-unknown-revision mime-types
conn conn
commit-hash))) commit-hash)))
@ -643,7 +670,8 @@
(render-revision-packages mime-types (render-revision-packages mime-types
conn conn
commit-hash commit-hash
parsed-query-parameters)) parsed-query-parameters
#:path-base path))
(render-unknown-revision mime-types (render-unknown-revision mime-types
conn conn
commit-hash))) commit-hash)))
@ -688,7 +716,11 @@
(if commit-hash (if commit-hash
(render-view-revision mime-types (render-view-revision mime-types
conn conn
commit-hash) commit-hash
#:path-base path
#:header-text
`("Latest processed revision for branch "
(samp ,branch-name)))
(render-unknown-revision mime-types (render-unknown-revision mime-types
conn conn
commit-hash)))) commit-hash))))
@ -716,7 +748,34 @@
(render-revision-packages mime-types (render-revision-packages mime-types
conn conn
commit-hash commit-hash
parsed-query-parameters)) parsed-query-parameters
#:path-base path
#:header-text
`("Latest processed revision for branch "
(samp ,branch-name))
#:header-link
(string-append
"/branch/" branch-name
"/latest-processed-revision")))
(render-unknown-revision mime-types
conn
commit-hash))))
((GET "branch" branch-name "latest-processed-revision" "package" name version)
(let ((commit-hash
(latest-processed-commit-for-branch conn branch-name)))
(if commit-hash
(render-revision-package mime-types
conn
commit-hash
name
version
#:header-text
`("Latest processed revision for branch "
(samp ,branch-name))
#:header-link
(string-append
"/branch/" branch-name
"/latest-processed-revision"))
(render-unknown-revision mime-types (render-unknown-revision mime-types
conn conn
commit-hash)))) commit-hash))))

54
guix-data-service/web/view/html.scm
View file

@ -316,9 +316,11 @@
(style "font-size: 2em; display: block;")) (style "font-size: 2em; display: block;"))
,derivations-count))))))) ,derivations-count)))))))
(define (view-revision-package-and-version revision-commit-hash name version (define* (view-revision-package-and-version revision-commit-hash name version
package-metadata package-metadata
derivations git-repositories) derivations git-repositories
#:key header-text
header-link)
(layout (layout
#:body #:body
`(,(header) `(,(header)
@ -328,9 +330,8 @@
(@ (class "row")) (@ (class "row"))
(div (div
(@ (class "col-sm-12")) (@ (class "col-sm-12"))
(h3 (a (@ (href ,(string-append (h3 (a (@ (href ,header-link))
"/revision/" revision-commit-hash))) ,@header-text))))
"Revision " (samp ,revision-commit-hash)))))
(div (div
(@ (class "row")) (@ (class "row"))
(div (div
@ -405,8 +406,10 @@
(td ,(build-status-span status))))) (td ,(build-status-span status)))))
derivations))))))))) derivations)))))))))
(define (view-revision commit-hash packages-count (define* (view-revision commit-hash packages-count
git-repositories-and-branches derivations-count) git-repositories-and-branches derivations-count
#:key (path-base "/revision/")
header-text)
(layout (layout
#:body #:body
`(,(header) `(,(header)
@ -417,17 +420,16 @@
(div (div
(@ (class "col-md-12")) (@ (class "col-md-12"))
(h1 (@ (style "white-space: nowrap;")) (h1 (@ (style "white-space: nowrap;"))
"Revision " (samp ,commit-hash)))) ,@header-text)))
(div (div
(@ (class "row")) (@ (class "row"))
(div (div
(@ (class "col-md-6")) (@ (class "col-md-6"))
(h3 "Packages") (h2 "Packages")
(strong (@ (class "text-center") (strong (@ (class "text-center")
(style "font-size: 2em; display: block;")) (style "font-size: 2em; display: block;"))
,packages-count) ,packages-count)
(a (@ (href ,(string-append "/revision/" commit-hash (a (@ (href ,(string-append path-base "/packages")))
"/packages")))
"View packages") "View packages")
,@(if ,@(if
@ -476,11 +478,13 @@
(td (samp ,count)))))) (td (samp ,count))))))
derivations-count))))))))) derivations-count)))))))))
(define (view-revision-packages revision-commit-hash (define* (view-revision-packages revision-commit-hash
query-parameters query-parameters
packages packages
git-repositories git-repositories
show-next-page?) show-next-page?
#:key path-base
header-text header-link)
(define field-options (define field-options
(map (map
(lambda (field) (lambda (field)
@ -499,9 +503,9 @@
(@ (class "row")) (@ (class "row"))
(div (div
(@ (class "col-sm-12")) (@ (class "col-sm-12"))
(h3 (a (@ (href ,(string-append (h3 (a (@ (style "white-space: nowrap;")
"/revision/" revision-commit-hash))) (href ,header-link))
"Revision " (samp ,revision-commit-hash))))) ,@header-text))))
(div (div
(@ (class "row")) (@ (class "row"))
(div (div
@ -546,7 +550,7 @@
(href ,(let ((query-parameter-string (href ,(let ((query-parameter-string
(query-parameters->string query-parameters))) (query-parameters->string query-parameters)))
(string-append (string-append
"/revision/" revision-commit-hash "/packages.json" path-base ".json"
(if (string-null? query-parameter-string) (if (string-null? query-parameter-string)
"" ""
(string-append "?" query-parameter-string)))))) (string-append "?" query-parameter-string))))))
@ -628,20 +632,20 @@
'()) '())
(td (@ (class "text-right")) (td (@ (class "text-right"))
(a (@ (href ,(string-append (a (@ (href ,(string-append
"/revision/" revision-commit-hash (string-drop-right path-base 1)
"/package/" name "/" version))) "/" name "/" version)))
"More information"))))) "More information")))))
packages)))))) packages))))))
,@(if show-next-page? ,@(if show-next-page?
`((div `((div
(@ (class "row")) (@ (class "row"))
(a (@ (href ,(string-append "/revision/" revision-commit-hash (a (@ (href ,(string-append path-base revision-commit-hash
"/packages?after_name=" "/packages?after_name="
(car (last packages))))) (car (last packages)))))
"Next page"))) "Next page")))
'()))))) '())))))
(define (view-branches branches-with-most-recent-commits) (define* (view-branches branches-with-most-recent-commits)
(layout (layout
#:body #:body
`(,(header) `(,(header)