diff options
author | Christopher Baines <mail@cbaines.net> | 2019-03-07 08:43:16 +0000 |
---|---|---|
committer | Christopher Baines <mail@cbaines.net> | 2019-03-07 08:43:16 +0000 |
commit | 8f4da3c872b9d04279e8805e61e3034db68dc539 (patch) | |
tree | fb8c709e4e6862ea5a5f6d169da65f310b08612a /guix-data-service | |
parent | 891cf42fc64febc08736a2a619ef43025433a368 (diff) | |
download | data-service-8f4da3c872b9d04279e8805e61e3034db68dc539.tar data-service-8f4da3c872b9d04279e8805e61e3034db68dc539.tar.gz |
Start to visualise derivations
Diffstat (limited to 'guix-data-service')
-rw-r--r-- | guix-data-service/model/derivation.scm | 47 | ||||
-rw-r--r-- | guix-data-service/web/controller.scm | 30 | ||||
-rw-r--r-- | guix-data-service/web/view/html.scm | 72 |
3 files changed, 140 insertions, 9 deletions
diff --git a/guix-data-service/model/derivation.scm b/guix-data-service/model/derivation.scm index a83bf97..05c9e95 100644 --- a/guix-data-service/model/derivation.scm +++ b/guix-data-service/model/derivation.scm @@ -7,7 +7,10 @@ #:use-module (guix inferior) #:use-module (guix derivations) #:use-module (guix-data-service model utils) - #:export (select-existing-derivations + #:export (select-derivation-by-file-name + select-derivation-outputs-by-derivation-id + select-derivation-inputs-by-derivation-id + select-existing-derivations select-derivations-by-id select-derivations-and-build-status-by-id insert-into-derivations @@ -122,6 +125,19 @@ derivation-output-ids)) +(define (select-derivation-by-file-name conn file-name) + (define query + (string-append + "SELECT id, file_name, builder, args, env_vars, system " + "FROM derivations " + "WHERE file_name = $1")) + + (match (exec-query conn query (list file-name)) + (() + #f) + ((result) + result))) + (define (select-derivation-output-id conn name path) (match (exec-query conn @@ -138,6 +154,35 @@ #f "cannot find derivation-output with name ~A and path ~A" name path))))) +(define (select-derivation-outputs-by-derivation-id conn id) + (define query + (string-append + "SELECT derivation_outputs.name, derivation_output_details.path, " + "derivation_output_details.hash_algorithm, derivation_output_details.hash, " + "derivation_output_details.recursive " + "FROM derivation_outputs " + "INNER JOIN derivation_output_details ON " + "derivation_outputs.derivation_output_details_id = derivation_output_details.id " + "WHERE derivation_id = $1")) + + (exec-query conn query (list id))) + +(define (select-derivation-inputs-by-derivation-id conn id) + (define query + (string-append + "SELECT derivations.file_name, derivation_outputs.name, " + "derivation_output_details.path " + "FROM derivation_inputs " + "INNER JOIN derivation_outputs" + " ON derivation_outputs.id = derivation_inputs.derivation_output_id " + "INNER JOIN derivation_output_details" + " ON derivation_outputs.derivation_output_details_id = derivation_output_details.id " + "INNER JOIN derivations" + " ON derivation_outputs.derivation_id = derivations.id " + "WHERE derivation_inputs.derivation_id = $1")) + + (exec-query conn query (list id))) + (define (insert-derivation-input conn derivation-id derivation-input) (define (insert-into-derivation-inputs output-ids) (string-append "INSERT INTO derivation_inputs " diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm index 7297dc4..0a2047e 100644 --- a/guix-data-service/web/controller.scm +++ b/guix-data-service/web/controller.scm @@ -29,6 +29,7 @@ #:use-module (guix-data-service comparison) #:use-module (guix-data-service model guix-revision) #:use-module (guix-data-service model package) + #:use-module (guix-data-service model derivation) #:use-module (guix-data-service model build) #:use-module (guix-data-service jobs load-new-guix-revision) #:use-module (guix-data-service web render) @@ -200,6 +201,27 @@ base-packages-vhash target-packages-vhash)))))) +(define (render-derivation conn derivation-file-name) + (let ((derivation (select-derivation-by-file-name conn + derivation-file-name))) + (if derivation + (let ((derivation-inputs (select-derivation-inputs-by-derivation-id + conn + (first derivation))) + (derivation-outputs (select-derivation-outputs-by-derivation-id + conn + (first derivation)))) + (apply render-html + (view-derivation derivation + derivation-inputs + derivation-outputs))) + #f ;; TODO + ))) + +(define (render-store-item conn filename) + (apply render-html + (view-store-item filename))) + (define (controller request body conn) (match-lambda ((GET) @@ -215,10 +237,10 @@ (view-revision commit-hash (select-packages-in-revision conn commit-hash)))) - ((GET "derivation" derivation-file-name ...) - (apply render-html - (view-derivation (string-append - "/" (string-join derivation-file-name "/"))))) + ((GET "gnu" "store" filename) + (if (string-suffix? ".drv" filename) + (render-derivation conn (string-append "/gnu/store/" filename)) + (render-store-item conn (string-append "/gnu/store/" filename)))) ((GET "compare") (with-base-and-target-commits request conn diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm index 81d4bec..2a09d85 100644 --- a/guix-data-service/web/view/html.scm +++ b/guix-data-service/web/view/html.scm @@ -27,6 +27,7 @@ view-revision view-builds view-derivation + view-store-item compare compare/derivations compare/packages @@ -253,7 +254,19 @@ "View build on " ,build-server-url))))) builds)))))))) -(define (view-derivation derivation-file-name) +(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;")) + ,(string-drop item 44)))) + +(define (display-store-item item) + `((span (@ (style "font-size: small; font-family: monospace;")) + ,(string-take item 44)) + (span (@ (style "font-size: x-large; font-family: monospace;")) + ,(string-drop item 44)))) + +(define (view-store-item filename) (layout #:extra-headers '((cache-control . ((max-age . 60)))) @@ -263,7 +276,56 @@ (@ (class "container")) (div (@ (class "row")) - (h1 "Derivation " (samp ,derivation-file-name))))))) + (h1 (samp ,filename))))))) + +(define (view-derivation derivation derivation-inputs derivation-outputs) + (layout + #:extra-headers + '((cache-control . ((max-age . 60)))) + #:body + `(,(header) + (div + (@ (class "container")) + ,(match derivation + ((id file-name builder args env-vars system) + `(div + (@ (class "row")) + (h1 "Derivation " (samp ,file-name))))) + (div + (@ (class "row")) + (div + (@ (class "col-md-4")) + (h3 "Inputs") + (table + (@ (class "table")) + (thead + (tr + (th "File name"))) + (tdata + ,@(map (match-lambda + ((file-name output-name path) + `(tr + (td (a (@ (href ,file-name)) + ,(display-store-item-short path)))))) + derivation-inputs)))) + (div + (@ (class "col-md-4")) + "Details") + (div + (@ (class "col-md-4")) + (h3 "Outputs") + (table + (@ (class "table")) + (thead + (tr + (th "File name"))) + (tdata + ,@(map (match-lambda + ((output-name path hash-algorithm hash recursive?) + `(tr + (td (a (@ (href ,path)) + ,(display-store-item-short path)))))) + derivation-outputs))))))))) (define (compare base-commit target-commit @@ -434,7 +496,8 @@ (match-lambda ((id file-name build-status) `(tr - (td ,file-name) + (td (a (@ (href ,file-name)) + ,(display-store-item file-name))) (td ,build-status)))) base-derivations)))) (div @@ -454,7 +517,8 @@ (match-lambda ((id file-name build-status) `(tr - (td ,file-name) + (td (a (@ (href ,file-name)) + ,(display-store-item file-name))) (td ,build-status)))) target-derivations)))))))) |