From a1e481cc4dbd81df77490e6ab8cab9ef55605248 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Thu, 7 Mar 2019 23:50:51 +0000 Subject: [PATCH] Continue improving pages and linking things together --- guix-data-service/model/build.scm | 20 ++++++ guix-data-service/model/derivation.scm | 28 ++++++++ guix-data-service/web/controller.scm | 27 +++++-- guix-data-service/web/view/html.scm | 98 +++++++++++++++++++++++--- 4 files changed, 160 insertions(+), 13 deletions(-) diff --git a/guix-data-service/model/build.scm b/guix-data-service/model/build.scm index 1f57672..bcfa444 100644 --- a/guix-data-service/model/build.scm +++ b/guix-data-service/model/build.scm @@ -2,6 +2,7 @@ #:use-module (squee) #:export (select-build-stats select-builds-with-context + select-builds-with-context-by-derivation-id select-build-by-build-server-and-id insert-build ensure-build-exists)) @@ -42,6 +43,25 @@ (exec-query conn query)) +(define (select-builds-with-context-by-derivation-id conn derivation-id) + (define query + (string-append + "SELECT builds.id, build_servers.url, " + "latest_build_status.status_fetched_at, latest_build_status.starttime, " + "latest_build_status.stoptime, latest_build_status.status " + "FROM builds " + "INNER JOIN build_servers ON build_servers.id = builds.build_server_id " + "INNER JOIN " + "(SELECT DISTINCT ON (internal_build_id) * " + "FROM build_status " + "ORDER BY internal_build_id, status_fetched_at DESC" + ") AS latest_build_status " + "ON latest_build_status.internal_build_id = builds.internal_id " + "WHERE builds.derivation_id = $1 " + "ORDER BY latest_build_status.status_fetched_at DESC ")) + + (exec-query conn query (list derivation-id))) + (define (select-build-by-build-server-and-id conn build-server-id id) (exec-query conn diff --git a/guix-data-service/model/derivation.scm b/guix-data-service/model/derivation.scm index 05c9e95..305c260 100644 --- a/guix-data-service/model/derivation.scm +++ b/guix-data-service/model/derivation.scm @@ -9,6 +9,8 @@ #:use-module (guix-data-service model utils) #:export (select-derivation-by-file-name select-derivation-outputs-by-derivation-id + select-derivation-by-output-filename + select-derivations-using-output select-derivation-inputs-by-derivation-id select-existing-derivations select-derivations-by-id @@ -34,6 +36,32 @@ ",") ")")) +(define (select-derivation-by-output-filename conn filename) + (define query + (string-append + "SELECT derivations.file_name, derivation_outputs.id " + "FROM derivation_output_details " + "INNER JOIN derivation_outputs" + " ON derivation_output_details.id = derivation_outputs.derivation_output_details_id " + "INNER JOIN derivations" + " ON derivation_outputs.derivation_id = derivations.id " + "WHERE derivation_output_details.path = $1")) + + (exec-query conn query (list filename))) + +(define (select-derivations-using-output conn output-id) + (define query + (string-append + "SELECT derivations.file_name " + "FROM derivations " + "INNER JOIN derivation_inputs" + " ON derivation_inputs.derivation_id = derivations.id " + "WHERE derivation_output_id = $1 " + "ORDER BY derivations.file_name " + "LIMIT 100 ")) + + (exec-query conn query (list output-id))) + (define (insert-derivation-outputs conn derivation-id names-and-derivation-outputs) diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm index 0a2047e..9f436dc 100644 --- a/guix-data-service/web/controller.scm +++ b/guix-data-service/web/controller.scm @@ -210,17 +210,31 @@ (first derivation))) (derivation-outputs (select-derivation-outputs-by-derivation-id conn - (first derivation)))) + (first derivation))) + (builds (select-builds-with-context-by-derivation-id + conn + (first derivation)))) (apply render-html (view-derivation derivation derivation-inputs - derivation-outputs))) + derivation-outputs + builds))) #f ;; TODO ))) (define (render-store-item conn filename) - (apply render-html - (view-store-item filename))) + (let ((derivation (select-derivation-by-output-filename conn filename))) + (match derivation + (() + #f) + ((derivation) + (apply render-html + (view-store-item filename + derivation + (match derivation + ((file-name output-id rest ...) + (select-derivations-using-output + conn output-id))))))))) (define (controller request body conn) (match-lambda @@ -237,6 +251,11 @@ (view-revision commit-hash (select-packages-in-revision conn commit-hash)))) + ((GET "revision" commit-hash "package" name version) + (apply render-html + (view-revision-package-and-version commit-hash + name + version))) ((GET "gnu" "store" filename) (if (string-suffix? ".drv" filename) (render-derivation conn (string-append "/gnu/store/" filename)) diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm index 62bb828..c7c353a 100644 --- a/guix-data-service/web/view/html.scm +++ b/guix-data-service/web/view/html.scm @@ -24,6 +24,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) #:export (index + view-revision-package-and-version view-revision view-builds view-derivation @@ -144,7 +145,9 @@ ((id url commit store_path) `(tr (td ,url) - (td (samp ,commit))))) + (td (a (@ (href ,(string-append + "/revision/" commit))) + (samp ,commit)))))) guix-revisions))))) (div (@ (class "row")) @@ -168,6 +171,18 @@ (td ,source)))) queued-guix-revisions))))))))) +(define (view-revision-package-and-version revision-commit-hash name version) + (layout + #:extra-headers + '((cache-control . ((max-age . 60)))) + #:body + `(,(header) + (div + (@ (class "container")) + (div + (@ (class "row")) + (h1 "Package " ,name " @ " ,version)))))) + (define (view-revision commit-hash packages) (layout #:extra-headers @@ -187,13 +202,16 @@ (thead (tr (th (@ (class "col-md-3")) "Name") - (th (@ (class "col-md-9")) "Version"))) + (th (@ (class "col-md-3")) "Version"))) (tbody ,@(map (match-lambda ((name version rest ...) `(tr - (td ,name) + (td (a (@ (href ,(string-append + "/revision/" commit-hash + "/package/" name "/" version))) + ,name)) (td ,version)))) packages)))))))) @@ -258,7 +276,7 @@ (define (display-store-item-short item) `((span (@ (style "font-size: small; font-family: monospace; display: block;")) ,(string-take item 44)) - (span (@ (style "font-size: x-large; font-family: monospace;")) + (span (@ (style "font-size: x-large; font-family: monospace; display: block;")) ,(string-drop item 44)))) (define (display-store-item item) @@ -267,7 +285,22 @@ (span (@ (style "font-size: x-large; font-family: monospace;")) ,(string-drop item 44)))) -(define (view-store-item filename) +(define (display-store-item-title item) + `(h1 (span (@ (style "font-size: 1em; font-family: monospace; display: block;")) + ,(string-take item 44)) + (span (@ (style "line-height: 1.7em; font-size: 1.5em; font-family: monospace;")) + ,(string-drop item 44)))) + +(define (display-file-in-store-item filename) + (match (string-split filename #\/) + (("" "gnu" "store" item fileparts ...) + `(,(let ((full-item (string-append "/gnu/store/" item))) + `(a (@ (href ,full-item)) + ,(display-store-item-short full-item))) + ,(string-append + "/" (string-join fileparts "/")))))) + +(define (view-store-item filename derivation derivations-using-store-item) (layout #:extra-headers '((cache-control . ((max-age . 60)))) @@ -277,9 +310,32 @@ (@ (class "container")) (div (@ (class "row")) - (h1 (samp ,filename))))))) + ,(display-store-item-title filename)) + (div + (@ (class "row")) + (h4 "Derivation: ") + ,(match derivation + ((file-name output-id) + `(a (@ (href ,file-name)) + ,(display-store-item file-name))))) + (div + (@ (class "row")) + (h2 "Derivations using this store item " + ,(let ((count (length derivations-using-store-item))) + (if (eq? count 100) + "(> 100)" + (simple-format #f "(~A)" count)))) + (ul + (@ (class "list-unstyled")) + ,(map + (match-lambda + ((file-name) + `(li (a (@ (href ,file-name)) + ,(display-store-item file-name))))) + derivations-using-store-item))))))) -(define (view-derivation derivation derivation-inputs derivation-outputs) +(define (view-derivation derivation derivation-inputs derivation-outputs + builds) (layout #:extra-headers '((cache-control . ((max-age . 60)))) @@ -291,7 +347,7 @@ ((id file-name builder args env-vars system) `(div (@ (class "row")) - (h1 "Derivation " (samp ,file-name))))) + ,(display-store-item-title file-name)))) (div (@ (class "row")) (div @@ -311,7 +367,31 @@ derivation-inputs)))) (div (@ (class "col-md-4")) - "Details") + (h3 "Derivation details") + ,(match derivation + ((id file-name builder args env-vars system) + `(table + (@ (class "table")) + (tbody + (tr + (td "Builder") + (td (a (@ (href ,builder)) + ,(display-file-in-store-item builder)))) + (tr + (td "System") + (td (samp ,system))))))) + (h3 "Build status") + ,@(map + (match-lambda + ((build-id build-server-url status-fetched-at + starttime stoptime status) + `(div + (@ (class "text-center")) + (div ,status) + (a (@ (href ,(simple-format + #f "~Abuild/~A" build-server-url build-id))) + "View build on " ,build-server-url)))) + builds)) (div (@ (class "col-md-4")) (h3 "Outputs")