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

Don't hardcode the system and target for the derivation history page

Browse source
This commit is contained in:
Christopher Baines 2020-01-05 11:17:39 +00:00
parent 6f34d12c4c
commit ffcf937c6a
2 changed files with 95 additions and 45 deletions
Download patch file Download diff file Expand all files Collapse all files

37
guix-data-service/web/repository/controller.scm
View file

@ -24,6 +24,7 @@
#:use-module (guix-data-service web util)
#:use-module (guix-data-service model utils)
#:use-module (guix-data-service model build-server)
#:use-module (guix-data-service model derivation)
#:use-module (guix-data-service model package)
#:use-module (guix-data-service model git-branch)
#:use-module (guix-data-service model git-repository)
@ -114,7 +115,8 @@
package-name
package-versions))))))
(('GET "repository" repository-id "branch" branch-name "package" package-name "derivation-history")
(render-branch-package-derivation-history mime-types
(render-branch-package-derivation-history request
mime-types
conn
repository-id
branch-name
@ -229,17 +231,38 @@
commit-hash))))
(_ #f)))
(define (render-branch-package-derivation-history mime-types
(define (parse-build-system conn)
(let ((systems
(valid-systems conn)))
(lambda (s)
(if (member s systems)
s
(make-invalid-query-parameter
s "unknown system")))))
(define (render-branch-package-derivation-history request
mime-types
conn
repository-id
branch-name
package-name)
(let ((package-derivations
(let ((parsed-query-parameters
(parse-query-parameters
request
`((system ,(parse-build-system conn)
#:default "x86_64-linux")
(target ,(parse-build-system conn)
#:default "x86_64-linux")))))
(let* ((system
(assq-ref parsed-query-parameters 'system))
(target
(assq-ref parsed-query-parameters 'target))
(package-derivations
(package-derivations-for-branch conn
(string->number repository-id)
branch-name
"x86_64-linux"
"x86_64-linux"
system
target
package-name))
(build-server-urls
(group-to-alist
@ -271,8 +294,10 @@
(else
(render-html
#:sxml (view-branch-package-derivations
parsed-query-parameters
repository-id
branch-name
package-name
(valid-systems conn)
build-server-urls
package-derivations))))))
package-derivations)))))))

27
guix-data-service/web/repository/html.scm
View file

@ -290,9 +290,11 @@
(rationalize width 1)))))))))))
versions-by-revision-range))))))))))
(define (view-branch-package-derivations git-repository-id
(define (view-branch-package-derivations query-parameters
git-repository-id
branch-name
package-name
valid-systems
build-server-urls
derivations-by-revision-range)
(define versions-list
@ -334,6 +336,29 @@
"View JSON")
(h1 (@ (style "white-space: nowrap;"))
(samp ,package-name))))
(div
(@ (class "col-md-12"))
(div
(@ (class "well"))
(form
(@ (method "get")
(action "")
(class "form-horizontal"))
,(form-horizontal-control
"System" query-parameters
#:options valid-systems
#:allow-selecting-multiple-options #f
#:help-text "Show derivations with this system.")
,(form-horizontal-control
"Target" query-parameters
#:options valid-systems
#:allow-selecting-multiple-options #f
#:help-text "Show derivations with this target.")
(div (@ (class "form-group form-group-lg"))
(div (@ (class "col-sm-offset-2 col-sm-10"))
(button (@ (type "submit")
(class "btn btn-lg btn-primary"))
"Update results"))))))
(div
(@ (class "row"))
(div