From 7d2309d3447b1e83e869b39fec3d247a85971f4c Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sat, 21 Mar 2020 10:38:20 +0000 Subject: [PATCH] Add a page for package output history on a branch This complements the existing pages for the version history, and derivation history. As well as the new page, the buttons and styling of the two existing pages has been made to match better to enable easier navigation between the pages. --- .../web/repository/controller.scm | 78 ++++++ guix-data-service/web/repository/html.scm | 261 +++++++++++++++++- 2 files changed, 335 insertions(+), 4 deletions(-) diff --git a/guix-data-service/web/repository/controller.scm b/guix-data-service/web/repository/controller.scm index af77737..f31c41f 100644 --- a/guix-data-service/web/repository/controller.scm +++ b/guix-data-service/web/repository/controller.scm @@ -126,6 +126,14 @@ repository-id branch-name package-name)) + (('GET "repository" repository-id "branch" branch-name + "package" package-name "output-history") + (render-branch-package-output-history request + mime-types + conn + repository-id + branch-name + package-name)) (('GET "repository" repository-id "branch" branch-name "latest-processed-revision") (let ((commit-hash (latest-processed-commit-for-branch conn repository-id branch-name))) @@ -308,3 +316,73 @@ (valid-targets conn)) build-server-urls package-derivations))))))) + +(define (render-branch-package-output-history request + mime-types + conn + repository-id + branch-name + package-name) + (let ((parsed-query-parameters + (parse-query-parameters + request + `((output ,identity + #:default "out") + (system ,(parse-build-system conn) + #:default "x86_64-linux") + (target ,parse-target + #:default ""))))) + (let* ((system + (assq-ref parsed-query-parameters 'system)) + (target + (assq-ref parsed-query-parameters 'target)) + (output-name + (assq-ref parsed-query-parameters 'output)) + (package-outputs + (package-outputs-for-branch conn + (string->number repository-id) + branch-name + system + target + package-name + output-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-outputs)))))) + (else + (render-html + #:sxml (view-branch-package-outputs + parsed-query-parameters + repository-id + branch-name + package-name + output-name + (valid-systems conn) + (valid-targets->options + (valid-targets conn)) + build-server-urls + package-outputs))))))) diff --git a/guix-data-service/web/repository/html.scm b/guix-data-service/web/repository/html.scm index 8f1a6d5..f21a9f2 100644 --- a/guix-data-service/web/repository/html.scm +++ b/guix-data-service/web/repository/html.scm @@ -26,7 +26,8 @@ view-branches view-branch view-branch-package - view-branch-package-derivations)) + view-branch-package-derivations + view-branch-package-outputs)) (define* (view-git-repositories git-repositories) (layout @@ -198,7 +199,7 @@ #:body `(,(header) (div - (@ (class "container")) + (@ (class "container-fluid")) (div (@ (class "row")) (div @@ -208,9 +209,23 @@ (a (@ (href ,(string-append "/repository/" git-repository-id "/branch/" branch-name))) (h3 ,(string-append branch-name " branch"))) + (a (@ (class "btn btn-default btn-lg pull-right") + (style "margin-left: 0.5em;") + (href ,(string-append + "/repository/" git-repository-id + "/branch/" branch-name + "/package/" package-name + ".json"))) + "View JSON") (div (@ (class "btn-group pull-right") (role "group")) + (a (@ (class "btn btn-default btn-lg disabled") + (href ,(string-append + "/repository/" git-repository-id + "/branch/" branch-name + "/package/" package-name))) + "Versions only") (a (@ (class "btn btn-default btn-lg") (href ,(string-append "/repository/" git-repository-id @@ -223,8 +238,8 @@ "/repository/" git-repository-id "/branch/" branch-name "/package/" package-name - ".json"))) - "View JSON")) + "/output-history"))) + "Include outputs")) (h1 (@ (style "white-space: nowrap;")) (samp ,package-name)))) (div @@ -361,12 +376,36 @@ "/branch/" branch-name))) (h3 ,(string-append branch-name " branch"))) (a (@ (class "btn btn-default btn-lg pull-right") + (style "margin-left: 0.5em;") (href ,(string-append "/repository/" git-repository-id "/branch/" branch-name "/package/" package-name "/derivation-history.json"))) "View JSON") + (div + (@ (class "btn-group pull-right") + (role "group")) + (a (@ (class "btn btn-default btn-lg") + (href ,(string-append + "/repository/" git-repository-id + "/branch/" branch-name + "/package/" package-name))) + "Versions only") + (a (@ (class "btn btn-default btn-lg disabled") + (href ,(string-append + "/repository/" git-repository-id + "/branch/" branch-name + "/package/" package-name + "/derivation-history"))) + "Include derivations") + (a (@ (class "btn btn-default btn-lg") + (href ,(string-append + "/repository/" git-repository-id + "/branch/" branch-name + "/package/" package-name + "/output-history"))) + "Include outputs")) (h1 (@ (style "white-space: nowrap;")) (samp ,package-name)))) (div @@ -528,3 +567,217 @@ (map second (cdr derivations-by-revision-range)) '(#f)))))))))))) + +(define (view-branch-package-outputs query-parameters + git-repository-id + branch-name + package-name + output-name + valid-systems + valid-targets + build-server-urls + outputs-by-revision-range) + (define versions-list + (pair-fold (match-lambda* + (((last) (count result ...)) + (cons (cons last count) + result)) + (((a b rst ...) (count result ...)) + (if (string=? a b) + (cons (+ 1 count) + (cons #f result)) + (cons 1 + (cons (cons a count) + result))))) + '(1) + (reverse + (map first outputs-by-revision-range)))) + + (layout + #:body + `(,(header) + (div + (@ (class "container-fluid")) + (div + (@ (class "row")) + (div + (@ (class "col-md-12")) + (a (@ (href ,(string-append "/repository/" git-repository-id))) + (h3 "Repository")) + (a (@ (href ,(string-append "/repository/" git-repository-id + "/branch/" branch-name))) + (h3 ,(string-append branch-name " branch"))) + (a (@ (class "btn btn-default btn-lg pull-right") + (style "margin-left: 0.5em;") + (href ,(string-append + "/repository/" git-repository-id + "/branch/" branch-name + "/package/" package-name + "/output-history.json"))) + "View JSON") + (div + (@ (class "btn-group pull-right") + (role "group")) + (a (@ (class "btn btn-default btn-lg") + (href ,(string-append + "/repository/" git-repository-id + "/branch/" branch-name + "/package/" package-name))) + "Versions only") + (a (@ (class "btn btn-default btn-lg") + (href ,(string-append + "/repository/" git-repository-id + "/branch/" branch-name + "/package/" package-name + "/derivation-history"))) + "Include derivations") + (a (@ (class "btn btn-default btn-lg disabled") + (href ,(string-append + "/repository/" git-repository-id + "/branch/" branch-name + "/package/" package-name + "/output-history"))) + "Include outputs")) + (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 + "Output" query-parameters + #:help-text "Show this output for the package.") + ,(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-targets + #: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")) + (table + (@ (class "table") + (style "table-layout: fixed;")) + (thead + (tr + (th (@ (class "col-sm-1")) "Version") + (th (@ (class "col-sm-6")) "Output") + (th (@ (class "col-sm-2")) "Builds") + (th (@ (class "col-sm-2")) "From") + (th (@ (class "col-sm-2")) "To"))) + (tbody + ,@(let* ((times-in-seconds + (map (lambda (d) + (time-second + (date->time-monotonic + (string->date d "~Y-~m-~d ~H:~M:~S")))) + (append (map fourth outputs-by-revision-range) + (map sixth outputs-by-revision-range)))) + (earliest-date-seconds + (apply min + times-in-seconds)) + (latest-date-seconds + (apply max + times-in-seconds)) + (min-to-max-seconds + (- latest-date-seconds + earliest-date-seconds))) + (map + (match-lambda* + ((version-column-entry + (package-version output-path + first-guix-revision-commit + first-datetime + last-guix-revision-commit + last-datetime + builds)) + `((tr + (@ (style "border-bottom: 0;")) + ,@(match version-column-entry + (#f '()) + ((package-version . rowspan) + `((td (@ (rowspan ,(* 2 ; To account for the extra rows + rowspan))) + ,package-version)))) + (td + (a (@ (href ,output-path)) + ,(display-store-item output-path))) + (td + (dl + ,@(append-map + (lambda (build) + (let ((build-server-id + (assoc-ref build "build_server_id"))) + `((dt + (@ (style "font-weight: unset;")) + (a (@ (href + ,(assq-ref build-server-urls + build-server-id))) + ,(assq-ref build-server-urls + build-server-id))) + (dd + (a (@ (href + ,(simple-format + #f "/build-server/~A/build?derivation_file_name=~A" + build-server-id + (assoc-ref build "derivation_file_name")))) + ,(build-status-alist->build-icon build)))))) + builds))) + (td (a (@ (href ,(string-append + "/revision/" first-guix-revision-commit))) + ,first-datetime)) + (td (a (@ (href ,(string-append + "/revision/" last-guix-revision-commit))) + ,last-datetime))) + (tr + (td + (@ (colspan 4) + (style "border-top: 0; padding-top: 0;")) + (div + (@ + (style + ,(let* ((start-seconds + (time-second + (date->time-monotonic + (string->date first-datetime + "~Y-~m-~d ~H:~M:~S")))) + (end-seconds + (time-second + (date->time-monotonic + (string->date last-datetime + "~Y-~m-~d ~H:~M:~S")))) + (margin-left + (min + (* (/ (- start-seconds earliest-date-seconds) + min-to-max-seconds) + 100) + 98)) + (width + (max + (- (* (/ (- end-seconds earliest-date-seconds) + min-to-max-seconds) + 100) + margin-left) + 2))) + (simple-format + #f + "margin-left: ~A%; width: ~A%; height: 10px; background: #DCDCDC;" + (rationalize margin-left 1) + (rationalize width 1))))))))))) + versions-list + outputs-by-revision-range))))))))))