Add a basic derivation comparison page
This commit is contained in:
parent
edb21317a6
commit
e31f370de0
4 changed files with 514 additions and 1 deletions
|
|
@ -4,8 +4,11 @@
|
|||
#:use-module (ice-9 vlist)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (squee)
|
||||
#:use-module (guix-data-service model utils)
|
||||
#:use-module (guix-data-service model derivation)
|
||||
#:export (package-data->package-data-vhashes
|
||||
#:export (derivation-differences-data
|
||||
|
||||
package-data->package-data-vhashes
|
||||
package-differences-data
|
||||
package-data-vhash->derivations
|
||||
package-data->names-and-versions
|
||||
|
|
@ -17,6 +20,218 @@
|
|||
|
||||
lint-warning-differences-data))
|
||||
|
||||
(define (group-to-alist process lst)
|
||||
(fold (lambda (element result)
|
||||
(match (process element)
|
||||
((key . value)
|
||||
(match (assoc key result)
|
||||
((_ . existing-values)
|
||||
`((,key . ,(cons value existing-values))
|
||||
,@result))
|
||||
(#f
|
||||
`((,key . (,value))
|
||||
,@result))))))
|
||||
'()
|
||||
lst))
|
||||
|
||||
(define (derivation-differences-data conn
|
||||
base-derivation-file-name
|
||||
target-derivation-file-name)
|
||||
(define base-derivation
|
||||
(select-derivation-by-file-name conn base-derivation-file-name))
|
||||
|
||||
(define target-derivation
|
||||
(select-derivation-by-file-name conn target-derivation-file-name))
|
||||
|
||||
(define group-by-last-element
|
||||
(lambda (vals)
|
||||
(let ((groups (last vals)))
|
||||
(cons (if (eq? (length groups) 2)
|
||||
'common
|
||||
(first groups))
|
||||
(drop-right vals 1)))))
|
||||
|
||||
(define (fetch-value alist key)
|
||||
(assq-ref (find (lambda (env-var)
|
||||
(if (string=? key (assq-ref env-var 'key))
|
||||
(assq-ref env-var 'value)
|
||||
#f))
|
||||
alist)
|
||||
'value))
|
||||
|
||||
`((outputs
|
||||
. ,(group-to-alist
|
||||
group-by-last-element
|
||||
(derivation-outputs-differences-data conn
|
||||
(first base-derivation)
|
||||
(first target-derivation))))
|
||||
(inputs
|
||||
. ,(group-to-alist
|
||||
group-by-last-element
|
||||
(derivation-inputs-differences-data conn
|
||||
(first base-derivation)
|
||||
(first target-derivation))))
|
||||
(sources
|
||||
. ,(group-to-alist
|
||||
group-by-last-element
|
||||
(derivation-sources-differences-data conn
|
||||
(first base-derivation)
|
||||
(first target-derivation))))
|
||||
,@(match base-derivation
|
||||
((_ _ base-builder base-args base-env-vars base-system)
|
||||
(match target-derivation
|
||||
((_ _ target-builder target-args target-env-vars target-system)
|
||||
`((system
|
||||
. ,(if (string=? base-system target-system)
|
||||
`((common . ,base-system))
|
||||
`((base . ,base-system)
|
||||
(target . ,target-system))))
|
||||
(builder
|
||||
. ,(if (string=? base-builder target-builder)
|
||||
`((common . ,base-builder))
|
||||
`((base . ,base-builder)
|
||||
(target . ,target-builder))))
|
||||
(arguments
|
||||
. ,(if (eq? base-args target-args)
|
||||
`((common . ,base-args))
|
||||
`((base . ,base-args)
|
||||
(target . ,target-args))))
|
||||
(environment-variables
|
||||
. ,(map (lambda (key)
|
||||
(let ((base-value (fetch-value base-env-vars key))
|
||||
(target-value (fetch-value target-env-vars key)))
|
||||
(if (and base-value target-value)
|
||||
`(,key
|
||||
. ,(if (string=? base-value target-value)
|
||||
`((common . ,base-value))
|
||||
`((base . ,base-value)
|
||||
(target . ,target-value))))
|
||||
(if base-value
|
||||
`(,key . ((base . ,base-value)))
|
||||
`(,key . ((target . ,target-value)))))))
|
||||
(delete-duplicates
|
||||
(map (lambda (env-var)
|
||||
(assq-ref env-var 'key))
|
||||
(append base-env-vars
|
||||
target-env-vars))
|
||||
string=?))))))))))
|
||||
|
||||
(define (derivation-outputs-differences-data conn
|
||||
base-derivation-id
|
||||
target-derivation-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,
|
||||
ARRAY_AGG(derivation_outputs.derivation_id) AS derivation_ids
|
||||
FROM derivation_outputs
|
||||
INNER JOIN derivation_output_details
|
||||
ON derivation_output_details_id = derivation_output_details.id
|
||||
WHERE derivation_outputs.derivation_id IN ("
|
||||
(simple-format #f "~A,~A"
|
||||
base-derivation-id
|
||||
target-derivation-id) "
|
||||
)
|
||||
GROUP BY 1, 2, 3, 4, 5"))
|
||||
|
||||
(map (match-lambda
|
||||
((output-name path hash-algorithm hash recursive
|
||||
derivation_ids)
|
||||
(let ((parsed-derivation-ids
|
||||
(map string->number
|
||||
(parse-postgresql-array-string derivation_ids))))
|
||||
(list output-name
|
||||
path
|
||||
hash-algorithm
|
||||
hash
|
||||
recursive
|
||||
(append (if (memq base-derivation-id
|
||||
parsed-derivation-ids)
|
||||
'(base)
|
||||
'())
|
||||
(if (memq target-derivation-id
|
||||
parsed-derivation-ids)
|
||||
'(target)
|
||||
'()))))))
|
||||
(exec-query conn query)))
|
||||
|
||||
(define (derivation-inputs-differences-data conn
|
||||
base-derivation-id
|
||||
target-derivation-id)
|
||||
(define query
|
||||
(string-append
|
||||
"
|
||||
SELECT derivations.file_name,
|
||||
derivation_outputs.name,
|
||||
relevant_derivation_inputs.derivation_ids
|
||||
FROM derivation_outputs
|
||||
INNER JOIN (
|
||||
SELECT derivation_output_id,
|
||||
ARRAY_AGG(derivation_id) AS derivation_ids
|
||||
FROM derivation_inputs
|
||||
WHERE derivation_id IN (" (simple-format #f "~A,~A"
|
||||
base-derivation-id
|
||||
target-derivation-id)
|
||||
") GROUP BY derivation_output_id
|
||||
) AS relevant_derivation_inputs
|
||||
ON derivation_outputs.id = relevant_derivation_inputs.derivation_output_id
|
||||
INNER JOIN derivations ON derivation_outputs.derivation_id = derivations.id
|
||||
"))
|
||||
|
||||
(map (match-lambda
|
||||
((derivation_file_name derivation_output_name
|
||||
derivation_ids)
|
||||
(let ((parsed-derivation-ids
|
||||
(map string->number
|
||||
(parse-postgresql-array-string derivation_ids))))
|
||||
(list derivation_file_name
|
||||
derivation_output_name
|
||||
(append (if (memq base-derivation-id
|
||||
parsed-derivation-ids)
|
||||
'(base)
|
||||
'())
|
||||
(if (memq target-derivation-id
|
||||
parsed-derivation-ids)
|
||||
'(target)
|
||||
'()))))))
|
||||
(exec-query conn query)))
|
||||
|
||||
(define (derivation-sources-differences-data conn
|
||||
base-derivation-id
|
||||
target-derivation-id)
|
||||
(define query
|
||||
(string-append
|
||||
"
|
||||
SELECT derivation_source_files.store_path, ARRAY_AGG(derivation_sources.derivation_id)
|
||||
FROM derivation_source_files
|
||||
INNER JOIN derivation_sources
|
||||
ON derivation_source_files.id = derivation_sources.derivation_source_file_id
|
||||
WHERE derivation_sources.derivation_id IN (" (simple-format #f "~A,~A"
|
||||
base-derivation-id
|
||||
target-derivation-id)
|
||||
")
|
||||
GROUP BY derivation_source_files.store_path"))
|
||||
|
||||
(map (match-lambda
|
||||
((store_path derivation_ids)
|
||||
(let ((parsed-derivation-ids
|
||||
(map string->number
|
||||
(parse-postgresql-array-string derivation_ids))))
|
||||
(list store_path
|
||||
(append (if (memq base-derivation-id
|
||||
parsed-derivation-ids)
|
||||
'(base)
|
||||
'())
|
||||
(if (memq target-derivation-id
|
||||
parsed-derivation-ids)
|
||||
'(target)
|
||||
'()))))))
|
||||
(exec-query conn query)))
|
||||
|
||||
(define* (package-differences-data conn
|
||||
base_guix_revision_id
|
||||
target_guix_revision_id
|
||||
|
|
|
|||
|
|
@ -53,6 +53,13 @@
|
|||
(make-invalid-query-parameter
|
||||
s "unknown commit"))))
|
||||
|
||||
(define (parse-derivation conn)
|
||||
(lambda (file-name)
|
||||
(if (select-derivation-by-file-name conn file-name)
|
||||
file-name
|
||||
(make-invalid-query-parameter
|
||||
file-name "unknown derivation"))))
|
||||
|
||||
(define (compare-controller request
|
||||
method-and-path-components
|
||||
mime-types
|
||||
|
|
@ -79,6 +86,15 @@
|
|||
(render-compare-by-datetime mime-types
|
||||
conn
|
||||
parsed-query-parameters)))
|
||||
(('GET "compare" "derivation")
|
||||
(let* ((parsed-query-parameters
|
||||
(parse-query-parameters
|
||||
request
|
||||
`((base_derivation ,(parse-derivation conn) #:required)
|
||||
(target_derivation ,(parse-derivation conn) #:required)))))
|
||||
(render-compare/derivation mime-types
|
||||
conn
|
||||
parsed-query-parameters)))
|
||||
(('GET "compare" "derivations")
|
||||
(let* ((parsed-query-parameters
|
||||
(parse-query-parameters
|
||||
|
|
@ -287,6 +303,42 @@
|
|||
lint-warnings-data)
|
||||
#:extra-headers http-headers-for-unchanging-content)))))))))
|
||||
|
||||
(define (render-compare/derivation mime-types
|
||||
conn
|
||||
query-parameters)
|
||||
(if (any-invalid-query-parameters? query-parameters)
|
||||
(case (most-appropriate-mime-type
|
||||
'(application/json text/html)
|
||||
mime-types)
|
||||
((application/json)
|
||||
(render-json
|
||||
'((error . "invalid query"))))
|
||||
(else
|
||||
(render-html
|
||||
#:sxml (compare/derivation
|
||||
query-parameters
|
||||
'()))))
|
||||
|
||||
(let ((base-derivation (assq-ref query-parameters 'base_derivation))
|
||||
(target-derivation (assq-ref query-parameters 'target_derivation)))
|
||||
(let ((data
|
||||
(derivation-differences-data conn
|
||||
base-derivation
|
||||
target-derivation)))
|
||||
(case (most-appropriate-mime-type
|
||||
'(application/json text/html)
|
||||
mime-types)
|
||||
((application/json)
|
||||
(render-json
|
||||
'((error . "unimplemented")) ; TODO
|
||||
#:extra-headers http-headers-for-unchanging-content))
|
||||
(else
|
||||
(render-html
|
||||
#:sxml (compare/derivation
|
||||
query-parameters
|
||||
data)
|
||||
#:extra-headers http-headers-for-unchanging-content)))))))
|
||||
|
||||
(define (render-compare/derivations mime-types
|
||||
conn
|
||||
query-parameters)
|
||||
|
|
|
|||
|
|
@ -22,6 +22,7 @@
|
|||
#:use-module (guix-data-service web query-parameters)
|
||||
#:use-module (guix-data-service web view html)
|
||||
#:export (compare
|
||||
compare/derivation
|
||||
compare/derivations
|
||||
compare-by-datetime/derivations
|
||||
compare/packages
|
||||
|
|
@ -232,6 +233,250 @@
|
|||
warnings))))))
|
||||
lint-warnings-data))))))))
|
||||
|
||||
(define (compare/derivation query-parameters data)
|
||||
(define base
|
||||
'(span (@ (class "text-danger glyphicon glyphicon-minus pull-left")
|
||||
(style "font-size: 1.5em; padding-right: 0.4em;"))))
|
||||
|
||||
(define target
|
||||
'(span (@ (class "text-success glyphicon glyphicon-plus pull-left")
|
||||
(style "font-size: 1.5em; padding-right: 0.4em;"))))
|
||||
|
||||
(layout
|
||||
#:body
|
||||
`(,(header)
|
||||
(div
|
||||
(@ (class "container"))
|
||||
(div
|
||||
(@ (class "row"))
|
||||
(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
|
||||
(@ (class "col-md-12"))
|
||||
(div
|
||||
(@ (class "well"))
|
||||
(form
|
||||
(@ (method "get")
|
||||
(action "")
|
||||
(class "form-horizontal"))
|
||||
,(form-horizontal-control
|
||||
"Base derivation" query-parameters
|
||||
#:required? #t
|
||||
#:help-text "The derivation to use as the basis for the comparison."
|
||||
#:font-family "monospace")
|
||||
,(form-horizontal-control
|
||||
"Target derivation" query-parameters
|
||||
#:required? #t
|
||||
#:help-text "The derivation to compare against the base commit."
|
||||
#:font-family "monospace")
|
||||
(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 ,(let ((query-parameter-string
|
||||
(query-parameters->string query-parameters)))
|
||||
(string-append
|
||||
"/compare/derivation.json"
|
||||
(if (string-null? query-parameter-string)
|
||||
""
|
||||
(string-append "?" query-parameter-string))))))
|
||||
"View JSON")))))
|
||||
(div
|
||||
(@ (class "row"))
|
||||
(div
|
||||
(@ (class "col-sm-12"))
|
||||
(h2 "Outputs")
|
||||
,@(let ((outputs (assq-ref data 'outputs)))
|
||||
`((table
|
||||
(@ (class "table"))
|
||||
(thead
|
||||
(tr
|
||||
(th "")
|
||||
(th "Name")
|
||||
(th "Path")
|
||||
(th "Hash algorithm")
|
||||
(th "Hash")
|
||||
(th "Recursive")))
|
||||
(tbody
|
||||
,@(let ((base-outputs (assq-ref outputs 'base))
|
||||
(target-outputs (assq-ref outputs 'target))
|
||||
(common-outputs (assq-ref outputs 'common)))
|
||||
(append-map
|
||||
(lambda (label items)
|
||||
(map
|
||||
(match-lambda
|
||||
((name path hash-algorithm hash recursive)
|
||||
`(tr
|
||||
(td ,label)
|
||||
(td ,name)
|
||||
(td (a (@ (href ,path))
|
||||
,(display-store-item path)))
|
||||
(td ,hash-algorithm)
|
||||
(td ,hash)
|
||||
(td ,recursive))))
|
||||
(or items '())))
|
||||
(list base target "Common")
|
||||
(list (assq-ref outputs 'base)
|
||||
(assq-ref outputs 'target)
|
||||
(assq-ref outputs 'common))))))))
|
||||
(h2 "Inputs")
|
||||
,@(let ((inputs (assq-ref data 'inputs)))
|
||||
`((table
|
||||
(@ (class "table"))
|
||||
(thead
|
||||
(tr
|
||||
(th "")
|
||||
(th "Derivation")
|
||||
(th "Outputs")))
|
||||
(tbody
|
||||
,@(append-map
|
||||
(lambda (label items)
|
||||
(map
|
||||
(match-lambda
|
||||
((derivation outputs)
|
||||
`(tr
|
||||
(td ,label)
|
||||
(td (a (@ (href ,derivation))
|
||||
,(display-store-item derivation)))
|
||||
(td ,outputs))))
|
||||
(or items '())))
|
||||
(list base target)
|
||||
(list (assq-ref inputs 'base)
|
||||
(assq-ref inputs 'target)))))))
|
||||
(p "Common inputs are omitted.")
|
||||
(h2 "Sources")
|
||||
,@(let ((sources (assq-ref data 'sources)))
|
||||
`((table
|
||||
(@ (class "table"))
|
||||
(thead
|
||||
(tr
|
||||
(th "")
|
||||
(th "Derivation")))
|
||||
(tbody
|
||||
,@(append-map
|
||||
(lambda (label items)
|
||||
(map
|
||||
(match-lambda
|
||||
((file)
|
||||
`(tr
|
||||
(td ,label)
|
||||
(td (a (@ (href ,file))
|
||||
,(display-store-item file))))))
|
||||
(or items '())))
|
||||
(list base target "Common")
|
||||
(list (assq-ref sources 'base)
|
||||
(assq-ref sources 'target)
|
||||
(assq-ref sources 'common)))))))
|
||||
(h2 "System")
|
||||
,@(let ((system (assq-ref data 'system)))
|
||||
(let ((common-system (assq-ref system 'common)))
|
||||
(if common-system
|
||||
(list common-system)
|
||||
`(table
|
||||
(@ (class "table"))
|
||||
(thead
|
||||
(tr
|
||||
(th "")
|
||||
(th "System")))
|
||||
(tbody
|
||||
,@(let ((base-system (assq-ref system 'base))
|
||||
(target-system (assq-ref system 'target)))
|
||||
`((tr
|
||||
(td ,base)
|
||||
(td ,base-system))
|
||||
(tr
|
||||
(td ,target)
|
||||
(td ,target-system)))))))))
|
||||
(h2 "Builder and arguments")
|
||||
,(let ((builder (assq-ref data 'builder))
|
||||
(arguments (assq-ref data 'arguments)))
|
||||
(let ((common-builder (assq-ref builder 'common))
|
||||
(common-args (assq-ref arguments 'common)))
|
||||
(if (and common-builder
|
||||
common-args)
|
||||
`(table
|
||||
(@ (class "table"))
|
||||
(thead
|
||||
(th "Builder")
|
||||
(th "Arguments"))
|
||||
(tbody
|
||||
(tr
|
||||
(td ,common-builder)
|
||||
(td (ol
|
||||
,@(map (lambda (arg)
|
||||
`(li ,arg))
|
||||
common-args))))))
|
||||
`(table
|
||||
(@ (class "table"))
|
||||
(thead
|
||||
(tr
|
||||
(th "")
|
||||
(th "Builder")
|
||||
(th "Arguments")))
|
||||
(tbody
|
||||
,@(let ((base-builder (assq-ref builder 'base))
|
||||
(target-builder (assq-ref builder 'target))
|
||||
(base-args (assq-ref arguments 'base))
|
||||
(target-args (assq-ref arguments 'target)))
|
||||
`((tr
|
||||
(td ,base)
|
||||
(td ,(or base-builder
|
||||
common-builder))
|
||||
(td (ol
|
||||
,@(map (lambda (arg)
|
||||
`(li ,arg))
|
||||
(or common-args
|
||||
base-args)))))
|
||||
(tr
|
||||
(td ,target)
|
||||
(td ,(or target-builder
|
||||
common-builder))
|
||||
(td (ol
|
||||
,@(map (lambda (arg)
|
||||
`(li ,arg))
|
||||
(or common-args
|
||||
target-args))))))))))))
|
||||
(h2 "Environment variables")
|
||||
,(let ((environment-variables (assq-ref data 'environment-variables)))
|
||||
`(table
|
||||
(@ (class "table"))
|
||||
(thead
|
||||
(th "Name"))
|
||||
(tbody
|
||||
,@(append-map
|
||||
(match-lambda
|
||||
((name . values)
|
||||
(let ((common-value (assq-ref values 'common)))
|
||||
(if common-value
|
||||
`((tr
|
||||
(td ,name)
|
||||
(td ,common-value)))
|
||||
(let ((base-value (assq-ref values 'base))
|
||||
(target-value (assq-ref values 'target)))
|
||||
(if (and base-value target-value)
|
||||
`((tr
|
||||
(td (@ (rowspan 2))
|
||||
,name)
|
||||
(td ,base ,base-value))
|
||||
(tr
|
||||
(td ,target ,target-value)))
|
||||
`((tr
|
||||
(td ,name)
|
||||
(td ,@(if base-value
|
||||
(list base base-value)
|
||||
(list target target-value)))))))))))
|
||||
environment-variables))))))))))
|
||||
|
||||
(define (compare/derivations query-parameters
|
||||
valid-systems
|
||||
valid-build-statuses
|
||||
|
|
|
|||
|
|
@ -32,6 +32,7 @@
|
|||
header
|
||||
form-horizontal-control
|
||||
|
||||
display-store-item
|
||||
display-store-item-short
|
||||
build-status-span
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue