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

Many changes 

A large proportion of these changes relate to changing the way
packages relate to derivations. Previously, a package at a given
revision had a single derivation. This was OK, but didn't account for
multiple architectures.

Therefore, these changes mean that a package has multiple derivations,
depending on the system of the derivation, and the target system.

There are multiple changes, small and large to the web interface as
well. More pages link to each other, and the visual display has been
improved somewhat.
This commit is contained in:
Christopher Baines 2019-03-11 22:11:14 +00:00
parent 5bc0e7d4bf
commit e117bb1d87
No known key found for this signature in database
GPG Key ID: 5E28A33B0B84F577
11 changed files with 999 additions and 326 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
Makefile.am
View File

@ -29,24 +29,25 @@ moddir = $(prefix)/share/guile/site/$(GUILE_EFFECTIVE_VERSION)
godir = $(moddir) godir = $(moddir)
assetsdir = $(datadir)/@PACKAGE@ assetsdir = $(datadir)/@PACKAGE@
SOURCES = \ SOURCES = \
guix-data-service/builds.scm \ guix-data-service/builds.scm \
guix-data-service/comparison.scm \ guix-data-service/comparison.scm \
guix-data-service/config.scm \ guix-data-service/config.scm \
guix-data-service/jobs.scm \ guix-data-service/jobs.scm \
guix-data-service/jobs/load-new-guix-revision.scm \ guix-data-service/jobs/load-new-guix-revision.scm \
guix-data-service/model/build-server.scm \ guix-data-service/model/build-server.scm \
guix-data-service/model/build-status.scm \ guix-data-service/model/build-status.scm \
guix-data-service/model/build.scm \ guix-data-service/model/build.scm \
guix-data-service/model/derivation.scm \ guix-data-service/model/derivation.scm \
guix-data-service/model/guix-revision-package.scm \ guix-data-service/model/guix-revision-package-derivation.scm \
guix-data-service/model/guix-revision.scm \ guix-data-service/model/guix-revision.scm \
guix-data-service/model/package-metadata.scm \ guix-data-service/model/package-derivation.scm \
guix-data-service/model/package.scm \ guix-data-service/model/package-metadata.scm \
guix-data-service/model/utils.scm \ guix-data-service/model/package.scm \
guix-data-service/web/controller.scm \ guix-data-service/model/utils.scm \
guix-data-service/web/render.scm \ guix-data-service/web/controller.scm \
guix-data-service/web/server.scm \ guix-data-service/web/render.scm \
guix-data-service/web/sxml.scm \ guix-data-service/web/server.scm \
guix-data-service/web/util.scm \ guix-data-service/web/sxml.scm \
guix-data-service/web/util.scm \
guix-data-service/web/view/html.scm guix-data-service/web/view/html.scm

146
guix-data-service/comparison.scm
View File

@ -12,20 +12,56 @@
package-data-vhashes->new-packages package-data-vhashes->new-packages
package-data-vhashes->removed-packages package-data-vhashes->removed-packages
package-data-version-changes package-data-version-changes
package-data-other-changes)) package-data-derivation-changes))
(define (package-differences-data conn base_guix_revision_id target_guix_revision_id) (define (package-differences-data conn base_guix_revision_id target_guix_revision_id)
(define query (define query
"WITH base_packages AS ( "
SELECT packages.* FROM packages INNER JOIN guix_revision_packages ON packages.id = guix_revision_packages.package_id WHERE revision_id = $1 WITH base_packages AS (
SELECT packages.*, derivations.file_name,
package_derivations.system, package_derivations.target
FROM packages
INNER JOIN package_derivations
ON packages.id = package_derivations.package_id
INNER JOIN derivations
ON package_derivations.derivation_id = derivations.id
WHERE package_derivations.id IN (
SELECT guix_revision_package_derivations.package_derivation_id
FROM guix_revision_package_derivations
WHERE revision_id = $1
)
), target_packages AS ( ), target_packages AS (
SELECT packages.* FROM packages INNER JOIN guix_revision_packages ON packages.id = guix_revision_packages.package_id WHERE revision_id = $2 SELECT packages.*, derivations.file_name,
package_derivations.system, package_derivations.target
FROM packages
INNER JOIN package_derivations
ON packages.id = package_derivations.package_id
INNER JOIN derivations
ON package_derivations.derivation_id = derivations.id
WHERE package_derivations.id IN (
SELECT guix_revision_package_derivations.package_derivation_id
FROM guix_revision_package_derivations
WHERE revision_id = $2
)
) )
SELECT base_packages.name, base_packages.version, base_packages.package_metadata_id, base_packages.derivation_id, target_packages.name, target_packages.version, target_packages.package_metadata_id, target_packages.derivation_id SELECT base_packages.name, base_packages.version,
base_packages.package_metadata_id, base_packages.file_name,
base_packages.system, base_packages.target,
target_packages.name, target_packages.version,
target_packages.package_metadata_id, target_packages.file_name,
target_packages.system, target_packages.target
FROM base_packages FROM base_packages
FULL OUTER JOIN target_packages ON base_packages.name = target_packages.name AND base_packages.version = target_packages.version FULL OUTER JOIN target_packages
WHERE (base_packages.id IS NULL OR target_packages.id IS NULL OR base_packages.id != target_packages.id) ON base_packages.name = target_packages.name
ORDER BY base_packages.name, base_packages.version, target_packages.name, target_packages.version") AND base_packages.version = target_packages.version
AND base_packages.system = target_packages.system
AND base_packages.target = target_packages.target
WHERE
base_packages.id IS NULL OR
target_packages.id IS NULL OR
base_packages.id != target_packages.id OR
base_packages.file_name != target_packages.file_name
ORDER BY base_packages.name DESC, base_packages.version, target_packages.name, target_packages.version")
(exec-query conn query (list base_guix_revision_id target_guix_revision_id))) (exec-query conn query (list base_guix_revision_id target_guix_revision_id)))
@ -40,7 +76,7 @@ ORDER BY base_packages.name, base_packages.version, target_packages.name, target
(apply values (apply values
(fold (lambda (row result) (fold (lambda (row result)
(let-values (((base-row-part target-row-part) (split-at row 4))) (let-values (((base-row-part target-row-part) (split-at row 6)))
(match result (match result
((base-package-data target-package-data) ((base-package-data target-package-data)
(list (add-data-to-vhash base-row-part base-package-data) (list (add-data-to-vhash base-row-part base-package-data)
@ -63,24 +99,29 @@ ORDER BY base_packages.name, base_packages.version, target_packages.name, target
derivation-data)) derivation-data))
(define (package-data-vhash->derivations-and-build-status conn packages-vhash) (define (package-data-vhash->derivations-and-build-status conn packages-vhash)
(define (vhash->derivation-ids vhash) (define (vhash->derivation-file-names vhash)
(vhash-fold (lambda (key value result) (vhash-fold (lambda (key value result)
(cons (third value) (cons (third value)
result)) result))
'() '()
vhash)) vhash))
(let* ((derivation-ids (let* ((derivation-file-names
(vhash->derivation-ids packages-vhash)) (vhash->derivation-file-names packages-vhash))
(derivation-data (derivation-data
(select-derivations-and-build-status-by-id conn derivation-ids))) (select-derivations-and-build-status-by-file-name
conn
derivation-file-names)))
derivation-data)) derivation-data))
(define (package-data-vhash->package-name-and-version-vhash vhash) (define (package-data-vhash->package-name-and-version-vhash vhash)
(vhash-fold (lambda (name details result) (vhash-fold (lambda (name details result)
(vhash-cons (cons name (first details)) (let ((key (cons name (first details))))
(cdr details) (vhash-cons key
result)) (cons (cdr details)
(or (and=> (vhash-assoc key result) cdr)
'()))
(vhash-delete key result))))
vlist-null vlist-null
vhash)) vhash))
@ -99,16 +140,29 @@ ORDER BY base_packages.name, base_packages.version, target_packages.name, target
base-packages-vhash))) base-packages-vhash)))
(define (package-data-vhash->package-versions-vhash package-data-vhash) (define (package-data-vhash->package-versions-vhash package-data-vhash)
(define (system-and-target<? a b)
(if (string=? (car a) (car b))
(string<? (cdr a) (cdr b))
(string<? (car a) (car b))))
(define (add-version-system-and-target-to-alist alist data)
(match data
((version package-metadata-id derivation-id system target)
(let ((systems-for-version (or (and=> (assoc version alist) cdr)
'())))
`((,version . ,(sort (cons (cons system target)
systems-for-version)
system-and-target<?))
,@(alist-delete version alist))))))
(vhash-fold (lambda (name details result) (vhash-fold (lambda (name details result)
(let ((version (first details)) (let ((version (first details))
(known-versions (vhash-assoc name result))) (known-versions (or (and=> (vhash-assoc name result) cdr)
(if known-versions '())))
(vhash-cons name (vhash-cons name
(cons version known-versions) (add-version-system-and-target-to-alist known-versions
(vhash-delete name result)) details)
(vhash-cons name (vhash-delete name result))))
(list version)
result))))
vlist-null vlist-null
package-data-vhash)) package-data-vhash))
@ -124,30 +178,42 @@ ORDER BY base_packages.name, base_packages.version, target_packages.name, target
(begin (begin
(if (equal? base-versions target-versions) (if (equal? base-versions target-versions)
result result
`((,name . ((base . ,base-versions) `((,name . ((base . ,(map car base-versions))
(target . ,target-versions))) (target . ,(map car target-versions))))
,@result))) ,@result)))
result))) result)))
'() '()
target-versions))) target-versions)))
(define (package-data-other-changes base-packages-vhash target-packages-vhash) (define (package-data-derivation-changes base-packages-vhash target-packages-vhash)
(define base-package-details-by-name-and-version (define base-package-details-by-name-and-version
(package-data-vhash->package-name-and-version-vhash base-packages-vhash)) (package-data-vhash->package-name-and-version-vhash base-packages-vhash))
(define target-package-details-by-name-and-version (define target-package-details-by-name-and-version
(package-data-vhash->package-name-and-version-vhash target-packages-vhash)) (package-data-vhash->package-name-and-version-vhash target-packages-vhash))
(vhash-fold (lambda (name-and-version target-details result) (define (derivation-system-and-target-list->alist lst)
(let ((base-packages-entry (if (null? lst)
(vhash-assoc name-and-version base-package-details-by-name-and-version))) '()
(if base-packages-entry `((,(cdr (first lst)) . ,(car (first lst)))
(let ((base-details (cdr base-packages-entry))) ,@(derivation-system-and-target-list->alist (cdr lst)))))
(if (equal? base-details target-details)
result (vhash-fold
`((,name-and-version . ((base . ,base-details) (lambda (name-and-version target-packages-entry result)
(target . ,target-details))) (let ((base-packages-entry
,@result))) (vhash-assoc name-and-version
result))) base-package-details-by-name-and-version)))
'() (if base-packages-entry
target-package-details-by-name-and-version)) (let ((base-derivations (map cdr (cdr base-packages-entry)))
(target-derivations (map cdr target-packages-entry)))
(if (equal? base-derivations target-derivations)
result
`((,name-and-version
. ((base . ,(derivation-system-and-target-list->alist
base-derivations))
(target . ,(derivation-system-and-target-list->alist
target-derivations))))
,@result)))
result)))
'()
target-package-details-by-name-and-version))

117
guix-data-service/jobs/load-new-guix-revision.scm
View File

@ -7,43 +7,104 @@
#:use-module (guix channels) #:use-module (guix channels)
#:use-module (guix inferior) #:use-module (guix inferior)
#:use-module (guix profiles) #:use-module (guix profiles)
#:use-module (guix progress)
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module (guix build utils) #:use-module (guix build utils)
#:use-module (guix-data-service model package) #:use-module (guix-data-service model package)
#:use-module (guix-data-service model guix-revision) #:use-module (guix-data-service model guix-revision)
#:use-module (guix-data-service model guix-revision-package) #:use-module (guix-data-service model package-derivation)
#:use-module (guix-data-service model guix-revision-package-derivation)
#:use-module (guix-data-service model package-metadata) #:use-module (guix-data-service model package-metadata)
#:use-module (guix-data-service model derivation) #:use-module (guix-data-service model derivation)
#:export (process-next-load-new-guix-revision-job #:export (process-next-load-new-guix-revision-job
select-job-for-commit select-job-for-commit
most-recent-n-load-new-guix-revision-jobs)) most-recent-n-load-new-guix-revision-jobs))
(define (inferior-guix->package-ids store conn inf) (define (inferior-guix->package-derivation-ids store conn inf)
(define (inferior-package->systems-targets-and-derivations package)
(let ((supported-systems
(inferior-package-transitive-supported-systems package)))
(append-map
(lambda (system)
(filter-map
(lambda (target)
(catch
#t
(lambda ()
(list
system
target
(inferior-package-derivation store package system
#:target
(if (string=? system target)
#f
target))))
(lambda args
(cond
((string-contains (simple-format #f "~A" (second args))
"&package-cross-build-system-error")
#f)
((string-contains (simple-format #f "~A" (fourth args))
"(No cross-compilation for ")
#f)
(else
(simple-format
#t "guix-data-service: inferior-guix->package-ids: error processing derivation\n ~A for system ~A and target ~A\n"
package system target)
(for-each (lambda (arg)
(simple-format #t "arg: ~A\n" arg))
args)
#f)))))
supported-systems))
supported-systems)))
(let* ((packages (inferior-packages inf)) (let* ((packages (inferior-packages inf))
(packages-metadata-ids (packages-metadata-ids
(inferior-packages->package-metadata-ids conn packages)) (inferior-packages->package-metadata-ids conn packages))
(packages-derivation-ids (packages-count (length packages))
(progress-reporter (progress-reporter/bar
packages-count
(format #f "processing ~a packages"
packages-count)))
(systems-targets-and-derivations-by-package
(call-with-progress-reporter progress-reporter
(lambda (report)
(map
(lambda (package)
(report)
(inferior-package->systems-targets-and-derivations package))
packages))))
(package-ids
(inferior-packages->package-ids
conn packages packages-metadata-ids))
(derivation-ids
(derivations->derivation-ids (derivations->derivation-ids
conn conn
(filter-map (append-map
(lambda (package) (lambda (system-targets-and-derivations)
(catch (map third system-targets-and-derivations))
#t systems-targets-and-derivations-by-package)))
(lambda () (flat-package-ids-systems-and-targets
(inferior-package-derivation (append-map
store package)) (lambda (package-id system-targets-and-derivations)
(lambda args (map (match-lambda
(simple-format ((system target derivation)
#t "guix-data-service: inferior-guix->package-ids: error processing derivation ~A\n" (list package-id
package) system
(simple-format target)))
#t "guix-data-service: inferior-guix->package-ids: error: ~A\n" args) system-targets-and-derivations))
#f))) package-ids
packages)))) systems-targets-and-derivations-by-package)))
(inferior-packages->package-ids (insert-package-derivations conn
conn packages packages-metadata-ids packages-derivation-ids))) flat-package-ids-systems-and-targets
derivation-ids)))
(define (inferior-package-transitive-supported-systems package)
((@@ (guix inferior) inferior-package-field)
package
'package-transitive-supported-systems))
(define (guix-store-path store) (define (guix-store-path store)
(let* ((guix-package (@ (gnu packages package-management) (let* ((guix-package (@ (gnu packages package-management)
@ -140,17 +201,21 @@
(inferior-eval '(use-modules (guix grafts)) inf) (inferior-eval '(use-modules (guix grafts)) inf)
(inferior-eval '(%graft? #f) inf) (inferior-eval '(%graft? #f) inf)
(let ((package-ids (inferior-guix->package-ids store conn inf))) (exec-query conn "BEGIN")
(exec-query conn "BEGIN") (let ((package-derivation-ids
(inferior-guix->package-derivation-ids store conn inf))
(guix-revision-id
(insert-guix-revision conn url commit store_path)))
(let ((guix-revision-id (insert-guix-revision-package-derivations conn
(insert-guix-revision conn url commit store_path))) guix-revision-id
(insert-guix-revision-packages conn guix-revision-id package-ids)) package-derivation-ids)
(exec-query conn "COMMIT") (exec-query conn "COMMIT")
(simple-format (simple-format
#t "Successfully loaded ~A packages\n" (length package-ids))) #t "Successfully loaded ~A package/derivation pairs\n"
(length package-derivation-ids)))
(close-inferior inf))) (close-inferior inf)))

319
guix-data-service/model/derivation.scm
View File

@ -5,16 +5,18 @@
#:use-module (squee) #:use-module (squee)
#:use-module (guix base32) #:use-module (guix base32)
#:use-module (guix inferior) #:use-module (guix inferior)
#:use-module (guix memoization)
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module (guix-data-service model utils) #:use-module (guix-data-service model utils)
#:export (select-derivation-by-file-name #:export (select-derivation-by-file-name
select-derivation-outputs-by-derivation-id select-derivation-outputs-by-derivation-id
select-derivation-by-output-filename select-derivation-by-output-filename
select-derivations-using-output select-derivations-using-output
select-derivations-by-revision-name-and-version
select-derivation-inputs-by-derivation-id select-derivation-inputs-by-derivation-id
select-existing-derivations select-existing-derivations
select-derivations-by-id select-derivations-by-id
select-derivations-and-build-status-by-id select-derivations-and-build-status-by-file-name
insert-into-derivations insert-into-derivations
derivations->derivation-ids)) derivations->derivation-ids))
@ -62,6 +64,36 @@
(exec-query conn query (list output-id))) (exec-query conn query (list output-id)))
(define (select-derivations-by-revision-name-and-version
conn revision-commit-hash name version)
(define query "
SELECT derivations.system, package_derivations.target, derivations.file_name,
latest_build_status.status
FROM derivations
INNER JOIN package_derivations
ON derivations.id = package_derivations.derivation_id
INNER JOIN packages
ON package_derivations.package_id = packages.id
INNER JOIN guix_revision_package_derivations
ON package_derivations.id = guix_revision_package_derivations.package_derivation_id
INNER JOIN guix_revisions
ON guix_revision_package_derivations.revision_id = guix_revisions.id
LEFT OUTER JOIN builds ON derivations.id = builds.derivation_id
LEFT OUTER JOIN (
SELECT DISTINCT ON (internal_build_id) *
FROM build_status
ORDER BY internal_build_id, status_fetched_at DESC
) AS latest_build_status
ON builds.internal_id = latest_build_status.internal_build_id
WHERE guix_revisions.commit = $1
AND packages.name = $2
AND packages.version = $3
ORDER BY derivations.system DESC,
package_derivations.target DESC,
derivations.file_name")
(exec-query conn query (list revision-commit-hash name version)))
(define (insert-derivation-outputs conn (define (insert-derivation-outputs conn
derivation-id derivation-id
names-and-derivation-outputs) names-and-derivation-outputs)
@ -166,21 +198,22 @@
((result) ((result)
result))) result)))
(define (select-derivation-output-id conn name path) (define select-derivation-output-id
(match (exec-query (mlambda (conn name path)
conn (match (exec-query
(string-append conn
"SELECT derivation_outputs.id FROM derivation_outputs " (string-append
"INNER JOIN derivations ON " "SELECT derivation_outputs.id FROM derivation_outputs "
"derivation_outputs.derivation_id = derivations.id " "INNER JOIN derivations ON "
"WHERE derivations.file_name = '" path "' " "derivation_outputs.derivation_id = derivations.id "
"AND derivation_outputs.name = '" name "';")) "WHERE derivations.file_name = '" path "' "
(((id)) "AND derivation_outputs.name = '" name "';"))
id) (((id))
(() id)
(error (simple-format (()
#f "cannot find derivation-output with name ~A and path ~A" (error (simple-format
name path))))) #f "cannot find derivation-output with name ~A and path ~A"
name path))))))
(define (select-derivation-outputs-by-derivation-id conn id) (define (select-derivation-outputs-by-derivation-id conn id)
(define query (define query
@ -211,7 +244,7 @@
(exec-query conn query (list id))) (exec-query conn query (list id)))
(define (insert-derivation-input conn derivation-id derivation-input) (define (insert-derivation-inputs conn derivation-id derivation-inputs)
(define (insert-into-derivation-inputs output-ids) (define (insert-into-derivation-inputs output-ids)
(string-append "INSERT INTO derivation_inputs " (string-append "INSERT INTO derivation_inputs "
"(derivation_id, derivation_output_id) VALUES " "(derivation_id, derivation_output_id) VALUES "
@ -224,16 +257,19 @@
",") ",")
";")) ";"))
(match derivation-input (unless (null? derivation-inputs)
(($ <derivation-input> path sub-derivations) (exec-query
(exec-query conn
conn (insert-into-derivation-inputs
(insert-into-derivation-inputs (append-map
(map (lambda (sub-derivation) (match-lambda
(select-derivation-output-id conn (($ <derivation-input> path sub-derivations)
sub-derivation (map (lambda (sub-derivation)
path)) (select-derivation-output-id conn
sub-derivations)))))) sub-derivation
path))
sub-derivations)))
derivation-inputs)))))
(define (select-from-derivation-source-files store-paths) (define (select-from-derivation-source-files store-paths)
(string-append (string-append
@ -304,7 +340,34 @@
(exec-query conn (exec-query conn
(insert-into-derivation-sources sources-ids)))) (insert-into-derivation-sources sources-ids))))
(define (insert-missing-derivations conn derivations) (define (insert-missing-derivations conn
derivation-ids-hash-table
derivations)
(define (ensure-input-derivations-exist input-derivation-file-names)
(unless (null? input-derivation-file-names)
(simple-format
#t "debug: ensure-input-derivations-exist: processing ~A derivations\n"
(length input-derivation-file-names))
(force-output)
(let* ((existing-derivation-entries
(derivation-file-names->vhash conn
derivation-ids-hash-table
input-derivation-file-names))
(missing-derivations-filenames
(filter (lambda (derivation-file-name)
(not (vhash-assoc derivation-file-name
existing-derivation-entries)))
input-derivation-file-names)))
(unless (null? missing-derivations-filenames)
;; Ensure all the input derivations exist
(insert-missing-derivations
conn
derivation-ids-hash-table
(map read-derivation-from-file
missing-derivations-filenames))))))
(define (insert-into-derivations) (define (insert-into-derivations)
(string-append (string-append
"INSERT INTO derivations " "INSERT INTO derivations "
@ -331,24 +394,60 @@
" RETURNING id" " RETURNING id"
";")) ";"))
(map (lambda (derivation-id derivation) (simple-format
(insert-derivation-outputs conn #t "debug: insert-missing-derivations: inserting ~A derivations\n"
derivation-id (length derivations))
(derivation-outputs derivation)) (let ((derivation-ids
(map car (exec-query conn (insert-into-derivations)))))
(insert-derivation-sources conn (simple-format
derivation-id #t "debug: insert-missing-derivations: updating hash table\n")
(derivation-sources derivation)) (for-each (lambda (derivation derivation-id)
(hash-set! derivation-ids-hash-table
(derivation-file-name derivation)
derivation-id))
derivations
derivation-ids)
(for-each (lambda (derivation-input) (simple-format
(insert-derivation-input conn #t "debug: insert-missing-derivations: inserting outputs\n")
derivation-id (for-each (lambda (derivation-id derivation)
derivation-input)) (insert-derivation-outputs conn
(derivation-inputs derivation)) derivation-id
(derivation-outputs derivation)))
derivation-ids
derivations)
derivation-id) (simple-format
(map car (exec-query conn (insert-into-derivations))) #t "debug: insert-missing-derivations: inserting sources\n")
derivations)) (for-each (lambda (derivation-id derivation)
(insert-derivation-sources conn
derivation-id
(derivation-sources derivation)))
derivation-ids
derivations)
(simple-format
#t "debug: insert-missing-derivations: ensure-input-derivations-exist\n")
(force-output)
(ensure-input-derivations-exist (deduplicate-strings
(map derivation-input-path
(append-map
derivation-inputs
derivations))))
(simple-format
#t "debug: insert-missing-derivations: inserting inputs\n")
(for-each (lambda (derivation-id derivation)
(insert-derivation-inputs conn
derivation-id
(derivation-inputs derivation)))
derivation-ids
derivations)
derivation-ids))
(define (select-derivations-by-id conn ids) (define (select-derivations-by-id conn ids)
(define query (define query
@ -363,10 +462,10 @@
(exec-query conn query)) (exec-query conn query))
(define (select-derivations-and-build-status-by-id conn ids) (define (select-derivations-and-build-status-by-file-name conn file-names)
(define query (define query
(string-append (string-append
"SELECT derivations.id, derivations.file_name, latest_build_status.status " "SELECT derivations.file_name, latest_build_status.status "
"FROM derivations " "FROM derivations "
"LEFT OUTER JOIN builds ON derivations.id = builds.derivation_id " "LEFT OUTER JOIN builds ON derivations.id = builds.derivation_id "
"LEFT OUTER JOIN " "LEFT OUTER JOIN "
@ -375,60 +474,124 @@
"ORDER BY internal_build_id, status_fetched_at DESC" "ORDER BY internal_build_id, status_fetched_at DESC"
") AS latest_build_status " ") AS latest_build_status "
"ON builds.internal_id = latest_build_status.internal_build_id " "ON builds.internal_id = latest_build_status.internal_build_id "
"WHERE derivations.id IN " "WHERE derivations.file_name IN "
"(" (string-join (map (lambda (id) "(" (string-join (map (lambda (file-name)
(simple-format #f "'~A'" id)) (simple-format #f "'~A'" file-name))
ids) file-names)
",") ",")
");")) ");"))
(exec-query conn query)) (exec-query conn query))
(define (deduplicate-strings strings)
(pair-fold
(lambda (pair result)
(if (null? (cdr pair))
(cons (first pair) result)
(if (string=? (first pair) (second pair))
result
(cons (first pair) result))))
'()
(sort strings
(lambda (a b)
(string<? a b)))))
(define (deduplicate-derivations derivations)
(define sorted-derivations
(sort derivations
(lambda (a b)
(string<? (derivation-file-name a)
(derivation-file-name b)))))
(pair-fold
(match-lambda*
(((x) result)
(cons x result))
(((x y rest ...) result)
(if (string=? (derivation-file-name x)
(derivation-file-name y))
result
(cons x result))))
'()
sorted-derivations))
(define (derivation-file-names->vhash conn derivation-ids-hash-table file-names)
(simple-format #t "debug: derivation-file-names->vhash: ~A file-names\n"
(length file-names))
(match (fold (match-lambda*
((file-name (result . missing-file-names))
(let ((cached-id (hash-ref derivation-ids-hash-table
file-name)))
(if cached-id
(cons (vhash-cons file-name cached-id result)
missing-file-names)
(cons result
(cons file-name missing-file-names))))))
(cons vlist-null '())
file-names)
((result)
(simple-format
#t "debug: derivation-file-names->vhash: lookup ~A file-names, all found\n"
(length file-names))
result)
((result . missing-file-names)
(simple-format
#t "debug: derivation-file-names->vhash: lookup ~A file-names, ~A not cached\n"
(length file-names) (length missing-file-names))
(let ((result-for-missing-file-names
(exec-query->vhash
conn
(select-existing-derivations missing-file-names)
second ;; file_name
first))) ;; id
(simple-format
#t "debug: derivation-file-names->vhash: adding ~A entries to the cache\n"
(vlist-length result-for-missing-file-names))
(vhash-fold (lambda (key value _)
(hash-set! derivation-ids-hash-table key value))
'()
result-for-missing-file-names)
(vhash-fold
(lambda (key value combined)
(vhash-cons key value combined))
result
result-for-missing-file-names)))))
(define (derivations->derivation-ids conn derivations) (define (derivations->derivation-ids conn derivations)
(define (ensure-input-derivations-exist)
(let* ((missing-derivation-file-names (map derivation-file-name
derivations))
(input-derivation-file-names (delete-duplicates
(map derivation-input-path
(append-map
derivation-inputs
derivations)))))
;; Ensure all the input derivations exist
(derivations->derivation-ids
conn
(map read-derivation-from-file
input-derivation-file-names))))
(if (null? derivations) (if (null? derivations)
'() '()
(begin (let* ((derivations-count (length derivations))
(ensure-input-derivations-exist) (derivation-ids-hash-table (make-hash-table derivations-count)))
(simple-format
#t "debug: derivations->derivation-ids: processing ~A derivations\n"
derivations-count)
(let* ((derivation-file-names (map derivation-file-name (let* ((derivation-file-names (map derivation-file-name
derivations)) derivations))
(existing-derivation-entries (exec-query->vhash (existing-derivation-entries
conn (derivation-file-names->vhash conn
(select-existing-derivations derivation-ids-hash-table
derivation-file-names) derivation-file-names))
second ;; file_name
first)) ;; id
(missing-derivations (missing-derivations
(filter (lambda (derivation) (deduplicate-derivations
(not (vhash-assoc (derivation-file-name derivation) (filter (lambda (derivation)
existing-derivation-entries))) (not (vhash-assoc (derivation-file-name derivation)
derivations)) existing-derivation-entries)))
derivations)))
(new-derivation-entries (new-derivation-entries
(if (null? missing-derivations) (if (null? missing-derivations)
'() '()
(insert-missing-derivations conn missing-derivations))) (insert-missing-derivations conn
derivation-ids-hash-table
missing-derivations)))
(new-entries-id-lookup-vhash (new-entries-id-lookup-vhash
(two-lists->vhash (map derivation-file-name missing-derivations) (two-lists->vhash (map derivation-file-name missing-derivations)
new-derivation-entries))) new-derivation-entries)))
(map (lambda (derivation-file-name) (map (lambda (derivation-file-name)
(cdr (cdr
(or (vhash-assoc derivation-file-name (or (vhash-assoc derivation-file-name

20
guix-data-service/model/guix-revision-package-derivation.scm Normal file
View File

@ -0,0 +1,20 @@
(define-module (guix-data-service model guix-revision-package-derivation)
#:use-module (squee)
#:export (insert-guix-revision-package-derivations))
(define (insert-guix-revision-package-derivations
conn guix-revision-id package-derivation-ids)
(define insert
(string-append "INSERT INTO guix_revision_package_derivations "
"(revision_id, package_derivation_id) "
"VALUES "
(string-join (map (lambda (package-derivation-id)
(simple-format
#f "(~A, ~A)"
guix-revision-id
package-derivation-id))
package-derivation-ids)
", ")
";"))
(exec-query conn insert))

19
guix-data-service/model/guix-revision-package.scm
View File

@ -1,19 +0,0 @@
(define-module (guix-data-service model guix-revision-package)
#:use-module (squee)
#:export (insert-guix-revision-packages))
(define (insert-guix-revision-packages conn guix-revision-id package-ids)
(define insert
(string-append "INSERT INTO guix_revision_packages "
"(revision_id, package_id) "
"VALUES "
(string-join (map (lambda (package-id)
(simple-format
#f "(~A, ~A)"
guix-revision-id
package-id))
package-ids)
", ")
";"))
(exec-query conn insert))

112
guix-data-service/model/package-derivation.scm Normal file
View File

@ -0,0 +1,112 @@
(define-module (guix-data-service model package-derivation)
#:use-module (srfi srfi-1)
#:use-module (ice-9 vlist)
#:use-module (ice-9 match)
#:use-module (squee)
#:use-module (guix-data-service model utils)
#:export (insert-package-derivations
count-packages-derivations-in-revision))
(define (insert-missing-package-derivations conn entries)
(define query
(string-append
"INSERT INTO package_derivations "
"(package_id, derivation_id, system, target) VALUES "
(string-join
(map
(lambda (entry)
(apply simple-format
#f "(~A, ~A, '~A', '~A')"
entry))
entries)
", ")
" RETURNING id"))
(exec-query conn query))
(define (insert-package-derivations conn
package-ids-systems-and-targets
derivation-ids)
(define select-existing-package-derivation-entries
(string-append
"SELECT id, package_derivations.package_id,"
" package_derivations.derivation_id, package_derivations.system,"
" package_derivations.target "
"FROM package_derivations "
"JOIN (VALUES "
(string-join (map (match-lambda*
(((package-id system target) derivation-id)
(simple-format
#f "(~A, ~A, '~A', '~A')"
package-id
derivation-id
system
target)))
package-ids-systems-and-targets
derivation-ids)
", ")
") AS vals (package_id, derivation_id, system, target) "
"ON package_derivations.package_id = vals.package_id "
"AND package_derivations.derivation_id = vals.derivation_id "
"AND package_derivations.system = vals.system "
"AND package_derivations.target = vals.target"))
(define data-4-tuples
(map (match-lambda*
(((package-id system target) derivation-id)
(list package-id
derivation-id
system
target)))
package-ids-systems-and-targets
derivation-ids))
(if (null? data-4-tuples)
'()
(begin
(let* ((existing-entries
(exec-query->vhash
conn
select-existing-package-derivation-entries
cdr
first)) ;; id
(missing-entries
(filter (lambda (4-tuple)
(not (vhash-assoc 4-tuple existing-entries)))
data-4-tuples))
(new-entry-ids
(if (null? missing-entries)
'()
(begin
(vlist->list existing-entries)
(insert-missing-package-derivations conn missing-entries))))
(new-entries-id-lookup-vhash
(two-lists->vhash missing-entries
new-entry-ids)))
(map (lambda (4-tuple)
(cdr
(or (vhash-assoc 4-tuple existing-entries)
(vhash-assoc 4-tuple new-entries-id-lookup-vhash)
(error "Missing entry"))))
data-4-tuples)))))
(define (count-packages-derivations-in-revision conn commit-hash)
(define query
"
SELECT package_derivations.system, package_derivations.target,
COUNT(DISTINCT package_derivations.derivation_id)
FROM package_derivations
WHERE package_derivations.id IN (
SELECT guix_revision_package_derivations.package_derivation_id
FROM guix_revision_package_derivations
INNER JOIN guix_revisions
ON guix_revision_package_derivations.revision_id = guix_revisions.id
WHERE guix_revisions.commit = $1
)
GROUP BY package_derivations.system, package_derivations.target
ORDER BY package_derivations.system DESC, package_derivations.target DESC")
(exec-query conn query (list commit-hash)))

24
guix-data-service/model/package-metadata.scm
View File

@ -9,6 +9,7 @@
#:use-module (guix inferior) #:use-module (guix inferior)
#:use-module (guix-data-service model utils) #:use-module (guix-data-service model utils)
#:export (select-package-metadata #:export (select-package-metadata
select-package-metadata-by-revision-name-and-version
insert-package-metadata insert-package-metadata
inferior-packages->package-metadata-ids)) inferior-packages->package-metadata-ids))
@ -22,6 +23,29 @@
",") ",")
");")) ");"))
(define (select-package-metadata-by-revision-name-and-version
conn revision-commit-hash name version)
(define query "
SELECT package_metadata.synopsis, package_metadata.description,
package_metadata.home_page
FROM package_metadata
INNER JOIN packages
ON package_metadata.id = packages.package_metadata_id
WHERE packages.id IN (
SELECT package_derivations.package_id
FROM package_derivations
INNER JOIN guix_revision_package_derivations
ON package_derivations.id =
guix_revision_package_derivations.package_derivation_id
INNER JOIN guix_revisions
ON guix_revision_package_derivations.revision_id = guix_revisions.id
WHERE guix_revisions.commit = $1
)
AND packages.name = $2
AND packages.version = $3")
(exec-query conn query (list revision-commit-hash name version)))
(define (insert-package-metadata metadata-rows) (define (insert-package-metadata metadata-rows)
(string-append "INSERT INTO package_metadata " (string-append "INSERT INTO package_metadata "
"(sha1_hash, synopsis, description, home_page) " "(sha1_hash, synopsis, description, home_page) "

74
guix-data-service/model/package.scm
View File

@ -7,75 +7,93 @@
#:use-module (guix-data-service model utils) #:use-module (guix-data-service model utils)
#:export (select-existing-package-entries #:export (select-existing-package-entries
select-packages-in-revision select-packages-in-revision
count-packages-in-revision
insert-into-package-entries insert-into-package-entries
inferior-packages->package-ids)) inferior-packages->package-ids))
(define (select-existing-package-entries package-entries) (define (select-existing-package-entries package-entries)
(string-append "SELECT id, packages.name, packages.version, " (string-append "SELECT id, packages.name, packages.version, "
"packages.package_metadata_id, packages.derivation_id " "packages.package_metadata_id "
"FROM packages " "FROM packages "
"JOIN (VALUES " "JOIN (VALUES "
(string-join (map (lambda (package-entry) (string-join (map (lambda (package-entry)
(apply (apply
simple-format simple-format
#f "('~A', '~A', ~A, ~A)" #f "('~A', '~A', ~A)"
package-entry)) package-entry))
package-entries) package-entries)
", ") ", ")
") AS vals (name, version, package_metadata_id, derivation_id) " ") AS vals (name, version, package_metadata_id) "
"ON packages.name = vals.name AND " "ON packages.name = vals.name AND "
"packages.version = vals.version AND " "packages.version = vals.version AND "
"packages.package_metadata_id = vals.package_metadata_id AND " "packages.package_metadata_id = vals.package_metadata_id"))
"packages.derivation_id = vals.derivation_id"
";"))
(define (select-packages-in-revision conn commit-hash) (define (select-packages-in-revision conn commit-hash)
(define query (define query
(string-append "
"SELECT packages.name, packages.version, packages.derivation_id " SELECT packages.name, packages.version, package_metadata.synopsis
"FROM packages " FROM packages
"INNER JOIN guix_revision_packages" INNER JOIN package_metadata
" ON packages.id = guix_revision_packages.package_id " ON packages.package_metadata_id = package_metadata.id
"INNER JOIN guix_revisions" WHERE packages.id IN (
" ON guix_revision_packages.revision_id = guix_revisions.id " SELECT package_derivations.package_id
"WHERE guix_revisions.commit = $1 " FROM package_derivations
"ORDER BY packages.name, packages.version")) INNER JOIN guix_revision_package_derivations
ON package_derivations.id = guix_revision_package_derivations.package_derivation_id
INNER JOIN guix_revisions
ON guix_revision_package_derivations.revision_id = guix_revisions.id
WHERE guix_revisions.commit = $1
)
ORDER BY packages.name, packages.version")
(exec-query conn query (list commit-hash)))
(define (count-packages-in-revision conn commit-hash)
(define query
"
SELECT COUNT(DISTINCT packages.name)
FROM packages
WHERE packages.id IN (
SELECT package_derivations.package_id
FROM package_derivations
INNER JOIN guix_revision_package_derivations
ON package_derivations.id = guix_revision_package_derivations.package_derivation_id
INNER JOIN guix_revisions
ON guix_revision_package_derivations.revision_id = guix_revisions.id
WHERE guix_revisions.commit = $1
)")
(exec-query conn query (list commit-hash))) (exec-query conn query (list commit-hash)))
(define (insert-into-package-entries package-entries) (define (insert-into-package-entries package-entries)
(string-append "INSERT INTO packages " (string-append "INSERT INTO packages "
"(name, version, package_metadata_id, derivation_id) VALUES " "(name, version, package_metadata_id) VALUES "
(string-join (string-join
(map (map
(match-lambda (match-lambda
((name version package_metadata_id derivation_id) ((name version package_metadata_id)
(simple-format #f "('~A', '~A', ~A, ~A)" (simple-format #f "('~A', '~A', ~A)"
name name
version version
package_metadata_id package_metadata_id)))
derivation_id)))
package-entries) package-entries)
",") ",")
" RETURNING id" " RETURNING id"
";")) ";"))
(define (inferior-packages->package-ids conn packages metadata-ids derivation-ids) (define (inferior-packages->package-ids conn packages metadata-ids)
(define package-entries (define package-entries
(map (lambda (package metadata-id derivation-id) (map (lambda (package metadata-id)
(list (inferior-package-name package) (list (inferior-package-name package)
(inferior-package-version package) (inferior-package-version package)
metadata-id metadata-id))
derivation-id))
packages packages
metadata-ids metadata-ids))
derivation-ids))
(let* ((existing-package-entry-ids (let* ((existing-package-entry-ids
(exec-query->vhash conn (exec-query->vhash conn
(select-existing-package-entries package-entries) (select-existing-package-entries package-entries)
;; name, version, package_metadata_id and ;; name, version and package_metadata_id
;; derivation_id
cdr cdr
first)) ;;id first)) ;;id
(missing-package-entries (missing-package-entries

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

@ -29,6 +29,8 @@
#:use-module (guix-data-service comparison) #:use-module (guix-data-service comparison)
#:use-module (guix-data-service model guix-revision) #:use-module (guix-data-service model guix-revision)
#:use-module (guix-data-service model package) #:use-module (guix-data-service model package)
#:use-module (guix-data-service model package-derivation)
#:use-module (guix-data-service model package-metadata)
#:use-module (guix-data-service model derivation) #:use-module (guix-data-service model derivation)
#:use-module (guix-data-service model build) #:use-module (guix-data-service model build)
#:use-module (guix-data-service jobs load-new-guix-revision) #:use-module (guix-data-service jobs load-new-guix-revision)
@ -113,16 +115,16 @@
(version-changes (version-changes
(package-data-version-changes base-packages-vhash (package-data-version-changes base-packages-vhash
target-packages-vhash)) target-packages-vhash))
(other-changes (derivation-changes
(package-data-other-changes base-packages-vhash (package-data-derivation-changes base-packages-vhash
target-packages-vhash))) target-packages-vhash)))
(cond (cond
((eq? content-type 'json) ((eq? content-type 'json)
(render-json (render-json
`((new-packages . ,new-packages) `((new-packages . ,new-packages)
(removed-packages . ,removed-packages) (removed-packages . ,removed-packages)
(version-changes . ,version-changes) (version-changes . ,version-changes)
(other-changes . ,other-changes)))) (derivation-changes . ,derivation-changes))))
(else (else
(apply render-html (apply render-html
(compare base-commit (compare base-commit
@ -130,7 +132,7 @@
new-packages new-packages
removed-packages removed-packages
version-changes version-changes
other-changes))))))) derivation-changes)))))))
(define (render-compare/derivations content-type (define (render-compare/derivations content-type
conn conn
@ -138,6 +140,15 @@
base-revision-id base-revision-id
target-commit target-commit
target-revision-id) target-revision-id)
(define (derivations->alist derivations)
(map (match-lambda
((file-name buildstatus)
`((file_name . ,file-name)
(build_status . ,(if (string=? "")
"unknown"
buildstatus)))))
derivations))
(let-values (let-values
(((base-packages-vhash target-packages-vhash) (((base-packages-vhash target-packages-vhash)
(package-data->package-data-vhashes (package-data->package-data-vhashes
@ -156,9 +167,13 @@
((eq? content-type 'json) ((eq? content-type 'json)
(render-json (render-json
`((base . ((commit . ,base-commit) `((base . ((commit . ,base-commit)
(derivations . ,base-derivations))) (derivations . ,(list->vector
(derivations->alist
base-derivations)))))
(target . ((commit . ,target-commit) (target . ((commit . ,target-commit)
(derivations . ,target-derivations)))))) (derivations . ,(list->vector
(derivations->alist
target-derivations))))))))
(else (else
(apply render-html (apply render-html
(compare/derivations (compare/derivations
@ -174,11 +189,13 @@
target-commit target-commit
target-revision-id) target-revision-id)
(define (package-data-vhash->json vh) (define (package-data-vhash->json vh)
(vhash-fold (lambda (name data result) (delete-duplicates
(cons (string-append name "@" (car data)) (vhash-fold (lambda (name data result)
result)) (cons `((name . ,name)
'() (version . ,(car data)))
vh)) result))
'()
vh)))
(let-values (let-values
(((base-packages-vhash target-packages-vhash) (((base-packages-vhash target-packages-vhash)
@ -189,10 +206,14 @@
(cond (cond
((eq? content-type 'json) ((eq? content-type 'json)
(render-json (render-json
`((base . ((commit . ,base-commit) `((base
(packages . ,(package-data-vhash->json base-packages-vhash)))) . ((commit . ,base-commit)
(target . ((commit . ,target-commit) (packages . ,(list->vector
(packages . ,(package-data-vhash->json target-packages-vhash))))))) (package-data-vhash->json base-packages-vhash)))))
(target
. ((commit . ,target-commit)
(packages . ,(list->vector
(package-data-vhash->json target-packages-vhash))))))))
(else (else
(apply render-html (apply render-html
(compare/packages (compare/packages
@ -227,14 +248,16 @@
(match derivation (match derivation
(() (()
#f) #f)
((derivation) (derivations
(apply render-html (apply render-html
(view-store-item filename (view-store-item filename
derivation derivations
(match derivation (map (lambda (derivation)
((file-name output-id rest ...) (match derivation
(select-derivations-using-output ((file-name output-id rest ...)
conn output-id))))))))) (select-derivations-using-output
conn output-id))))
derivations)))))))
(define (controller request body conn) (define (controller request body conn)
(match-lambda (match-lambda
@ -249,13 +272,31 @@
((GET "revision" commit-hash) ((GET "revision" commit-hash)
(apply render-html (apply render-html
(view-revision commit-hash (view-revision commit-hash
(select-packages-in-revision conn (count-packages-in-revision conn
commit-hash)))) commit-hash)
(count-packages-derivations-in-revision conn
commit-hash))))
((GET "revision" commit-hash "packages")
(apply render-html
(view-revision-packages commit-hash
(select-packages-in-revision
conn commit-hash))))
((GET "revision" commit-hash "package" name version) ((GET "revision" commit-hash "package" name version)
(apply render-html (apply render-html
(view-revision-package-and-version commit-hash (view-revision-package-and-version
name commit-hash
version))) name
version
(select-package-metadata-by-revision-name-and-version
conn
commit-hash
name
version)
(select-derivations-by-revision-name-and-version
conn
commit-hash
name
version))))
((GET "gnu" "store" filename) ((GET "gnu" "store" filename)
(if (string-suffix? ".drv" filename) (if (string-suffix? ".drv" filename)
(render-derivation conn (string-append "/gnu/store/" filename)) (render-derivation conn (string-append "/gnu/store/" filename))

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

@ -23,9 +23,12 @@
#: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)
#:use-module (texinfo)
#:use-module (texinfo html)
#:export (index #:export (index
view-revision-package-and-version view-revision-package-and-version
view-revision view-revision
view-revision-packages
view-builds view-builds
view-derivation view-derivation
view-store-item view-store-item
@ -171,7 +174,9 @@
(td ,source)))) (td ,source))))
queued-guix-revisions))))))))) queued-guix-revisions)))))))))
(define (view-revision-package-and-version revision-commit-hash name version) (define (view-revision-package-and-version revision-commit-hash name version
package-metadata
derivations)
(layout (layout
#:extra-headers #:extra-headers
'((cache-control . ((max-age . 60)))) '((cache-control . ((max-age . 60))))
@ -181,9 +186,48 @@
(@ (class "container")) (@ (class "container"))
(div (div
(@ (class "row")) (@ (class "row"))
(h1 "Package " ,name " @ " ,version)))))) (h3 (a (@ (href ,(string-append
"/revision/" revision-commit-hash)))
"Revision " (samp ,revision-commit-hash))))
(div
(@ (class "row"))
(h1 "Package " ,name " @ " ,version))
(div
(@ (class "row"))
,(match package-metadata
(((synopsis description home-page))
`(dl
(@ (class "dl-horizontal"))
(dt "Synopsis")
(dd ,(stexi->shtml (texi-fragment->stexi synopsis)))
(dt "Description")
(dd ,(stexi->shtml (texi-fragment->stexi description)))
(dt "Home page")
(dd (a (@ (href ,home-page))
,home-page))))))
(div
(@ (class "row"))
(table
(@ (class "table"))
(thead
(tr
(th "System")
(th "Target")
(th "Derivation")
(th "Build status")))
(tbody
,@(map
(match-lambda
((system target file-name status)
`(tr
(td (samp ,system))
(td (samp ,target))
(td (a (@ (href ,file-name))
,(display-store-item-short file-name)))
(td ,(build-status-span status)))))
derivations))))))))
(define (view-revision commit-hash packages) (define (view-revision commit-hash packages-count derivations-count)
(layout (layout
#:extra-headers #:extra-headers
'((cache-control . ((max-age . 60)))) '((cache-control . ((max-age . 60))))
@ -196,23 +240,78 @@
(h1 "Revision " (samp ,commit-hash))) (h1 "Revision " (samp ,commit-hash)))
(div (div
(@ (class "row")) (@ (class "row"))
(h3 "Packages") (div
(@ (class "col-md-6"))
(h3 "Packages")
(strong (@ (class "text-center")
(style "font-size: 2em; display: block;"))
,packages-count)
(a (@ (class "btn btn-default btn-lg")
(href ,(string-append "/revision/" commit-hash
"/packages")))
"View packages"))
(div
(@ (class "col-md-6"))
(h3 "Derivations")
(table
(@ (class "table"))
(thead
(tr
(th "System")
(th "Target")
(th "Distinct derivations")))
(tbody
,@(map (match-lambda
((system target count)
(if (string=? system target)
`(tr
(td (@ (class "text-center")
(colspan 2))
(samp ,system))
(td (samp ,count)))
`(tr
(td (samp ,system))
(td (samp ,target))
(td (samp ,count))))))
derivations-count)))))))))
(define (view-revision-packages revision-commit-hash packages)
(layout
#:extra-headers
'((cache-control . ((max-age . 60))))
#:body
`(,(header)
(div
(@ (class "container"))
(div
(@ (class "row"))
(h3 (a (@ (href ,(string-append
"/revision/" revision-commit-hash)))
"Revision " (samp ,revision-commit-hash))))
(div
(@ (class "row"))
(h1 "Packages")
(table (table
(@ (class "table")) (@ (class "table table-responsive"))
(thead (thead
(tr (tr
(th (@ (class "col-md-3")) "Name") (th (@ (class "col-md-3")) "Name")
(th (@ (class "col-md-3")) "Version"))) (th (@ (class "col-md-3")) "Version")
(th (@ (class "col-md-3")) "Synopsis")
(th (@ (class "col-md-3")) "")))
(tbody (tbody
,@(map ,@(map
(match-lambda (match-lambda
((name version rest ...) ((name version synopsis)
`(tr `(tr
(td (a (@ (href ,(string-append (td ,name)
"/revision/" commit-hash (td ,version)
(td ,(stexi->shtml (texi-fragment->stexi synopsis)))
(td (@ (class "text-right"))
(a (@ (href ,(string-append
"/revision/" revision-commit-hash
"/package/" name "/" version))) "/package/" name "/" version)))
,name)) "More information")))))
(td ,version))))
packages)))))))) packages))))))))
(define (view-builds stats builds) (define (view-builds stats builds)
@ -237,7 +336,7 @@
(match-lambda (match-lambda
((status count) ((status count)
`(tr `(tr
(td ,status) (td ,(build-status-span status))
(td ,count)))) (td ,count))))
stats)))) stats))))
(div (div
@ -257,13 +356,8 @@
((build-id build-server-url derivation-file-name ((build-id build-server-url derivation-file-name
status-fetched-at starttime stoptime status) status-fetched-at starttime stoptime status)
`(tr `(tr
(td (@ (class ,(cond (td (@ (class "text-center"))
((string=? status "succeeded") ,(build-status-span status))
"bg-success")
((string=? status "failed")
"bg-danger")
(else ""))))
,status)
(td (a (@ (href ,derivation-file-name)) (td (a (@ (href ,derivation-file-name))
,(display-store-item-short derivation-file-name))) ,(display-store-item-short derivation-file-name)))
(td ,starttime) (td ,starttime)
@ -273,6 +367,31 @@
"View build on " ,build-server-url))))) "View build on " ,build-server-url)))))
builds)))))))) builds))))))))
(define (build-status-span status)
`(span (@ (class ,(string-append
"label label-"
(assoc-ref
'(("scheduled" . "info")
("started" . "primary")
("succeeded" . "success")
("failed" . "danger")
("failed-dependency" . "warning")
("failed-other" . "danger")
("canceled" . "default")
("" . "default"))
status)))
(style "display: inline-block; font-size: 1.2em; margin-top: 0.4em;"))
,(assoc-ref
'(("scheduled" . "Scheduled")
("started" . "Started")
("succeeded" . "Succeeded")
("failed" . "Failed")
("failed-dependency" . "Failed (dependency)")
("failed-other" . "Failed (other)")
("canceled" . "Canceled")
("" . "Unknown"))
status)))
(define (display-store-item-short item) (define (display-store-item-short item)
`((span (@ (style "font-size: small; font-family: monospace; display: block;")) `((span (@ (style "font-size: small; font-family: monospace; display: block;"))
,(string-take item 44)) ,(string-take item 44))
@ -280,9 +399,9 @@
,(string-drop item 44)))) ,(string-drop item 44))))
(define (display-store-item item) (define (display-store-item item)
`((span (@ (style "font-size: small; font-family: monospace;")) `((span (@ (style "font-size: small; font-family: monospace; white-space: nowrap;"))
,(string-take item 44)) ,(string-take item 44))
(span (@ (style "font-size: x-large; font-family: monospace;")) (span (@ (style "font-size: x-large; font-family: monospace; white-space: nowrap;"))
,(string-drop item 44)))) ,(string-drop item 44))))
(define (display-store-item-title item) (define (display-store-item-title item)
@ -300,7 +419,7 @@
,(string-append ,(string-append
"/" (string-join fileparts "/")))))) "/" (string-join fileparts "/"))))))
(define (view-store-item filename derivation derivations-using-store-item) (define (view-store-item filename derivations derivations-using-store-item-list)
(layout (layout
#:extra-headers #:extra-headers
'((cache-control . ((max-age . 60)))) '((cache-control . ((max-age . 60))))
@ -311,28 +430,31 @@
(div (div
(@ (class "row")) (@ (class "row"))
,(display-store-item-title filename)) ,(display-store-item-title filename))
(div ,@(map (lambda (derivation derivations-using-store-item)
(@ (class "row")) `((div
(h4 "Derivation: ") (@ (class "row"))
,(match derivation (h4 "Derivation: ")
((file-name output-id) ,(match derivation
`(a (@ (href ,file-name)) ((file-name output-id)
,(display-store-item file-name))))) `(a (@ (href ,file-name))
(div ,(display-store-item file-name)))))
(@ (class "row")) (div
(h2 "Derivations using this store item " (@ (class "row"))
,(let ((count (length derivations-using-store-item))) (h2 "Derivations using this store item "
(if (eq? count 100) ,(let ((count (length derivations-using-store-item)))
"(> 100)" (if (eq? count 100)
(simple-format #f "(~A)" count)))) "(> 100)"
(ul (simple-format #f "(~A)" count))))
(@ (class "list-unstyled")) (ul
,(map (@ (class "list-unstyled"))
(match-lambda ,(map
((file-name) (match-lambda
`(li (a (@ (href ,file-name)) ((file-name)
,(display-store-item file-name))))) `(li (a (@ (href ,file-name))
derivations-using-store-item))))))) ,(display-store-item file-name)))))
derivations-using-store-item)))))
derivations
derivations-using-store-item-list)))))
(define (view-derivation derivation derivation-inputs derivation-outputs (define (view-derivation derivation derivation-inputs derivation-outputs
builds) builds)
@ -381,17 +503,22 @@
(td "System") (td "System")
(td (samp ,system))))))) (td (samp ,system)))))))
(h3 "Build status") (h3 "Build status")
,@(map ,@(if (null? builds)
(match-lambda `((div
((build-id build-server-url status-fetched-at (@ (class "text-center"))
starttime stoptime status) ,(build-status-span "")))
`(div (map
(@ (class "text-center")) (match-lambda
(div ,status) ((build-id build-server-url status-fetched-at
(a (@ (href ,(simple-format starttime stoptime status)
#f "~Abuild/~A" build-server-url build-id))) `(div
"View build on " ,build-server-url)))) (@ (class "text-center"))
builds)) (div ,(build-status-span status))
(a (@ (style "display: inline-block; margin-top: 0.4em;")
(href ,(simple-format
#f "~Abuild/~A" build-server-url build-id)))
"View build on " ,build-server-url))))
builds)))
(div (div
(@ (class "col-md-4")) (@ (class "col-md-4"))
(h3 "Outputs") (h3 "Outputs")
@ -413,7 +540,7 @@
new-packages new-packages
removed-packages removed-packages
version-changes version-changes
other-changes) derivation-changes)
(define query-params (define query-params
(string-append "?base_commit=" base-commit (string-append "?base_commit=" base-commit
"&target_commit=" target-commit)) "&target_commit=" target-commit))
@ -516,24 +643,61 @@
version-changes))))) version-changes)))))
(div (div
(@ (class "row")) (@ (class "row"))
(h3 "Other changed packages") (h3 "Package derivation changes")
,@(if (null? other-changes) ,(if
'((p "No other changes")) (null? derivation-changes)
`((p "The metadata or derivation for these packages has changed.") '(p "No derivation changes")
(table `(table
(@ (class "table")) (@ (class "table")
(thead (style "table-layout: fixed;"))
(tr (thead
(th (@ (class "col-md-3")) "Name") (tr
(th (@ (class "col-md-9")) "Version"))) (th "Name")
(tbody (th "Version")
,@(map (th "System")
(match-lambda (th "Target")
(((name . version) . (metadata-id derivation-id)) (th (@ (class "col-xs-5")) "Derivations")))
`(tr (tbody
(td ,name) ,@(append-map
(td ,version)))) (match-lambda
other-changes)))))))))) (((name . version) . (('base . base-derivations)
('target . target-derivations)))
(let* ((system-and-versions
(delete-duplicates
(append (map car base-derivations)
(map car target-derivations))))
(data-columns
(map
(lambda (system-and-target)
(let ((base-derivation-file-name
(assoc-ref base-derivations system-and-target))
(target-derivation-file-name
(assoc-ref target-derivations system-and-target)))
`((td (samp (@ (style "white-space: nowrap;"))
,(car system-and-target)))
(td (samp (@ (style "white-space: nowrap;"))
,(cdr system-and-target)))
(td (a (@ (style "display: block;")
(href ,base-derivation-file-name))
(span (@ (class "text-danger glyphicon glyphicon-minus pull-left")
(style "font-size: 1.5em; padding-right: 0.4em;")))
,(display-store-item-short base-derivation-file-name))
(a (@ (style "display: block;")
(href ,target-derivation-file-name))
(span (@ (class "text-success glyphicon glyphicon-plus pull-left")
(style "font-size: 1.5em; padding-right: 0.4em;")))
,(display-store-item-short target-derivation-file-name))))))
system-and-versions)))
`((tr (td (@ (rowspan , (length system-and-versions)))
,name)
(td (@ (rowspan , (length system-and-versions)))
,version)
,@(car data-columns))
,@(map (lambda (data-row)
`(tr ,data-row))
(cdr data-columns))))))
derivation-changes)))))))))
(define (compare/derivations base-commit (define (compare/derivations base-commit
target-commit target-commit
@ -575,11 +739,11 @@
(tbody (tbody
,@(map ,@(map
(match-lambda (match-lambda
((id file-name build-status) ((file-name build-status)
`(tr `(tr
(td (a (@ (href ,file-name)) (td (a (@ (href ,file-name))
,(display-store-item file-name))) ,(display-store-item file-name)))
(td ,build-status)))) (td ,(build-status-span build-status)))))
base-derivations)))) base-derivations))))
(div (div
(@ (class "row")) (@ (class "row"))
@ -596,11 +760,11 @@
(tbody (tbody
,@(map ,@(map
(match-lambda (match-lambda
((id file-name build-status) ((file-name build-status)
`(tr `(tr
(td (a (@ (href ,file-name)) (td (a (@ (href ,file-name))
,(display-store-item file-name))) ,(display-store-item file-name)))
(td ,build-status)))) (td ,(build-status-span build-status)))))
target-derivations)))))))) target-derivations))))))))
(define (compare/packages base-commit (define (compare/packages base-commit
@ -638,16 +802,25 @@
(@ (class "table")) (@ (class "table"))
(thead (thead
(tr (tr
(th (@ (class "col-md-6")) "Name") (th (@ (class "col-md-4")) "Name")
(th (@ (class "col-md-6")) "Version"))) (th (@ (class "col-md-4")) "Version")
(th (@ (class "col-md-4")) "")))
(tbody (tbody
,@(map ,@(map
(match-lambda (match-lambda
((name version rest ...) ((name version)
`(tr `(tr
(td ,name) (td ,name)
(td ,version)))) (td ,version)
(vlist->list base-packages-vhash))))) (td (@ (class "text-right"))
(a (@ (href ,(string-append
"/revision/" base-commit
"/package/" name "/" version)))
"More information")))))
(delete-duplicates
(map (lambda (data)
(take data 2))
(vlist->list base-packages-vhash)))))))
(div (div
(@ (class "row")) (@ (class "row"))
(h3 "Target (" (h3 "Target ("
@ -658,16 +831,25 @@
(@ (class "table")) (@ (class "table"))
(thead (thead
(tr (tr
(th (@ (class "col-md-6")) "Name") (th (@ (class "col-md-4")) "Name")
(th (@ (class "col-md-6")) "Version"))) (th (@ (class "col-md-4")) "Version")
(th (@ (class "col-md-4")) "")))
(tbody (tbody
,@(map ,@(map
(match-lambda (match-lambda
((name version rest ...) ((name version)
`(tr `(tr
(td ,name) (td ,name)
(td ,version)))) (td ,version)
(vlist->list target-packages-vhash))))))))) (td (@ (class "text-right"))
(a (@ (href ,(string-append
"/revision/" base-commit
"/package/" name "/" version)))
"More information")))))
(delete-duplicates
(map (lambda (data)
(take data 2))
(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?