Start to visualise derivations
This commit is contained in:
parent
891cf42fc6
commit
8f4da3c872
|
@ -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 "
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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))))))))
|
||||
|
||||
|
|
Loading…
Reference in New Issue