diff options
| -rw-r--r-- | guix-data-service/web/repository/controller.scm | 113 | ||||
| -rw-r--r-- | guix-data-service/web/repository/html.scm | 27 |
2 files changed, 95 insertions, 45 deletions
diff --git a/guix-data-service/web/repository/controller.scm b/guix-data-service/web/repository/controller.scm index e77b574..30e7ffd 100644 --- a/guix-data-service/web/repository/controller.scm +++ b/guix-data-service/web/repository/controller.scm @@ -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,50 +231,73 @@ 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 - (package-derivations-for-branch conn - (string->number repository-id) - branch-name - "x86_64-linux" - "x86_64-linux" - package-name)) - (build-server-urls - (group-to-alist - (match-lambda - ((id url lookup-all-derivations) - (cons id url))) - (select-build-servers conn)))) - (case (most-appropriate-mime-type - '(application/json text/html) - mime-types) - ((application/json) - (render-json - `((derivations . ,(list->vector - (map (match-lambda - ((package-version derivation-file-name - first-guix-revision-commit - first-datetime - last-guix-revision-commit - last-datetime) - `((version . ,package-version) - (derivation . ,derivation-file-name) - (first_revision - . ((commit . ,first-guix-revision-commit) - (datetime . ,first-datetime))) - (last_revision - . ((commit . ,last-guix-revision-commit) - (datetime . ,last-datetime)))))) - package-derivations)))))) - (else - (render-html - #:sxml (view-branch-package-derivations - repository-id - branch-name - package-name - build-server-urls - 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 + system + target + package-name)) + (build-server-urls + (group-to-alist + (match-lambda + ((id url lookup-all-derivations) + (cons id url))) + (select-build-servers conn)))) + (case (most-appropriate-mime-type + '(application/json text/html) + mime-types) + ((application/json) + (render-json + `((derivations . ,(list->vector + (map (match-lambda + ((package-version derivation-file-name + first-guix-revision-commit + first-datetime + last-guix-revision-commit + last-datetime) + `((version . ,package-version) + (derivation . ,derivation-file-name) + (first_revision + . ((commit . ,first-guix-revision-commit) + (datetime . ,first-datetime))) + (last_revision + . ((commit . ,last-guix-revision-commit) + (datetime . ,last-datetime)))))) + package-derivations)))))) + (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))))))) diff --git a/guix-data-service/web/repository/html.scm b/guix-data-service/web/repository/html.scm index 37aaadc..4503f08 100644 --- a/guix-data-service/web/repository/html.scm +++ b/guix-data-service/web/repository/html.scm @@ -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 @@ -335,6 +337,29 @@ (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 (@ (class "col-md-12")) |