mirror of
git://git.savannah.gnu.org/guix/data-service.git
synced 2023-12-14 03:23:03 +01:00
Add a packages comparison page
The primary use I have in mind for this is producing a list of strings suitable for building a limited Cuirass job with.
This commit is contained in:
parent
31737d32f9
commit
2836a848cb
|
@ -18,6 +18,7 @@
|
||||||
|
|
||||||
(define-module (guix-data-service web controller)
|
(define-module (guix-data-service web controller)
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
|
#:use-module (ice-9 vlist)
|
||||||
#:use-module (ice-9 pretty-print)
|
#:use-module (ice-9 pretty-print)
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
#:use-module (srfi srfi-11)
|
#:use-module (srfi srfi-11)
|
||||||
|
@ -163,6 +164,40 @@
|
||||||
base-derivations
|
base-derivations
|
||||||
target-derivations)))))))
|
target-derivations)))))))
|
||||||
|
|
||||||
|
(define (render-compare/packages content-type
|
||||||
|
conn
|
||||||
|
base-commit
|
||||||
|
base-revision-id
|
||||||
|
target-commit
|
||||||
|
target-revision-id)
|
||||||
|
(define (package-data-vhash->json vh)
|
||||||
|
(vhash-fold (lambda (name data result)
|
||||||
|
(cons (string-append name "@" (car data))
|
||||||
|
result))
|
||||||
|
'()
|
||||||
|
vh))
|
||||||
|
|
||||||
|
(let-values
|
||||||
|
(((base-packages-vhash target-packages-vhash)
|
||||||
|
(package-data->package-data-vhashes
|
||||||
|
(package-differences-data conn
|
||||||
|
base-revision-id
|
||||||
|
target-revision-id))))
|
||||||
|
(cond
|
||||||
|
((eq? content-type 'json)
|
||||||
|
(render-json
|
||||||
|
`((base . ((commit . ,base-commit)
|
||||||
|
(packages . ,(package-data-vhash->json base-packages-vhash))))
|
||||||
|
(target . ((commit . ,target-commit)
|
||||||
|
(packages . ,(package-data-vhash->json target-packages-vhash)))))))
|
||||||
|
(else
|
||||||
|
(apply render-html
|
||||||
|
(compare/packages
|
||||||
|
base-commit
|
||||||
|
target-commit
|
||||||
|
base-packages-vhash
|
||||||
|
target-packages-vhash))))))
|
||||||
|
|
||||||
(define (controller request body conn)
|
(define (controller request body conn)
|
||||||
(match-lambda
|
(match-lambda
|
||||||
((GET)
|
((GET)
|
||||||
|
@ -235,5 +270,39 @@
|
||||||
base-revision-id
|
base-revision-id
|
||||||
target-commit
|
target-commit
|
||||||
target-revision-id)))))
|
target-revision-id)))))
|
||||||
|
((GET "compare" "packages")
|
||||||
|
(with-base-and-target-commits
|
||||||
|
request conn
|
||||||
|
(lambda (base-commit base-revision-id target-commit target-revision-id)
|
||||||
|
(if (not (and base-revision-id target-revision-id))
|
||||||
|
(render-compare-unknown-commit 'html
|
||||||
|
conn
|
||||||
|
base-commit
|
||||||
|
base-revision-id
|
||||||
|
target-commit
|
||||||
|
target-revision-id)
|
||||||
|
(render-compare/packages 'html
|
||||||
|
conn
|
||||||
|
base-commit
|
||||||
|
base-revision-id
|
||||||
|
target-commit
|
||||||
|
target-revision-id)))))
|
||||||
|
((GET "compare" "packages.json")
|
||||||
|
(with-base-and-target-commits
|
||||||
|
request conn
|
||||||
|
(lambda (base-commit base-revision-id target-commit target-revision-id)
|
||||||
|
(if (not (and base-revision-id target-revision-id))
|
||||||
|
(render-compare-unknown-commit 'json
|
||||||
|
conn
|
||||||
|
base-commit
|
||||||
|
base-revision-id
|
||||||
|
target-commit
|
||||||
|
target-revision-id)
|
||||||
|
(render-compare/packages 'json
|
||||||
|
conn
|
||||||
|
base-commit
|
||||||
|
base-revision-id
|
||||||
|
target-commit
|
||||||
|
target-revision-id)))))
|
||||||
((GET path ...)
|
((GET path ...)
|
||||||
(render-static-asset request))))
|
(render-static-asset request))))
|
||||||
|
|
|
@ -19,12 +19,14 @@
|
||||||
|
|
||||||
(define-module (guix-data-service web view html)
|
(define-module (guix-data-service web view html)
|
||||||
#:use-module (guix-data-service config)
|
#:use-module (guix-data-service config)
|
||||||
|
#:use-module (ice-9 vlist)
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
#:use-module (srfi srfi-19)
|
#:use-module (srfi srfi-19)
|
||||||
#:export (index
|
#:export (index
|
||||||
compare
|
compare
|
||||||
compare/derivations
|
compare/derivations
|
||||||
|
compare/packages
|
||||||
compare-unknown-commit
|
compare-unknown-commit
|
||||||
error-page))
|
error-page))
|
||||||
|
|
||||||
|
@ -275,6 +277,58 @@
|
||||||
(td ,file-name))))
|
(td ,file-name))))
|
||||||
target-derivations)))))))
|
target-derivations)))))))
|
||||||
|
|
||||||
|
(define (compare/packages base-commit
|
||||||
|
target-commit
|
||||||
|
base-packages-vhash
|
||||||
|
target-packages-vhash)
|
||||||
|
(layout
|
||||||
|
#:extra-headers
|
||||||
|
'((cache-control . ((max-age . 60))))
|
||||||
|
#:body
|
||||||
|
`(,(header)
|
||||||
|
(div
|
||||||
|
(@ (class "container"))
|
||||||
|
(h1 "Comparing "
|
||||||
|
(samp ,(string-take base-commit 8) "…")
|
||||||
|
" and "
|
||||||
|
(samp ,(string-take target-commit 8) "…"))
|
||||||
|
(h3 "Base ("
|
||||||
|
(samp ,base-commit)
|
||||||
|
")")
|
||||||
|
(p "Packages found in the base revision.")
|
||||||
|
(table
|
||||||
|
(@ (class "table"))
|
||||||
|
(thead
|
||||||
|
(tr
|
||||||
|
(th (@ (class "col-md-6")) "Name")
|
||||||
|
(th (@ (class "col-md-6")) "Version")))
|
||||||
|
(tbody
|
||||||
|
,@(map
|
||||||
|
(match-lambda
|
||||||
|
((name version rest ...)
|
||||||
|
`(tr
|
||||||
|
(td ,name)
|
||||||
|
(td ,version))))
|
||||||
|
(vlist->list base-packages-vhash))))
|
||||||
|
(h3 "Target ("
|
||||||
|
(samp ,target-commit)
|
||||||
|
")")
|
||||||
|
(p "Packages found in the target revision.")
|
||||||
|
(table
|
||||||
|
(@ (class "table"))
|
||||||
|
(thead
|
||||||
|
(tr
|
||||||
|
(th (@ (class "col-md-6")) "Name")
|
||||||
|
(th (@ (class "col-md-6")) "Version")))
|
||||||
|
(tbody
|
||||||
|
,@(map
|
||||||
|
(match-lambda
|
||||||
|
((name version rest ...)
|
||||||
|
`(tr
|
||||||
|
(td ,name)
|
||||||
|
(td ,version))))
|
||||||
|
(vlist->list target-packages-vhash))))))))
|
||||||
|
|
||||||
(define (compare-unknown-commit base-commit target-commit
|
(define (compare-unknown-commit base-commit target-commit
|
||||||
base-exists? target-exists?
|
base-exists? target-exists?
|
||||||
base-job target-job)
|
base-job target-job)
|
||||||
|
|
Loading…
Reference in a new issue