guix
/
data-service
mirror of git://git.savannah.gnu.org/guix/data-service.git
2
0
Fork 0
Code Issues Releases Wiki Activity

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:
Christopher Baines 2019-02-25 23:44:32 +00:00
parent 31737d32f9
commit 2836a848cb
No known key found for this signature in database
GPG Key ID: 5E28A33B0B84F577
2 changed files with 123 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

69
guix-data-service/web/controller.scm
View File

@ -18,6 +18,7 @@
(define-module (guix-data-service web controller)
#:use-module (ice-9 match)
#:use-module (ice-9 vlist)
#:use-module (ice-9 pretty-print)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
@ -163,6 +164,40 @@
base-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)
(match-lambda
((GET)
@ -235,5 +270,39 @@
base-revision-id
target-commit
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 ...)
(render-static-asset request))))

54
guix-data-service/web/view/html.scm
View File

@ -19,12 +19,14 @@
(define-module (guix-data-service web view html)
#:use-module (guix-data-service config)
#:use-module (ice-9 vlist)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
#:export (index
compare
compare/derivations
compare/packages
compare-unknown-commit
error-page))
@ -275,6 +277,58 @@
(td ,file-name))))
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
base-exists? target-exists?
base-job target-job)