aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Makefile.am41
-rw-r--r--guix-data-service/comparison.scm146
-rw-r--r--guix-data-service/jobs/load-new-guix-revision.scm117
-rw-r--r--guix-data-service/model/derivation.scm325
-rw-r--r--guix-data-service/model/guix-revision-package-derivation.scm20
-rw-r--r--guix-data-service/model/guix-revision-package.scm19
-rw-r--r--guix-data-service/model/package-derivation.scm112
-rw-r--r--guix-data-service/model/package-metadata.scm24
-rw-r--r--guix-data-service/model/package.scm74
-rw-r--r--guix-data-service/web/controller.scm95
-rw-r--r--guix-data-service/web/view/html.scm358
11 files changed, 1002 insertions, 329 deletions
diff --git a/Makefile.am b/Makefile.am
index a60542e..4c68c04 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -29,24 +29,25 @@ moddir = $(prefix)/share/guile/site/$(GUILE_EFFECTIVE_VERSION)
godir = $(moddir)
assetsdir = $(datadir)/@PACKAGE@
-SOURCES = \
- guix-data-service/builds.scm \
- guix-data-service/comparison.scm \
- guix-data-service/config.scm \
- guix-data-service/jobs.scm \
- guix-data-service/jobs/load-new-guix-revision.scm \
- guix-data-service/model/build-server.scm \
- guix-data-service/model/build-status.scm \
- guix-data-service/model/build.scm \
- guix-data-service/model/derivation.scm \
- guix-data-service/model/guix-revision-package.scm \
- guix-data-service/model/guix-revision.scm \
- guix-data-service/model/package-metadata.scm \
- guix-data-service/model/package.scm \
- guix-data-service/model/utils.scm \
- guix-data-service/web/controller.scm \
- guix-data-service/web/render.scm \
- guix-data-service/web/server.scm \
- guix-data-service/web/sxml.scm \
- guix-data-service/web/util.scm \
+SOURCES = \
+ guix-data-service/builds.scm \
+ guix-data-service/comparison.scm \
+ guix-data-service/config.scm \
+ guix-data-service/jobs.scm \
+ guix-data-service/jobs/load-new-guix-revision.scm \
+ guix-data-service/model/build-server.scm \
+ guix-data-service/model/build-status.scm \
+ guix-data-service/model/build.scm \
+ guix-data-service/model/derivation.scm \
+ guix-data-service/model/guix-revision-package-derivation.scm \
+ guix-data-service/model/guix-revision.scm \
+ guix-data-service/model/package-derivation.scm \
+ guix-data-service/model/package-metadata.scm \
+ guix-data-service/model/package.scm \
+ guix-data-service/model/utils.scm \
+ guix-data-service/web/controller.scm \
+ guix-data-service/web/render.scm \
+ guix-data-service/web/server.scm \
+ guix-data-service/web/sxml.scm \
+ guix-data-service/web/util.scm \
guix-data-service/web/view/html.scm
diff --git a/guix-data-service/comparison.scm b/guix-data-service/comparison.scm
index e3190ad..8688f84 100644
--- a/guix-data-service/comparison.scm
+++ b/guix-data-service/comparison.scm
@@ -12,20 +12,56 @@
package-data-vhashes->new-packages
package-data-vhashes->removed-packages
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 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 (
- 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
-FULL OUTER JOIN target_packages ON base_packages.name = target_packages.name AND base_packages.version = target_packages.version
-WHERE (base_packages.id IS NULL OR target_packages.id IS NULL OR base_packages.id != target_packages.id)
-ORDER BY base_packages.name, base_packages.version, target_packages.name, target_packages.version")
+FULL OUTER JOIN target_packages
+ ON base_packages.name = target_packages.name
+ 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)))
@@ -40,7 +76,7 @@ ORDER BY base_packages.name, base_packages.version, target_packages.name, target
(apply values
(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
((base-package-data target-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))
(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)
(cons (third value)
result))
'()
vhash))
- (let* ((derivation-ids
- (vhash->derivation-ids packages-vhash))
+ (let* ((derivation-file-names
+ (vhash->derivation-file-names packages-vhash))
(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))
(define (package-data-vhash->package-name-and-version-vhash vhash)
(vhash-fold (lambda (name details result)
- (vhash-cons (cons name (first details))
- (cdr details)
- result))
+ (let ((key (cons name (first details))))
+ (vhash-cons key
+ (cons (cdr details)
+ (or (and=> (vhash-assoc key result) cdr)
+ '()))
+ (vhash-delete key result))))
vlist-null
vhash))
@@ -99,16 +140,29 @@ ORDER BY base_packages.name, base_packages.version, target_packages.name, target
base-packages-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)
(let ((version (first details))
- (known-versions (vhash-assoc name result)))
- (if known-versions
- (vhash-cons name
- (cons version known-versions)
- (vhash-delete name result))
- (vhash-cons name
- (list version)
- result))))
+ (known-versions (or (and=> (vhash-assoc name result) cdr)
+ '())))
+ (vhash-cons name
+ (add-version-system-and-target-to-alist known-versions
+ details)
+ (vhash-delete name result))))
vlist-null
package-data-vhash))
@@ -124,30 +178,42 @@ ORDER BY base_packages.name, base_packages.version, target_packages.name, target
(begin
(if (equal? base-versions target-versions)
result
- `((,name . ((base . ,base-versions)
- (target . ,target-versions)))
+ `((,name . ((base . ,(map car base-versions))
+ (target . ,(map car target-versions))))
,@result)))
result)))
'()
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
(package-data-vhash->package-name-and-version-vhash base-packages-vhash))
(define target-package-details-by-name-and-version
(package-data-vhash->package-name-and-version-vhash target-packages-vhash))
- (vhash-fold (lambda (name-and-version target-details result)
- (let ((base-packages-entry
- (vhash-assoc name-and-version base-package-details-by-name-and-version)))
- (if base-packages-entry
- (let ((base-details (cdr base-packages-entry)))
- (if (equal? base-details target-details)
- result
- `((,name-and-version . ((base . ,base-details)
- (target . ,target-details)))
- ,@result)))
- result)))
- '()
- target-package-details-by-name-and-version))
+ (define (derivation-system-and-target-list->alist lst)
+ (if (null? lst)
+ '()
+ `((,(cdr (first lst)) . ,(car (first lst)))
+ ,@(derivation-system-and-target-list->alist (cdr lst)))))
+
+ (vhash-fold
+ (lambda (name-and-version target-packages-entry result)
+ (let ((base-packages-entry
+ (vhash-assoc name-and-version
+ base-package-details-by-name-and-version)))
+ (if base-packages-entry
+ (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))
diff --git a/guix-data-service/jobs/load-new-guix-revision.scm b/guix-data-service/jobs/load-new-guix-revision.scm
index dcdd83e..23044ec 100644
--- a/guix-data-service/jobs/load-new-guix-revision.scm
+++ b/guix-data-service/jobs/load-new-guix-revision.scm
@@ -7,43 +7,104 @@
#:use-module (guix channels)
#:use-module (guix inferior)
#:use-module (guix profiles)
+ #:use-module (guix progress)
#:use-module (guix packages)
#:use-module (guix derivations)
#:use-module (guix build utils)
#:use-module (guix-data-service model package)
#: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 derivation)
#:export (process-next-load-new-guix-revision-job
select-job-for-commit
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))
(packages-metadata-ids
(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
conn
- (filter-map
- (lambda (package)
- (catch
- #t
- (lambda ()
- (inferior-package-derivation
- store package))
- (lambda args
- (simple-format
- #t "guix-data-service: inferior-guix->package-ids: error processing derivation ~A\n"
- package)
- (simple-format
- #t "guix-data-service: inferior-guix->package-ids: error: ~A\n" args)
- #f)))
- packages))))
+ (append-map
+ (lambda (system-targets-and-derivations)
+ (map third system-targets-and-derivations))
+ systems-targets-and-derivations-by-package)))
+ (flat-package-ids-systems-and-targets
+ (append-map
+ (lambda (package-id system-targets-and-derivations)
+ (map (match-lambda
+ ((system target derivation)
+ (list package-id
+ system
+ target)))
+ system-targets-and-derivations))
+ package-ids
+ systems-targets-and-derivations-by-package)))
+
+ (insert-package-derivations conn
+ flat-package-ids-systems-and-targets
+ derivation-ids)))
- (inferior-packages->package-ids
- conn packages packages-metadata-ids packages-derivation-ids)))
+(define (inferior-package-transitive-supported-systems package)
+ ((@@ (guix inferior) inferior-package-field)
+ package
+ 'package-transitive-supported-systems))
(define (guix-store-path store)
(let* ((guix-package (@ (gnu packages package-management)
@@ -140,17 +201,21 @@
(inferior-eval '(use-modules (guix grafts)) 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 conn url commit store_path)))
- (insert-guix-revision-packages conn guix-revision-id package-ids))
+ (insert-guix-revision-package-derivations conn
+ guix-revision-id
+ package-derivation-ids)
(exec-query conn "COMMIT")
(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)))
diff --git a/guix-data-service/model/derivation.scm b/guix-data-service/model/derivation.scm
index 305c260..b38efc7 100644
--- a/guix-data-service/model/derivation.scm
+++ b/guix-data-service/model/derivation.scm
@@ -5,16 +5,18 @@
#:use-module (squee)
#:use-module (guix base32)
#:use-module (guix inferior)
+ #:use-module (guix memoization)
#:use-module (guix derivations)
#:use-module (guix-data-service model utils)
#:export (select-derivation-by-file-name
select-derivation-outputs-by-derivation-id
select-derivation-by-output-filename
select-derivations-using-output
+ select-derivations-by-revision-name-and-version
select-derivation-inputs-by-derivation-id
select-existing-derivations
select-derivations-by-id
- select-derivations-and-build-status-by-id
+ select-derivations-and-build-status-by-file-name
insert-into-derivations
derivations->derivation-ids))
@@ -62,6 +64,36 @@
(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
derivation-id
names-and-derivation-outputs)
@@ -166,21 +198,22 @@
((result)
result)))
-(define (select-derivation-output-id conn name path)
- (match (exec-query
- conn
- (string-append
- "SELECT derivation_outputs.id FROM derivation_outputs "
- "INNER JOIN derivations ON "
- "derivation_outputs.derivation_id = derivations.id "
- "WHERE derivations.file_name = '" path "' "
- "AND derivation_outputs.name = '" name "';"))
- (((id))
- id)
- (()
- (error (simple-format
- #f "cannot find derivation-output with name ~A and path ~A"
- name path)))))
+(define select-derivation-output-id
+ (mlambda (conn name path)
+ (match (exec-query
+ conn
+ (string-append
+ "SELECT derivation_outputs.id FROM derivation_outputs "
+ "INNER JOIN derivations ON "
+ "derivation_outputs.derivation_id = derivations.id "
+ "WHERE derivations.file_name = '" path "' "
+ "AND derivation_outputs.name = '" name "';"))
+ (((id))
+ id)
+ (()
+ (error (simple-format
+ #f "cannot find derivation-output with name ~A and path ~A"
+ name path))))))
(define (select-derivation-outputs-by-derivation-id conn id)
(define query
@@ -211,7 +244,7 @@
(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)
(string-append "INSERT INTO derivation_inputs "
"(derivation_id, derivation_output_id) VALUES "
@@ -224,16 +257,19 @@
",")
";"))
- (match derivation-input
- (($ <derivation-input> path sub-derivations)
- (exec-query
- conn
- (insert-into-derivation-inputs
- (map (lambda (sub-derivation)
- (select-derivation-output-id conn
- sub-derivation
- path))
- sub-derivations))))))
+ (unless (null? derivation-inputs)
+ (exec-query
+ conn
+ (insert-into-derivation-inputs
+ (append-map
+ (match-lambda
+ (($ <derivation-input> path sub-derivations)
+ (map (lambda (sub-derivation)
+ (select-derivation-output-id conn
+ sub-derivation
+ path))
+ sub-derivations)))
+ derivation-inputs)))))
(define (select-from-derivation-source-files store-paths)
(string-append
@@ -304,7 +340,34 @@
(exec-query conn
(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)
(string-append
"INSERT INTO derivations "
@@ -331,24 +394,60 @@
" RETURNING id"
";"))
- (map (lambda (derivation-id derivation)
- (insert-derivation-outputs conn
- derivation-id
- (derivation-outputs derivation))
-
- (insert-derivation-sources conn
- derivation-id
- (derivation-sources derivation))
-
- (for-each (lambda (derivation-input)
- (insert-derivation-input conn
- derivation-id
- derivation-input))
- (derivation-inputs derivation))
-
- derivation-id)
- (map car (exec-query conn (insert-into-derivations)))
- derivations))
+ (simple-format
+ #t "debug: insert-missing-derivations: inserting ~A derivations\n"
+ (length derivations))
+ (let ((derivation-ids
+ (map car (exec-query conn (insert-into-derivations)))))
+
+ (simple-format
+ #t "debug: insert-missing-derivations: updating hash table\n")
+ (for-each (lambda (derivation derivation-id)
+ (hash-set! derivation-ids-hash-table
+ (derivation-file-name derivation)
+ derivation-id))
+ derivations
+ derivation-ids)
+
+ (simple-format
+ #t "debug: insert-missing-derivations: inserting outputs\n")
+ (for-each (lambda (derivation-id derivation)
+ (insert-derivation-outputs conn
+ derivation-id
+ (derivation-outputs derivation)))
+ derivation-ids
+ derivations)
+
+ (simple-format
+ #t "debug: insert-missing-derivations: inserting sources\n")
+ (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 query
@@ -363,10 +462,10 @@
(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
(string-append
- "SELECT derivations.id, derivations.file_name, latest_build_status.status "
+ "SELECT derivations.file_name, latest_build_status.status "
"FROM derivations "
"LEFT OUTER JOIN builds ON derivations.id = builds.derivation_id "
"LEFT OUTER JOIN "
@@ -375,60 +474,124 @@
"ORDER BY internal_build_id, status_fetched_at DESC"
") AS latest_build_status "
"ON builds.internal_id = latest_build_status.internal_build_id "
- "WHERE derivations.id IN "
- "(" (string-join (map (lambda (id)
- (simple-format #f "'~A'" id))
- ids)
+ "WHERE derivations.file_name IN "
+ "(" (string-join (map (lambda (file-name)
+ (simple-format #f "'~A'" file-name))
+ file-names)
",")
");"))
(exec-query conn query))
-(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))))
+(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)
(if (null? derivations)
'()
- (begin
- (ensure-input-derivations-exist)
+ (let* ((derivations-count (length derivations))
+ (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
derivations))
- (existing-derivation-entries (exec-query->vhash
- conn
- (select-existing-derivations
- derivation-file-names)
- second ;; file_name
- first)) ;; id
+ (existing-derivation-entries
+ (derivation-file-names->vhash conn
+ derivation-ids-hash-table
+ derivation-file-names))
(missing-derivations
- (filter (lambda (derivation)
- (not (vhash-assoc (derivation-file-name derivation)
- existing-derivation-entries)))
- derivations))
+ (deduplicate-derivations
+ (filter (lambda (derivation)
+ (not (vhash-assoc (derivation-file-name derivation)
+ existing-derivation-entries)))
+ derivations)))
(new-derivation-entries
(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
(two-lists->vhash (map derivation-file-name missing-derivations)
new-derivation-entries)))
+
(map (lambda (derivation-file-name)
(cdr
(or (vhash-assoc derivation-file-name
diff --git a/guix-data-service/model/guix-revision-package-derivation.scm b/guix-data-service/model/guix-revision-package-derivation.scm
new file mode 100644
index 0000000..733dad2
--- /dev/null
+++ b/guix-data-service/model/guix-revision-package-derivation.scm
@@ -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))
diff --git a/guix-data-service/model/guix-revision-package.scm b/guix-data-service/model/guix-revision-package.scm
deleted file mode 100644
index 2f710a4..0000000
--- a/guix-data-service/model/guix-revision-package.scm
+++ /dev/null
@@ -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))
diff --git a/guix-data-service/model/package-derivation.scm b/guix-data-service/model/package-derivation.scm
new file mode 100644
index 0000000..6e87765
--- /dev/null
+++ b/guix-data-service/model/package-derivation.scm
@@ -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)))
diff --git a/guix-data-service/model/package-metadata.scm b/guix-data-service/model/package-metadata.scm
index 429538b..bd6cbe6 100644
--- a/guix-data-service/model/package-metadata.scm
+++ b/guix-data-service/model/package-metadata.scm
@@ -9,6 +9,7 @@
#:use-module (guix inferior)
#:use-module (guix-data-service model utils)
#:export (select-package-metadata
+ select-package-metadata-by-revision-name-and-version
insert-package-metadata
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)
(string-append "INSERT INTO package_metadata "
"(sha1_hash, synopsis, description, home_page) "
diff --git a/guix-data-service/model/package.scm b/guix-data-service/model/package.scm
index b5a38fa..bb01986 100644
--- a/guix-data-service/model/package.scm
+++ b/guix-data-service/model/package.scm
@@ -7,75 +7,93 @@
#:use-module (guix-data-service model utils)
#:export (select-existing-package-entries
select-packages-in-revision
+ count-packages-in-revision
insert-into-package-entries
inferior-packages->package-ids))
(define (select-existing-package-entries package-entries)
(string-append "SELECT id, packages.name, packages.version, "
- "packages.package_metadata_id, packages.derivation_id "
+ "packages.package_metadata_id "
"FROM packages "
"JOIN (VALUES "
(string-join (map (lambda (package-entry)
(apply
simple-format
- #f "('~A', '~A', ~A, ~A)"
+ #f "('~A', '~A', ~A)"
package-entry))
package-entries)
", ")
- ") AS vals (name, version, package_metadata_id, derivation_id) "
+ ") AS vals (name, version, package_metadata_id) "
"ON packages.name = vals.name AND "
"packages.version = vals.version AND "
- "packages.package_metadata_id = vals.package_metadata_id AND "
- "packages.derivation_id = vals.derivation_id"
- ";"))
+ "packages.package_metadata_id = vals.package_metadata_id"))
(define (select-packages-in-revision conn commit-hash)
(define query
- (string-append
- "SELECT packages.name, packages.version, packages.derivation_id "
- "FROM packages "
- "INNER JOIN guix_revision_packages"
- " ON packages.id = guix_revision_packages.package_id "
- "INNER JOIN guix_revisions"
- " ON guix_revision_packages.revision_id = guix_revisions.id "
- "WHERE guix_revisions.commit = $1 "
- "ORDER BY packages.name, packages.version"))
+ "
+SELECT packages.name, packages.version, package_metadata.synopsis
+FROM packages
+INNER JOIN package_metadata
+ ON packages.package_metadata_id = 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
+)
+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)))
(define (insert-into-package-entries package-entries)
(string-append "INSERT INTO packages "
- "(name, version, package_metadata_id, derivation_id) VALUES "
+ "(name, version, package_metadata_id) VALUES "
(string-join
(map
(match-lambda
- ((name version package_metadata_id derivation_id)
- (simple-format #f "('~A', '~A', ~A, ~A)"
+ ((name version package_metadata_id)
+ (simple-format #f "('~A', '~A', ~A)"
name
version
- package_metadata_id
- derivation_id)))
+ package_metadata_id)))
package-entries)
",")
" 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
- (map (lambda (package metadata-id derivation-id)
+ (map (lambda (package metadata-id)
(list (inferior-package-name package)
(inferior-package-version package)
- metadata-id
- derivation-id))
+ metadata-id))
packages
- metadata-ids
- derivation-ids))
+ metadata-ids))
(let* ((existing-package-entry-ids
(exec-query->vhash conn
(select-existing-package-entries package-entries)
- ;; name, version, package_metadata_id and
- ;; derivation_id
+ ;; name, version and package_metadata_id
cdr
first)) ;;id
(missing-package-entries
diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm
index 9f436dc..a8dd897 100644
--- a/guix-data-service/web/controller.scm
+++ b/guix-data-service/web/controller.scm
@@ -29,6 +29,8 @@
#: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 package-derivation)
+ #:use-module (guix-data-service model package-metadata)
#:use-module (guix-data-service model derivation)
#:use-module (guix-data-service model build)
#:use-module (guix-data-service jobs load-new-guix-revision)
@@ -113,16 +115,16 @@
(version-changes
(package-data-version-changes base-packages-vhash
target-packages-vhash))
- (other-changes
- (package-data-other-changes base-packages-vhash
- target-packages-vhash)))
+ (derivation-changes
+ (package-data-derivation-changes base-packages-vhash
+ target-packages-vhash)))
(cond
((eq? content-type 'json)
(render-json
`((new-packages . ,new-packages)
(removed-packages . ,removed-packages)
(version-changes . ,version-changes)
- (other-changes . ,other-changes))))
+ (derivation-changes . ,derivation-changes))))
(else
(apply render-html
(compare base-commit
@@ -130,7 +132,7 @@
new-packages
removed-packages
version-changes
- other-changes)))))))
+ derivation-changes)))))))
(define (render-compare/derivations content-type
conn
@@ -138,6 +140,15 @@
base-revision-id
target-commit
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
(((base-packages-vhash target-packages-vhash)
(package-data->package-data-vhashes
@@ -156,9 +167,13 @@
((eq? content-type 'json)
(render-json
`((base . ((commit . ,base-commit)
- (derivations . ,base-derivations)))
+ (derivations . ,(list->vector
+ (derivations->alist
+ base-derivations)))))
(target . ((commit . ,target-commit)
- (derivations . ,target-derivations))))))
+ (derivations . ,(list->vector
+ (derivations->alist
+ target-derivations))))))))
(else
(apply render-html
(compare/derivations
@@ -174,11 +189,13 @@
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))
+ (delete-duplicates
+ (vhash-fold (lambda (name data result)
+ (cons `((name . ,name)
+ (version . ,(car data)))
+ result))
+ '()
+ vh)))
(let-values
(((base-packages-vhash target-packages-vhash)
@@ -189,10 +206,14 @@
(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)))))))
+ `((base
+ . ((commit . ,base-commit)
+ (packages . ,(list->vector
+ (package-data-vhash->json base-packages-vhash)))))
+ (target
+ . ((commit . ,target-commit)
+ (packages . ,(list->vector
+ (package-data-vhash->json target-packages-vhash))))))))
(else
(apply render-html
(compare/packages
@@ -227,14 +248,16 @@
(match derivation
(()
#f)
- ((derivation)
+ (derivations
(apply render-html
(view-store-item filename
- derivation
- (match derivation
- ((file-name output-id rest ...)
- (select-derivations-using-output
- conn output-id)))))))))
+ derivations
+ (map (lambda (derivation)
+ (match derivation
+ ((file-name output-id rest ...)
+ (select-derivations-using-output
+ conn output-id))))
+ derivations)))))))
(define (controller request body conn)
(match-lambda
@@ -249,13 +272,31 @@
((GET "revision" commit-hash)
(apply render-html
(view-revision commit-hash
- (select-packages-in-revision conn
- commit-hash))))
+ (count-packages-in-revision conn
+ 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)
(apply render-html
- (view-revision-package-and-version commit-hash
- name
- version)))
+ (view-revision-package-and-version
+ commit-hash
+ 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)
(if (string-suffix? ".drv" filename)
(render-derivation conn (string-append "/gnu/store/" filename))
diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm
index c7c353a..dcd2f15 100644
--- a/guix-data-service/web/view/html.scm
+++ b/guix-data-service/web/view/html.scm
@@ -23,9 +23,12 @@
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
+ #:use-module (texinfo)
+ #:use-module (texinfo html)
#:export (index
view-revision-package-and-version
view-revision
+ view-revision-packages
view-builds
view-derivation
view-store-item
@@ -171,7 +174,9 @@
(td ,source))))
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
#:extra-headers
'((cache-control . ((max-age . 60))))
@@ -181,9 +186,48 @@
(@ (class "container"))
(div
(@ (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
#:extra-headers
'((cache-control . ((max-age . 60))))
@@ -196,23 +240,78 @@
(h1 "Revision " (samp ,commit-hash)))
(div
(@ (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
- (@ (class "table"))
+ (@ (class "table table-responsive"))
(thead
(tr
(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
,@(map
(match-lambda
- ((name version rest ...)
+ ((name version synopsis)
`(tr
- (td (a (@ (href ,(string-append
- "/revision/" commit-hash
+ (td ,name)
+ (td ,version)
+ (td ,(stexi->shtml (texi-fragment->stexi synopsis)))
+ (td (@ (class "text-right"))
+ (a (@ (href ,(string-append
+ "/revision/" revision-commit-hash
"/package/" name "/" version)))
- ,name))
- (td ,version))))
+ "More information")))))
packages))))))))
(define (view-builds stats builds)
@@ -237,7 +336,7 @@
(match-lambda
((status count)
`(tr
- (td ,status)
+ (td ,(build-status-span status))
(td ,count))))
stats))))
(div
@@ -257,13 +356,8 @@
((build-id build-server-url derivation-file-name
status-fetched-at starttime stoptime status)
`(tr
- (td (@ (class ,(cond
- ((string=? status "succeeded")
- "bg-success")
- ((string=? status "failed")
- "bg-danger")
- (else ""))))
- ,status)
+ (td (@ (class "text-center"))
+ ,(build-status-span status))
(td (a (@ (href ,derivation-file-name))
,(display-store-item-short derivation-file-name)))
(td ,starttime)
@@ -273,6 +367,31 @@
"View build on " ,build-server-url)))))
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)
`((span (@ (style "font-size: small; font-family: monospace; display: block;"))
,(string-take item 44))
@@ -280,9 +399,9 @@
,(string-drop item 44))))
(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))
- (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))))
(define (display-store-item-title item)
@@ -300,7 +419,7 @@
,(string-append
"/" (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
#:extra-headers
'((cache-control . ((max-age . 60))))
@@ -311,28 +430,31 @@
(div
(@ (class "row"))
,(display-store-item-title filename))
- (div
- (@ (class "row"))
- (h4 "Derivation: ")
- ,(match derivation
- ((file-name output-id)
- `(a (@ (href ,file-name))
- ,(display-store-item file-name)))))
- (div
- (@ (class "row"))
- (h2 "Derivations using this store item "
- ,(let ((count (length derivations-using-store-item)))
- (if (eq? count 100)
- "(> 100)"
- (simple-format #f "(~A)" count))))
- (ul
- (@ (class "list-unstyled"))
- ,(map
- (match-lambda
- ((file-name)
- `(li (a (@ (href ,file-name))
- ,(display-store-item file-name)))))
- derivations-using-store-item)))))))
+ ,@(map (lambda (derivation derivations-using-store-item)
+ `((div
+ (@ (class "row"))
+ (h4 "Derivation: ")
+ ,(match derivation
+ ((file-name output-id)
+ `(a (@ (href ,file-name))
+ ,(display-store-item file-name)))))
+ (div
+ (@ (class "row"))
+ (h2 "Derivations using this store item "
+ ,(let ((count (length derivations-using-store-item)))
+ (if (eq? count 100)
+ "(> 100)"
+ (simple-format #f "(~A)" count))))
+ (ul
+ (@ (class "list-unstyled"))
+ ,(map
+ (match-lambda
+ ((file-name)
+ `(li (a (@ (href ,file-name))
+ ,(display-store-item file-name)))))
+ derivations-using-store-item)))))
+ derivations
+ derivations-using-store-item-list)))))
(define (view-derivation derivation derivation-inputs derivation-outputs
builds)
@@ -381,17 +503,22 @@
(td "System")
(td (samp ,system)))))))
(h3 "Build status")
- ,@(map
- (match-lambda
- ((build-id build-server-url status-fetched-at
- starttime stoptime status)
- `(div
- (@ (class "text-center"))
- (div ,status)
- (a (@ (href ,(simple-format
- #f "~Abuild/~A" build-server-url build-id)))
- "View build on " ,build-server-url))))
- builds))
+ ,@(if (null? builds)
+ `((div
+ (@ (class "text-center"))
+ ,(build-status-span "")))
+ (map
+ (match-lambda
+ ((build-id build-server-url status-fetched-at
+ starttime stoptime status)
+ `(div
+ (@ (class "text-center"))
+ (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
(@ (class "col-md-4"))
(h3 "Outputs")
@@ -413,7 +540,7 @@
new-packages
removed-packages
version-changes
- other-changes)
+ derivation-changes)
(define query-params
(string-append "?base_commit=" base-commit
"&target_commit=" target-commit))
@@ -516,24 +643,61 @@
version-changes)))))
(div
(@ (class "row"))
- (h3 "Other changed packages")
- ,@(if (null? other-changes)
- '((p "No other changes"))
- `((p "The metadata or derivation for these packages has changed.")
- (table
- (@ (class "table"))
- (thead
- (tr
- (th (@ (class "col-md-3")) "Name")
- (th (@ (class "col-md-9")) "Version")))
- (tbody
- ,@(map
- (match-lambda
- (((name . version) . (metadata-id derivation-id))
- `(tr
- (td ,name)
- (td ,version))))
- other-changes))))))))))
+ (h3 "Package derivation changes")
+ ,(if
+ (null? derivation-changes)
+ '(p "No derivation changes")
+ `(table
+ (@ (class "table")
+ (style "table-layout: fixed;"))
+ (thead
+ (tr
+ (th "Name")
+ (th "Version")
+ (th "System")
+ (th "Target")
+ (th (@ (class "col-xs-5")) "Derivations")))
+ (tbody
+ ,@(append-map
+ (match-lambda
+ (((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
target-commit
@@ -575,11 +739,11 @@
(tbody
,@(map
(match-lambda
- ((id file-name build-status)
+ ((file-name build-status)
`(tr
(td (a (@ (href ,file-name))
,(display-store-item file-name)))
- (td ,build-status))))
+ (td ,(build-status-span build-status)))))
base-derivations))))
(div
(@ (class "row"))
@@ -596,11 +760,11 @@
(tbody
,@(map
(match-lambda
- ((id file-name build-status)
+ ((file-name build-status)
`(tr
(td (a (@ (href ,file-name))
,(display-store-item file-name)))
- (td ,build-status))))
+ (td ,(build-status-span build-status)))))
target-derivations))))))))
(define (compare/packages base-commit
@@ -638,16 +802,25 @@
(@ (class "table"))
(thead
(tr
- (th (@ (class "col-md-6")) "Name")
- (th (@ (class "col-md-6")) "Version")))
+ (th (@ (class "col-md-4")) "Name")
+ (th (@ (class "col-md-4")) "Version")
+ (th (@ (class "col-md-4")) "")))
(tbody
,@(map
(match-lambda
- ((name version rest ...)
+ ((name version)
`(tr
(td ,name)
- (td ,version))))
- (vlist->list base-packages-vhash)))))
+ (td ,version)
+ (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
(@ (class "row"))
(h3 "Target ("
@@ -658,16 +831,25 @@
(@ (class "table"))
(thead
(tr
- (th (@ (class "col-md-6")) "Name")
- (th (@ (class "col-md-6")) "Version")))
+ (th (@ (class "col-md-4")) "Name")
+ (th (@ (class "col-md-4")) "Version")
+ (th (@ (class "col-md-4")) "")))
(tbody
,@(map
(match-lambda
- ((name version rest ...)
+ ((name version)
`(tr
(td ,name)
- (td ,version))))
- (vlist->list target-packages-vhash)))))))))
+ (td ,version)
+ (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
base-exists? target-exists?
generated by cgit v1.2.3 (git 2.25.4) at 2024-09-28 07:15:00 +0000