From 640fb8a2ad262e06b138deb975f92e6acb3a423b Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sat, 11 May 2019 20:38:16 +0100 Subject: Update the derivation comparison implementation This adds more query parameter validation, and uses form-horizontal-control to neaten up the view code. --- guix-data-service/web/controller.scm | 172 ++++++++++++++++----------------- guix-data-service/web/view/html.scm | 179 ++++++++++------------------------- 2 files changed, 134 insertions(+), 217 deletions(-) diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm index 94b8b5e..afe98cb 100644 --- a/guix-data-service/web/controller.scm +++ b/guix-data-service/web/controller.scm @@ -141,13 +141,7 @@ (define (render-compare/derivations content-type conn - base-commit - base-revision-id - target-commit - target-revision-id - systems - targets - build-statuses) + query-parameters) (define (derivations->alist derivations) (map (match-lambda ((file-name system target buildstatus) @@ -159,49 +153,64 @@ buildstatus))))) derivations)) - (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-and-build-status - conn - base-packages-vhash - systems - targets - build-statuses)) - (target-derivations - (package-data-vhash->derivations-and-build-status - conn - target-packages-vhash - systems - targets - build-statuses))) + (if (any-invalid-query-parameters? query-parameters) (cond ((eq? content-type 'json) (render-json - `((base . ((commit . ,base-commit) - (derivations . ,(list->vector - (derivations->alist - base-derivations))))) - (target . ((commit . ,target-commit) - (derivations . ,(list->vector - (derivations->alist - target-derivations)))))))) + '((error . "invalid query")))) (else (apply render-html (compare/derivations + query-parameters (valid-systems conn) build-status-strings - base-commit - target-commit - base-derivations - target-derivations - systems - targets - build-statuses))))))) + '() + '())))) + + (let ((base-commit (assq-ref query-parameters 'base_commit)) + (target-commit (assq-ref query-parameters 'target_commit)) + (systems (assq-ref query-parameters 'system)) + (targets (assq-ref query-parameters 'target)) + (build-statuses (assq-ref query-parameters 'build_status))) + (let-values + (((base-packages-vhash target-packages-vhash) + (package-data->package-data-vhashes + (package-differences-data conn + (commit->revision-id conn base-commit) + (commit->revision-id conn target-commit))))) + (let ((base-derivations + (package-data-vhash->derivations-and-build-status + conn + base-packages-vhash + systems + targets + build-statuses)) + (target-derivations + (package-data-vhash->derivations-and-build-status + conn + target-packages-vhash + systems + targets + build-statuses))) + (cond + ((eq? content-type 'json) + (render-json + `((base . ((commit . ,base-commit) + (derivations . ,(list->vector + (derivations->alist + base-derivations))))) + (target . ((commit . ,target-commit) + (derivations . ,(list->vector + (derivations->alist + target-derivations)))))))) + (else + (apply render-html + (compare/derivations + query-parameters + (valid-systems conn) + build-status-strings + base-derivations + target-derivations))))))))) (define (render-compare/packages content-type conn @@ -280,6 +289,19 @@ conn output-id)))) derivations))))))) +(define (parse-commit conn) + (lambda (s) + (if (guix-commit-exists? conn s) + s + (make-invalid-query-parameter + s "unknown commit")))) + +(define (parse-system s) + s) + +(define (parse-build-status s) + s) + (define (controller request body conn) (define query-parameters (-> request @@ -408,51 +430,29 @@ target-commit target-revision-id))))) ((GET "compare" "derivations") - (with-base-and-target-commits - query-parameters 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 - (assoc-ref-multiple query-parameters - "system") - (assoc-ref-multiple query-parameters - "target") - (assoc-ref-multiple query-parameters - "build_status")))))) + (let* ((parsed-query-parameters + (parse-query-parameters + request + `((base_commit ,(parse-commit conn) #:required) + (target_commit ,(parse-commit conn) #:required) + (system ,parse-system #:multi-value) + (target ,parse-system #:multi-value) + (build_status ,parse-build-status #:multi-value))))) + (render-compare/derivations 'html + conn + parsed-query-parameters))) ((GET "compare" "derivations.json") - (with-base-and-target-commits - query-parameters 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 - (assoc-ref-multiple query-parameters - "system") - (assoc-ref-multiple query-parameters - "target") - (assoc-ref-multiple query-parameters - "build_status")))))) + (let* ((parsed-query-parameters + (parse-query-parameters + request + `((base_commit ,(parse-commit conn) #:required) + (target_commit ,(parse-commit conn) #:required) + (system ,parse-system #:multi-value) + (target ,parse-system #:multi-value) + (build_status ,parse-build-status #:multi-value))))) + (render-compare/derivations 'json + conn + parsed-query-parameters))) ((GET "compare" "packages") (with-base-and-target-commits query-parameters conn diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm index b966853..d7b5725 100644 --- a/guix-data-service/web/view/html.scm +++ b/guix-data-service/web/view/html.scm @@ -1005,35 +1005,11 @@ (cdr data-columns)))))) (vector->list derivation-changes))))))))))) -(define (compare/derivations valid-systems +(define (compare/derivations query-parameters + valid-systems valid-build-statuses - base-commit - target-commit base-derivations - target-derivations - systems - targets - build-statuses) - (define query-params - (string-append - "?" - (string-join - `(,(string-append "base_commit=" base-commit) - ,(string-append "target_commit=" target-commit) - ,@(map (lambda (system) - (string-append - "system=" system)) - systems) - ,@(map (lambda (target) - (string-append - "target=" target)) - targets) - ,@(map (lambda (build_status) - (string-append - "build_status=" build_status)) - build-statuses)) - "&"))) - + target-derivations) (layout #:extra-headers '((cache-control . ((max-age . 60)))) @@ -1043,10 +1019,14 @@ (@ (class "container")) (div (@ (class "row")) - (h1 "Comparing " - (samp ,(string-take base-commit 8) "…") - " and " - (samp ,(string-take target-commit 8) "…"))) + (h1 ,@(let ((base-commit (assq-ref query-parameters 'base_commit)) + (target-commit (assq-ref query-parameters 'target_commit))) + (if (every string? (list base-commit target-commit)) + `("Comparing " + (samp ,(string-take base-commit 8) "…") + " and " + (samp ,(string-take target-commit 8) "…")) + '("Comparing derivations"))))) (div (@ (class "row")) (div @@ -1057,114 +1037,49 @@ (@ (method "get") (action "") (class "form-horizontal")) - (div (@ (class "form-group form-group-lg")) - (label (@ (for "inputBaseCommit") - (class "col-sm-2 control-label")) - "Base commit") - (div (@ (class "col-sm-9")) - (input (@ (class "form-control") - (style "font-family: monospace;") - (id "inputBaseCommit") - (required #t) - (aria-describedby "baseCommitHelp") - (name "base_commit") - (value ,base-commit))) - (span (@ (id "baseCommitHelp") - (class "help-block")) - (strong "Required.") - " The commit to use as the basis for the comparison."))) - (div (@ (class "form-group form-group-lg")) - (label (@ (for "inputTargetCommit") - (class "col-sm-2 control-label")) - "Target commit") - (div (@ (class "col-sm-9")) - (input (@ (class "form-control") - (style "font-family: monospace;") - (id "inputTargetCommit") - (required #t) - (aria-describedby "targetCommitHelp") - (name "target_commit") - (value ,target-commit))) - (span (@ (id "targetCommitHelp") - (class "help-block")) - (strong "Required.") - " The commit to compare against the base commit."))) - (div (@ (class "form-group form-group-lg")) - (label (@ (for "inputSystem") - (class "col-sm-2 control-label")) - "System") - (div (@ (class "col-sm-9")) - (select (@ (class "form-control") - (style "font-family: monospace;") - (multiple #t) - (id "inputSystem") - (aria-describedby "systemHelp") - (name "system")) - ,@(map (lambda (system) - `(option (@ ,@(if (member system systems) - '((selected "")) - '())) - ,system)) - valid-systems)) - (span (@ (id "systemHelp") - (class "help-block")) - "Only include derivations for this system."))) - (div (@ (class "form-group form-group-lg")) - (label (@ (for "inputTarget") - (class "col-sm-2 control-label")) - "Target") - (div (@ (class "col-sm-9")) - (select (@ (class "form-control") - (style "font-family: monospace;") - (multiple #t) - (id "inputTarget") - (aria-describedby "targetHelp") - (name "target")) - ,@(map (lambda (system) - `(option (@ ,@(if (member system targets) - '((selected "")) - '())) - ,system)) - valid-systems)) - (span (@ (id "targetHelp") - (class "help-block")) - "Only include derivations that are build for this system."))) - (div (@ (class "form-group form-group-lg")) - (label (@ (for "inputBuildStatus") - (class "col-sm-2 control-label")) - "Build status") - (div (@ (class "col-sm-9")) - (select (@ (class "form-control") - (id "inputBuildStatus") - (aria-describedby "buildStatusHelp") - (multiple #t) - (name "build_status")) - ,@(map (lambda (build-status) - `(option (@ ,@(if (member build-status build-statuses) - '((selected "")) - '()) - (value ,build-status)) - ,(build-status-value->display-string build-status))) - valid-build-statuses)) - (span (@ (id "buildStatusHelp") - (class "help-block")) - "Only include derivations which have this build status."))) + ,(form-horizontal-control + "Base commit" query-parameters + #:required? #t + #:help-text "The commit to use as the basis for the comparison.") + ,(form-horizontal-control + "Target commit" query-parameters + #:required? #t + #:help-text "The commit to compare against the base commit.") + ,(form-horizontal-control + "System" query-parameters + #:options valid-systems + #:help-text "Only include derivations for this system.") + ,(form-horizontal-control + "Target" query-parameters + #:options valid-systems + #:help-text "Only include derivations that are build for this system.") + ,(form-horizontal-control + "Build status" query-parameters + #:options valid-build-statuses + #:help-text "Only include derivations which have this build status.") (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"))) (a (@ (class "btn btn-default btn-lg pull-right") - (href ,(string-append - "/compare/derivations.json" query-params))) + (href ,(let ((query-parameter-string + (query-parameters->string query-parameters))) + (string-append + "/compare/derivations.json" + (if (string-null? query-parameter-string) + "" + (string-append "?" query-parameter-string)))))) "View JSON"))))) (div (@ (class "row")) (div (@ (class "col-sm-12")) - (h3 "Base (" - (samp ,base-commit) - ")") + (h3 "Base" + ,@(let ((base-commit (assq-ref query-parameters 'base_commit))) + (if (string? base-commit) + `(" (" (samp ,base-commit) ")") + '()))) (p "Derivations found only in the base revision.") (table (@ (class "table")) @@ -1189,9 +1104,11 @@ (@ (class "row")) (div (@ (class "col-sm-12")) - (h3 "Target (" - (samp ,target-commit) - ")") + (h3 "Target" + ,@(let ((target-commit (assq-ref query-parameters 'target_commit))) + (if (string? target-commit) + `(" (" (samp ,target-commit) ")") + '()))) (p "Derivations found only in the target revision.") (table (@ (class "table")) -- cgit v1.2.3