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

DRAFT database: Use records instead of alists.

This commit is contained in:
Ludovic Courtès 2023-08-14 23:44:51 +02:00
parent 95ca6edca5
commit e7b27b98e6
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
11 changed files with 1048 additions and 716 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

61
src/cuirass/base.scm
View File

@ -358,7 +358,7 @@ build products."
(let* ((build (db-get-build drv))
(spec (and build
(db-get-specification
(assq-ref build #:specification)))))
(build-specification-name build)))))
(when (and spec build)
(create-build-outputs build
(specification-build-outputs spec))))
@ -510,8 +510,8 @@ updating the database accordingly."
(define (build-derivation=? build1 build2)
"Return true if BUILD1 and BUILD2 correspond to the same derivation."
(string=? (assq-ref build1 #:derivation)
(assq-ref build2 #:derivation)))
(string=? (build-derivation build1)
(build-derivation build2)))
(define (clear-build-queue)
"Reset the status of builds in the database that are marked as \"started\".
@ -540,19 +540,23 @@ started)."
(spawn-builds store valid))
(log-info "done with restarted builds"))))
(define (create-build-outputs build build-outputs)
"Given BUILDS a list of built derivations, save the build products described
by BUILD-OUTPUTS."
(define (create-build-outputs build outputs)
"Given BUILDS, a list of <build> records, save the build products described by
OUTPUTS, a list of <build-output> records."
(define (build-has-products? job-regex)
(let ((job-name (assq-ref build #:job-name)))
(string-match job-regex job-name)))
(let ((job-name (build-job-name build)))
(pk 'has-prod? job-regex build
(string-match job-regex job-name))))
(define* (find-product build build-output)
(let* ((outputs (assq-ref build #:outputs))
(let* ((outputs (build-outputs build))
(output (build-output-output build-output))
(path (build-output-path build-output))
(root (and=> (assoc-ref outputs output)
(cut assq-ref <> #:path))))
(root (and=> (find (lambda (o)
(string=? (output-name o)
output))
(pk 'looking-for output 'outputs outputs))
output-item)))
(and root
(if (string=? path "")
root
@ -562,19 +566,19 @@ by BUILD-OUTPUTS."
(stat:size (stat file)))
(for-each (lambda (build-output)
(let ((product (and (build-has-products?
(build-output-job build-output))
(find-product build build-output))))
(when (and product (file-exists? product))
(log-info "Adding build product ~a" product)
(let ((file (and (build-has-products?
(build-output-job build-output))
(find-product build build-output))))
(when (and file (file-exists? file))
(log-info "Adding build product ~a" file)
(db-add-build-product
`((#:build . ,(assq-ref build #:id))
(#:type . ,(build-output-type build-output))
(#:file-size . ,(file-size product))
;; TODO: Implement it.
(#:checksum . "")
(#:path . ,product))))))
build-outputs))
(build-product
(build-id (build-id build))
(type (build-output-type build-output))
(file file)
(file-size (file-size file))
(checksum "")))))) ;TODO: Implement it.
outputs))
(define (build-packages store eval-id)
"Build JOBS and return a list of Build results."
@ -582,7 +586,7 @@ by BUILD-OUTPUTS."
(db-get-builds `((evaluation . ,eval-id))))
(define derivations
(map (cut assq-ref <> #:derivation) builds))
(map built-derivations builds))
;; Register a GC root for each derivation so that they are not garbage
;; collected before getting built.
@ -597,15 +601,12 @@ by BUILD-OUTPUTS."
(spawn-builds store derivations)
(let* ((results (filter-map (cut db-get-build <>) derivations))
(status (map (cut assq-ref <> #:status) results))
(status (map build-current-status results))
(success (count (lambda (status)
(= status (build-status succeeded)))
status))
(outputs (map (cut assq-ref <> #:outputs) results))
(outs (append-map (match-lambda
(((_ (#:path . (? string? outputs))) ...)
outputs))
outputs))
(outputs (map build-outputs results))
(outs (append-map build-output-path outputs))
(fail (- (length derivations) success)))
(log-info "outputs:\n~a" (string-join outs "\n"))

672
src/cuirass/database.scm
View File

@ -30,6 +30,7 @@
#:use-module (cuirass remote)
#:use-module (cuirass specification)
#:use-module (cuirass utils)
#:use-module (guix records)
#:use-module (guix channels)
#:use-module (squee)
#:use-module ((fibers scheduler) #:select (current-scheduler))
@ -45,7 +46,94 @@
#:use-module (srfi srfi-26)
#:use-module (system foreign)
#:use-module (rnrs bytevectors)
#:export (;; Procedures.
#:export (;; Data types.
output?
output-item
output-derivation
output-name
job?
job-build-id
job-status
job-name
output?
output
output-name
output-derivation
output-item
evaluation?
evaluation-id
evaluation-specification-name
evaluation-current-status
evaluation-start-time
evaluation-checkout-time
evaluation-completion-time
evaluation-checkouts
build?
build
build-id
build-derivation
build-dependencies
build-job-name
build-system
build-nix-name
build-log
build-priority
build-max-silent-time
build-timeout
build-outputs
build-evaluation-id
build-specification-name
build-current-status
build-last-status
build-current-weather
build-creation-time
build-start-time
build-completion-time
build-worker
build-products
build-dependencies/id
build-product
build-product-id
build-product-type
build-product-file
build-product-file-size
build-product-checksum
checkout?
checkout-commit
checkout-channel
checkout-directory
build-summary?
build-summary-evaluation-id
build-summary-status
build-summary-checkouts
build-summary-succeeded
build-summary-failed
build-summary-scheduled
evaluation-summary?
evaluation-summary-id
evaluation-summary-status
evaluation-summary-total
evaluation-summary-succeeded
evaluation-summary-failed
evaluation-summary-scheduled
evaluation-summary-start-time
evaluation-summary-checkout-time
evaluation-summary-completion-time
dashboard?
dashboard-id
dashboard-specification-name
dashboard-job-ids
;; Procedures.
db-init
db-open
db-close
@ -628,44 +716,109 @@ RETURNING id;"))
((and (> status 0) (> last-status 0))
(build-weather still-failing))))
(define (db-add-output derivation output)
(define-record-type* <build> build make-build
build?
this-build
(id build-id (default 0))
(derivation build-derivation)
(dependencies build-dependencies ;list of ".drv" file names
(thunked)
(default
(if (= 0 (build-id this-build))
'() ;not yet in database
(db-get-build-dependencies/derivation
(build-id this-build)))))
(job-name build-job-name)
(system build-system)
(nix-name build-nix-name)
(log build-log (default ""))
(priority build-priority (default max-priority))
(max-silent-time build-max-silent-time (default 3600))
(timeout build-timeout (default (* 12 3600)))
(outputs build-outputs)
(evaluation-id build-evaluation-id)
(specification-name build-specification-name)
(status build-current-status
(default (build-status scheduled)))
(last-status build-last-status
(default (build-status scheduled)))
(weather build-current-weather
(default (build-weather unknown)))
(creation-time build-creation-time
(default (time-second (current-time time-utc))))
(start-time build-start-time (default 0))
(completion-time build-completion-time (default 0))
(worker build-worker (default #f))
(products build-products
(thunked)
(default
(if (= 0 (build-id this-build))
'()
(db-get-build-products (build-id this-build))))))
(define (set-build-id b id)
(build (inherit b) (id id)))
(define-record-type* <build-product> build-product make-build-product
build-product?
(id build-product-id (default 0))
(build-id build-product-build-id)
(type build-product-type)
(file build-product-file)
(file-size build-product-file-size)
(checksum build-product-checksum))
(define-record-type* <job> job make-job
job?
(build-id job-build-id) ;integer
(evaluation-id job-evaluation-id) ;integer
(status job-status) ;integer
(system job-system) ;string
(name job-name)) ;string
(define-record-type* <output> output make-output
output?
(item output-item) ;string
(derivation output-derivation) ;string
(name output-name (default "out"))) ;string
(define (db-add-output output)
"Insert OUTPUT associated with DERIVATION."
(with-db-worker-thread db
(match output
((name . path)
(exec-query/bind db "\
(exec-query/bind db "\
INSERT INTO Outputs (derivation, name, path) VALUES ("
derivation ", " name ", " path ")
ON CONFLICT ON CONSTRAINT outputs_pkey DO NOTHING;")))))
(output-derivation output) ", " (output-name output)
", " (output-item output) ")
ON CONFLICT ON CONSTRAINT outputs_pkey DO NOTHING;")))
(define (db-add-build build)
"Store BUILD in database the database only if one of its outputs is new.
Return #f otherwise. BUILD outputs are stored in the OUTPUTS table."
(with-db-worker-thread db
(exec-query/bind db "
(match (with-db-worker-thread db
(exec-query/bind db "
INSERT INTO Builds (derivation, evaluation, job_name, system, nix_name, log,
status, priority, max_silent, timeout, timestamp, starttime, stoptime)
VALUES ("
(assq-ref build #:derivation) ", "
(assq-ref build #:eval-id) ", "
(assq-ref build #:job-name) ", "
(assq-ref build #:system) ", "
(assq-ref build #:nix-name) ", "
(assq-ref build #:log) ", "
(or (assq-ref build #:status)
(build-status scheduled)) ", "
(or (assq-ref build #:priority) max-priority) ", "
(or (assq-ref build #:max-silent) 0) ", "
(or (assq-ref build #:timeout) 0) ", "
(or (assq-ref build #:timestamp) 0) ", "
(or (assq-ref build #:starttime) 0) ", "
(or (assq-ref build #:stoptime) 0) ")
(build-derivation build) ", "
(build-evaluation-id build) ", "
(build-job-name build) ", "
(build-system build) ", "
(build-nix-name build) ", "
(build-log build) ", "
(build-current-status build) ", "
(build-priority build) ", "
(build-max-silent-time build) ", "
(build-timeout build) ", "
(build-creation-time build) ", "
(build-start-time build) ", "
(build-completion-time build) ")
ON CONFLICT ON CONSTRAINT builds_derivation_key DO NOTHING;"))
(let* ((derivation (assq-ref build #:derivation))
(outputs (assq-ref build #:outputs))
(new-outputs (filter-map (cut db-add-output derivation <>)
outputs)))
derivation))
(0 ;a build for this derivation already exists
#f)
((? integer? id)
(for-each db-add-output (build-outputs build))
id)))
(define (db-add-build-product product)
"Insert PRODUCT into BuildProducts table."
@ -673,11 +826,11 @@ ON CONFLICT ON CONSTRAINT builds_derivation_key DO NOTHING;"))
(exec-query/bind db "\
INSERT INTO BuildProducts (build, type, file_size, checksum,
path) VALUES ("
(assq-ref product #:build) ", "
(assq-ref product #:type) ", "
(assq-ref product #:file-size) ", "
(assq-ref product #:checksum) ", "
(assq-ref product #:path) ")
(build-product-build-id product) ", "
(build-product-type product) ", "
(build-product-file-size product) ", "
(build-product-checksum product) ", "
(build-product-file product) ")
ON CONFLICT ON CONSTRAINT buildproducts_pkey DO NOTHING;")))
(define (db-get-output path)
@ -688,8 +841,7 @@ WHERE path =" path "
LIMIT 1;")
(() #f)
(((derivation name))
`((#:derivation . ,derivation)
(#:name . ,name))))))
(output (item path) (derivation derivation) (name name))))))
(define (db-get-outputs derivation)
"Retrieve the OUTPUTS of the build identified by DERIVATION in the
@ -704,7 +856,7 @@ WHERE derivation =" derivation ";"))
(((name path)
. rest)
(loop rest
(cons `(,name . ((#:path . ,path)))
(cons (output (name name) (item path) (derivation derivation))
outputs)))))))
(define (db-get-time-since-previous-eval specification)
@ -717,19 +869,23 @@ WHERE specification = " specification
"ORDER BY Evaluations.timestamp DESC LIMIT 1"))
((time)
(string->number time))
(else #f))))
(_ #f))))
(define (db-get-build-percentages builds)
"Return the list of \"build percentages\" for BUILDS."
(define build-ids
(format #f "{~a}"
(string-join
(map number->string
(map (cut assq-ref <> #:id) builds))
(map (compose number->string build-id) builds)
",")))
(with-db-worker-thread db
(let loop ((rows
(exec-query/bind db "
(map (match-lambda
((id percentage)
(list (string->number id)
(string->number percentage))))
(exec-query/bind db "
SELECT id, CASE WHEN last_duration = 0 THEN
0 ELSE LEAST(duration::float/last_duration * 100, 100)::int END AS percentage
FROM (SELECT DISTINCT ON (b1.id) b1.id AS id,
@ -738,34 +894,30 @@ COALESCE((b2.stoptime - b2.starttime), 0) AS last_duration,
LEFT JOIN builds AS b2 ON b1.job_name = b2.job_name
AND b2.status >= 0 AND b2.status < 2 WHERE b1.id IN
(SELECT id FROM builds WHERE id = ANY(" build-ids "))
ORDER BY b1.id, b2.id DESC) d;"))
ORDER BY b1.id, b2.id DESC) d;")))
(percentages '()))
(match rows
(() (reverse percentages))
(((id percentage) . rest)
(let ((build
(find (lambda (build)
(eq? (assq-ref build #:id)
(string->number id)))
builds)))
(loop rest
(cons `(,@build
(#:percentage . ,(string->number percentage)))
percentages))))))))
(map (lambda (build)
(match (assoc (build-id build) rows)
((_ percentage)
percentage)))
builds))))
(define (db-add-job job eval-id)
(define (db-add-job-for-build build)
"Insert JOB into Jobs table for the EVAL-ID evaluation. It is possible that
another already built derivation has the same build outputs that the JOB
derivation. In that case, the JOB DERIVATION field is set to the existing
derivation sharing the same build outputs, otherwise it is set to the given
JOB derivation."
(let* ((name (assq-ref job #:job-name))
(derivation (assq-ref job #:derivation))
(outputs (assq-ref job #:outputs))
(output (match outputs
(((name . path) _ ...)
path)))
(system (assq-ref job #:system)))
(let* ((job (job (build-id (build-id build))
(evaluation-id (build-evaluation-id build))
(status (build-current-status build))
(system (build-system build))
(name (build-job-name build))))
(name (job-name job))
(derivation (build-derivation build))
(outputs (build-outputs build))
(output (output-item (first outputs)))
(system (job-system job)))
(with-db-worker-thread db
(exec-query/bind db "\
WITH b AS
@ -773,9 +925,12 @@ WITH b AS
(SELECT COALESCE((SELECT derivation FROM Outputs WHERE
PATH = " output "), " derivation ")))
INSERT INTO Jobs (name, evaluation, build, status, system)
(SELECT " name ", " eval-id ", b.id, b.status," system " FROM b)
(SELECT " name ", " (build-evaluation-id build) ", b.id, b.status," system " FROM b)
ON CONFLICT ON CONSTRAINT jobs_pkey DO NOTHING;"))))
(define (job-build job)
(db-get-build (job-build-id job)))
(define (db-get-jobs eval-id filters)
"Return the jobs inside Jobs table for the EVAL-ID evaluation that are
matching the given FILTERS. FILTERS is an assoc list whose possible keys are
@ -785,7 +940,7 @@ the symbols system and names."
(with-db-worker-thread db
(let ((query "
SELECT build, status, name FROM Jobs
SELECT build, status, name, evaluation, system FROM Jobs
WHERE Jobs.evaluation = :evaluation
AND ((Jobs.system = :system) OR :system IS NULL)
AND ((Jobs.name = ANY(:names)) OR :names IS NULL)
@ -799,14 +954,30 @@ ORDER BY Jobs.name")
(jobs '()))
(match rows
(() (reverse jobs))
(((id status name)
. rest)
(((id status name evaluation system) . rest)
(loop rest
(cons `((#:build . ,(string->number id))
(#:status . ,(string->number status))
(#:name . ,name))
(cons (job (build-id (string->number id))
(status (string->number status))
(name name)
(evaluation-id evaluation)
(system system))
jobs))))))))
(define-record-type* <evaluation> evaluation make-evaluation
evaluation?
this-evaluation
(id evaluation-id)
(specification-name evaluation-specification-name)
(status evaluation-current-status
(default (evaluation-status started)))
(start-time evaluation-start-time)
(checkout-time evaluation-checkout-time (default 0))
(completion-time evaluation-completion-time (default 0))
(checkouts evaluation-checkouts
(thunked)
(default (db-get-checkouts
(evaluation-id this-evaluation)))))
(define* (db-get-jobs-history names
#:key spec (limit 10))
"Return the list of jobs from Jobs table which name is a member of the given
@ -848,6 +1019,7 @@ AND Jobs.name = ANY(:names);")
(begin
(assq-set! eval #:jobs (cons job jobs))
evaluations)
;; TODO: Define a record type.
(cons `((#:evaluation . ,(string->number evaluation))
(#:checkouts . ,(db-get-checkouts evaluation))
(#:jobs . ,(list job)))
@ -880,6 +1052,22 @@ SELECT target FROM BuildDependencies WHERE source = " build))
(loop rest
(cons (string->number target) dependencies)))))))
(define (db-get-build-dependencies/derivation build)
"Return the list of derivations (\".drv\" file names) BUILD depends on."
(with-db-worker-thread db
(let loop ((rows (exec-query/bind db "
SELECT Builds.derivation FROM Builds
INNER JOIN BuildDependencies AS dep ON dep.target = Builds.id
WHERE dep.source = " build))
(dependencies '()))
(match rows
(() (reverse dependencies))
(((target) . rest)
(loop rest
(cons target dependencies)))))))
(define build-dependencies/id (compose db-get-build-dependencies build-id))
(define (db-update-resumable-builds!)
"Update the build status of the failed-dependency builds which all
dependencies are successful to scheduled."
@ -909,13 +1097,14 @@ INNER JOIN Builds AS dep ON bd.target = dep.id AND dep.status > 0
WHERE Builds.status = " (build-status scheduled)
" GROUP BY Builds.id) AS deps WHERE deps.id = Builds.id")))
(define (db-register-builds jobs eval-id specification)
(define (db-register-builds builds specification)
(define (new-outputs? outputs)
(let ((new-outputs
(filter-map (match-lambda
((name . path)
(let ((drv (db-get-output path)))
(and (not drv) path))))
(filter-map (lambda (output)
(let ((drv (db-get-output
(output-item output))))
(and (not drv)
(output-item output))))
outputs)))
(not (null? new-outputs))))
@ -923,59 +1112,31 @@ WHERE Builds.status = " (build-status scheduled)
(let ((spec-priority (specification-priority specification)))
(+ (* spec-priority 10) priority)))
(define (register job)
(let* ((drv (assq-ref job #:derivation))
(job-name (assq-ref job #:job-name))
(system (assq-ref job #:system))
(nix-name (assq-ref job #:nix-name))
(log (assq-ref job #:log))
(priority (or (assq-ref job #:priority) max-priority))
(max-silent (assq-ref job #:max-silent-time))
(timeout (assq-ref job #:timeout))
(outputs (assq-ref job #:outputs))
(cur-time (time-second (current-time time-utc)))
(result
(and (new-outputs? outputs)
(let ((build `((#:derivation . ,drv)
(#:eval-id . ,eval-id)
(#:job-name . ,job-name)
(#:system . ,system)
(#:nix-name . ,nix-name)
;; XXX: We'd leave LOG to #f (i.e., NULL) but
;; that currently violates the non-NULL
;; constraint.
(#:log . ,(or log ""))
(#:status . ,(build-status scheduled))
(#:priority . ,(build-priority priority))
(#:max-silent . ,max-silent)
(#:timeout . ,timeout)
(#:outputs . ,outputs)
(#:timestamp . ,cur-time)
(#:starttime . 0)
(#:stoptime . 0))))
(db-add-build build)
job))))
(define (register build)
(let ((result (and (new-outputs? (build-outputs build))
(and=> (db-add-build build)
(cut set-build-id build <>)))))
;; Always register JOB inside the Jobs table. If there are new outputs,
;; JOB will refer to the newly created build. Otherwise, it will refer
;; to the last build with the same build outputs.
(db-add-job job eval-id)
(db-add-job-for-build (or result build))
result))
(define (register-dependencies job)
(let ((drv (assq-ref job #:derivation))
(inputs (or (assq-ref job #:inputs) '())))
(define (register-dependencies build)
(let ((drv (build-derivation build))
(inputs (build-dependencies build)))
(db-add-build-dependencies drv inputs)))
(with-db-worker-thread db
(log-info "Registering builds for evaluation ~a." eval-id)
(log-info "Registering builds for evaluation~{ ~a~}."
(delete-duplicates
(map build-evaluation-id builds)))
(exec-query db "BEGIN TRANSACTION;")
(let ((new-jobs (filter-map register jobs)))
(let ((builds (filter-map register builds)))
;; Register build dependencies after registering all the evaluation
;; derivations.
(for-each register-dependencies new-jobs)
(for-each register-dependencies builds)
(exec-query db "COMMIT;")
#t)))
@ -1042,7 +1203,7 @@ UPDATE Builds SET stoptime =" now
" AND status != " status ";")))
(when (positive? rows)
(let* ((build (db-get-build drv))
(spec (assq-ref build #:specification))
(spec (build-specification-name build))
(specification (db-get-specification spec))
(notifications
(specification-notifications specification)))
@ -1052,7 +1213,7 @@ UPDATE Builds SET stoptime =" now
(eq? weather
(build-weather new-failure)))
(db-push-notification notif
(assq-ref build #:id))))
(build-id build))))
notifications)))))))
(define* (db-update-build-worker! drv worker)
@ -1138,14 +1299,14 @@ WHERE build = " build-id))
(products '()))
(match rows
(() (reverse products))
(((id type file-size checksum path)
. rest)
(((id type file-size checksum path) . rest)
(loop rest
(cons `((#:id . ,(string->number id))
(#:type . ,type)
(#:file-size . ,(string->number file-size))
(#:checksum . ,checksum)
(#:path . ,path))
(cons (build-product (id (string->number id))
(build-id build-id)
(type type)
(file-size (string->number file-size))
(checksum checksum)
(file path))
products)))))))
(define (db-get-builds-by-search filters)
@ -1157,7 +1318,8 @@ border-low-id, border-high-id, and nr."
SELECT * FROM
(SELECT Builds.id, Builds.timestamp,
Builds.starttime,Builds.stoptime, Builds.log, Builds.status,
Builds.job_name, Builds.system, Builds.nix_name, Specifications.name
Builds.job_name, Builds.system, Builds.nix_name, Builds.evaluation,
Builds.derivation, Specifications.name, Builds.worker
FROM Builds
INNER JOIN Evaluations ON Builds.evaluation = Evaluations.id
INNER JOIN Specifications ON Evaluations.specification = Specifications.name
@ -1187,20 +1349,28 @@ ORDER BY Builds.id DESC;"))
(match builds
(() (reverse result))
(((id timestamp starttime stoptime log status job-name
system nix-name specification)
system nix-name evaluation-id derivation specification
worker)
. rest)
(loop rest
(cons `((#:id . ,(string->number id))
(#:timestamp . ,(string->number timestamp))
(#:starttime . ,(string->number starttime))
(#:stoptime . ,(string->number stoptime))
(#:log . ,log)
(#:status . ,(string->number status))
(#:job-name . ,job-name)
(#:system . ,system)
(#:nix-name . ,nix-name)
(#:specification . ,specification)
(#:buildproducts . ,(db-get-build-products id)))
(cons (build (id (string->number id))
(derivation derivation)
(creation-time (string->number timestamp))
(start-time (string->number starttime))
(completion-time (string->number stoptime))
(log log)
(status (string->number status))
(job-name job-name)
(system system)
(nix-name nix-name)
(evaluation-id evaluation-id)
(specification-name specification)
(worker worker)
(max-silent-time *unspecified*)
(timeout *unspecified*)
;; FIXME: The following one would require an
;; extra JOIN.
(outputs *unspecified*))
result))))))))
(define (db-get-builds filters)
@ -1273,9 +1443,11 @@ OR :borderhightime IS NULL OR :borderhighid IS NULL)")))
'()
(map car filters))))
(define (format-outputs names paths)
(define (format-outputs names paths derivation)
(map (lambda (name path)
`(,name . ((#:path . ,path))))
(output (name name)
(item path)
(derivation derivation)))
(string-split names #\,)
(string-split paths #\,)))
@ -1286,11 +1458,12 @@ OR :borderhightime IS NULL OR :borderhighid IS NULL)")))
'()))
(map (lambda (id type file-size checksum path)
`((#:id . ,(string->number id))
(#:type . ,type)
(#:file-size . ,(string->number file-size))
(#:checksum . ,checksum)
(#:path . ,path)))
(build-product (id (string->number id))
(build-id *unspecified*) ;FIXME
(type type)
(file-size (string->number file-size))
(checksum checksum)
(file path)))
(split ids)
(split types)
(split file-sizes)
@ -1298,6 +1471,7 @@ OR :borderhightime IS NULL OR :borderhighid IS NULL)")))
(split paths)))
(define (format-build-dependencies dependencies)
;; FIXME: Should return a list of derivations.
(if dependencies
(map string->number (string-split dependencies #\,))
'()))
@ -1359,8 +1533,8 @@ ORDER BY ~a;"
(map number->string value)
",")))
('nr value)
('order #f) ; Doesn't need binding.
('status #f) ; Doesn't need binding.
('order #f) ; Doesn't need binding.
('status #f) ; Doesn't need binding.
(else value)))))
filters))
(builds (exec-query/bind-params db query params)))
@ -1376,37 +1550,38 @@ ORDER BY ~a;"
products-checksum products-path dependencies)
. rest)
(loop rest
(cons `((#:derivation . ,derivation)
(#:id . ,(string->number id))
(#:timestamp . ,(string->number timestamp))
(#:starttime . ,(string->number starttime))
(#:stoptime . ,(string->number stoptime))
(#:log . ,log)
(#:status . ,(string->number status))
(#:last-status . ,(and last-status
(cons (build (derivation derivation)
(id (string->number id))
(creation-time (string->number timestamp))
(start-time (string->number starttime))
(completion-time (string->number stoptime))
(log log)
(status (string->number status))
(last-status (and last-status
(string->number last-status)))
(#:weather . ,(if weather
(weather (if weather
(string->number weather)
(build-weather unknown)))
(#:priority . ,(string->number priority))
(#:max-silent . ,(string->number max-silent))
(#:timeout . ,(string->number timeout))
(#:job-name . ,job-name)
(#:system . ,system)
(#:worker . ,worker)
(#:nix-name . ,nix-name)
(#:eval-id . ,(string->number eval-id))
(#:specification . ,specification)
(#:builddependencies .
,(format-build-dependencies dependencies))
(#:outputs . ,(format-outputs outputs-name
outputs-path))
(#:buildproducts .
,(format-build-products products-id
products-type
products-file-size
products-checksum
products-path)))
(priority (string->number priority))
(max-silent-time (string->number max-silent))
(timeout (string->number timeout))
(job-name job-name)
(system system)
(worker worker)
(nix-name nix-name)
(evaluation-id (string->number eval-id))
(specification-name specification)
;; (dependencies
;; (format-build-dependencies dependencies))
(outputs (format-outputs outputs-name
outputs-path
derivation))
(products
(format-build-products products-id
products-type
products-file-size
products-checksum
products-path)))
result))))))))
(define (db-get-build derivation-or-id)
@ -1439,6 +1614,12 @@ SELECT id FROM pending_dependencies WHERE deps = 0 LIMIT 1;"))
((id) (db-get-build (string->number id)))
(else #f))))
(define-record-type* <checkout> checkout make-checkout
checkout?
(commit checkout-commit)
(channel checkout-channel)
(directory checkout-directory))
(define (db-get-checkouts eval-id)
(with-db-worker-thread db
(let loop ((rows (exec-query/bind
@ -1447,12 +1628,11 @@ WHERE evaluation =" eval-id " ORDER BY channel ASC;"))
(checkouts '()))
(match rows
(() (reverse checkouts))
(((revision channel directory)
. rest)
(((revision channel directory) . rest)
(loop rest
(cons `((#:commit . ,revision)
(#:channel . ,(string->symbol channel))
(#:directory . ,directory))
(cons (checkout (commit revision)
(channel (string->symbol channel))
(directory directory))
checkouts)))))))
(define (db-get-latest-checkout spec channel eval-id)
@ -1465,20 +1645,9 @@ specification with an evaluation id inferior or equal to EVAL-ID."
" AND evaluation <= " eval-id "ORDER BY evaluation DESC LIMIT 1;")
(() #f)
(((channel revision directory))
`((#:commit . ,revision)
(#:channel . ,(string->symbol channel))
(#:directory . ,directory))))))
(define (parse-evaluation evaluation)
(match evaluation
((id specification status timestamp checkouttime evaltime)
`((#:id . ,(string->number id))
(#:specification . ,specification)
(#:status . ,(string->number status))
(#:timestamp . ,(string->number timestamp))
(#:checkouttime . ,(string->number checkouttime))
(#:evaltime . ,(string->number evaltime))
(#:checkouts . ,(db-get-checkouts id))))))
(checkout (commit revision)
(channel (string->symbol channel))
(directory directory))))))
(define (db-get-evaluation id)
(with-db-worker-thread db
@ -1489,6 +1658,16 @@ FROM Evaluations WHERE id = " id)
((evaluation)
(parse-evaluation evaluation)))))
(define (parse-evaluation lst)
(match lst
((id specification status timestamp checkouttime evaltime)
(evaluation (id (string->number id))
(specification-name specification)
(status (string->number status))
(completion-time (string->number timestamp))
(checkout-time (string->number checkouttime))
(start-time (string->number evaltime))))))
(define* (db-get-evaluations limit
#:optional spec)
(with-db-worker-thread db
@ -1509,6 +1688,19 @@ ORDER BY id DESC LIMIT :limit;")
(loop rest
(cons (parse-evaluation evaluation) evaluations))))))))
(define-record-type* <build-summary> build-summary make-build-summary
build-summary?
this-build-summary
(evaluation-id build-summary-evaluation-id)
(status build-summary-status)
(checkouts build-summary-checkouts
(thunked)
(default (db-get-checkouts
(build-summary-evaluation-id this-build-summary))))
(succeeded build-summary-succeeded (default 0))
(failed build-summary-failed (default 0))
(scheduled build-summary-scheduled (default 0)))
(define (db-get-evaluations-build-summary spec limit border-low border-high)
(with-db-worker-thread db
(let ((query "
@ -1531,18 +1723,20 @@ ORDER BY E.id DESC;")
(#:borderlow . ,border-low)
(#:borderhigh . ,border-high))))
(let loop ((rows (exec-query/bind-params db query params))
(evaluations '()))
(summaries '()))
(match rows
(() (reverse evaluations))
(()
(reverse summaries))
(((id status succeeded failed scheduled) . rest)
(loop rest
(cons `((#:id . ,(string->number id))
(#:status . ,(string->number status))
(#:checkouts . ,(db-get-checkouts id))
(#:succeeded . ,(or (string->number succeeded) 0))
(#:failed . ,(or (string->number failed) 0))
(#:scheduled . ,(or (string->number scheduled) 0)))
evaluations))))))))
(cons (build-summary
(evaluation-id (string->number id))
(status (string->number status))
(checkouts (db-get-checkouts id))
(succeeded (or (string->number succeeded) 0))
(failed (or (string->number failed) 0))
(scheduled (or (string->number scheduled) 0)))
summaries))))))))
(define (db-get-previous-eval eval-id)
"Return the successful evaluation preceeding EVAL-ID, for the same
@ -1615,14 +1809,24 @@ GROUP BY Evaluations.specification;") ))
(evaluations '()))
(match rows
(() (reverse evaluations))
(((specification evaluation)
. rest)
(((specification evaluation) . rest)
(loop rest
(cons `((#:specification . ,specification)
(#:evaluation
. ,(and=> (string->number evaluation)
db-get-evaluation)))
evaluations)))))))
(match (string->number evaluation)
(#f evaluations)
(id (cons (db-get-evaluation id) evaluations)))))))))
(define-record-type* <evaluation-summary>
evaluation-summary make-evaluation-summary
evaluation-summary?
(id evaluation-summary-id)
(status evaluation-summary-status)
(total evaluation-summary-total)
(succeeded evaluation-summary-succeeded)
(failed evaluation-summary-failed)
(scheduled evaluation-summary-scheduled)
(start-time evaluation-summary-start-time)
(checkout-time evaluation-summary-checkout-time)
(completion-time evaluation-summary-completion-time))
(define (db-get-evaluation-summary id)
(with-db-worker-thread db
@ -1642,16 +1846,17 @@ WHERE Evaluations.id = " id
ORDER BY Evaluations.id ASC;"))
((id status timestamp checkouttime evaltime
total succeeded failed scheduled)
`((#:id . ,(string->number id))
(#:status . ,(string->number status))
(#:total . ,(or (string->number total) 0))
(#:timestamp . ,(string->number timestamp))
(#:checkouttime . ,(string->number checkouttime))
(#:evaltime . ,(string->number evaltime))
(#:succeeded . ,(or (string->number succeeded) 0))
(#:failed . ,(or (string->number failed) 0))
(#:scheduled . ,(or (string->number scheduled) 0))))
(else #f))))
(evaluation-summary
(id (string->number id))
(status (string->number status))
(total (or (string->number total) 0))
(start-time (string->number timestamp))
(checkout-time (string->number checkouttime))
(completion-time (string->number evaltime))
(succeeded (or (string->number succeeded) 0))
(failed (or (string->number failed) 0))
(scheduled (or (string->number scheduled) 0))))
(_ #f))))
(define (db-get-evaluation-absolute-summary evaluation)
(expect-one-row
@ -1665,7 +1870,7 @@ ORDER BY Evaluations.id ASC;"))
(number->string
(if (number? eval)
eval
(assq-ref eval #:id))))
(build-summary-evaluation-id eval))))
evaluations)
",")))
@ -1686,11 +1891,17 @@ GROUP BY Jobs.evaluation;"))
(() (reverse summary))
(((total succeeded failed scheduled evaluation) . rest)
(loop rest
(cons `((#:evaluation . ,(number evaluation))
(#:total . ,(number total))
(#:succeeded . ,(number succeeded))
(#:failed . ,(number failed))
(#:scheduled . ,(number scheduled)))
(cons (evaluation-summary
(id (number evaluation))
(total (number total))
(succeeded (number succeeded))
(failed (number failed))
(scheduled (number scheduled))
;; FIXME: Info missing; use a different record type?
(status *unspecified*)
(start-time *unspecified*)
(checkout-time *unspecified*)
(completion-time *unspecified*))
summary)))))))
(define (db-get-builds-query-min filters)
@ -1819,6 +2030,12 @@ RETURNING id;"))
((id) id)
(else #f)))))
(define-record-type* <dashboard> dashboard make-dashboard
dashboard?
(id dashboard-id)
(specification-name dashboard-specification-name)
(job-ids dashboard-job-ids))
(define (db-get-dashboard id)
"Return the dashboard specification and jobs with the given ID."
(with-db-worker-thread db
@ -1826,9 +2043,10 @@ RETURNING id;"))
(exec-query/bind db "
SELECT specification, jobs from Dashboards WHERE id = " id ";"))
((specification jobs)
`((#:specification . ,specification)
(#:jobs . ,jobs)))
(else #f))))
(dashboard (id id)
(specification-name specification)
(job-ids jobs)))
(_ #f))))
(define (db-add-or-update-worker worker)
"Insert WORKER into Worker table."

140
src/cuirass/http.scm
View File

@ -102,41 +102,52 @@
(if bool 1 0))
(define finished?
(>= (assq-ref build #:status) 0))
(>= (build-current-status build) 0))
`((#:id . ,(assq-ref build #:id))
(#:evaluation . ,(assq-ref build #:eval-id))
(#:jobset . ,(assq-ref build #:specification))
(#:job . ,(assq-ref build #:job-name))
`((#:id . ,(build-id build))
(#:evaluation . ,(build-evaluation-id build))
(#:jobset . ,(build-specification-name build))
(#:job . ,(build-job-name build))
;; Hydra's API uses "timestamp" as the time of the last useful event for
;; that build: evaluation or completion.
(#:timestamp . ,(if finished?
(assq-ref build #:stoptime)
(assq-ref build #:timestamp)))
(build-completion-time build)
(build-creation-time build)))
(#:starttime . ,(assq-ref build #:starttime))
(#:stoptime . ,(assq-ref build #:stoptime))
(#:derivation . ,(assq-ref build #:derivation))
(#:buildoutputs . ,(assq-ref build #:outputs))
(#:system . ,(assq-ref build #:system))
(#:nixname . ,(assq-ref build #:nix-name))
(#:buildstatus . ,(assq-ref build #:status))
(#:weather . ,(assq-ref build #:weather))
(#:starttime . ,(build-start-time build))
(#:stoptime . ,(build-completion-time build))
(#:derivation . ,(build-derivation build))
(#:buildoutputs . ,(map (lambda (output)
(list (output-name output)
(cons "path"
(output-item output))))
(build-outputs build)))
(#:system . ,(build-system build))
(#:nixname . ,(build-nix-name build))
(#:buildstatus . ,(build-current-status build))
(#:weather . ,(build-current-weather build))
(#:busy . ,(bool->int (eqv? (build-status started)
(assq-ref build #:status))))
(#:priority . ,(assq-ref build #:priority))
(build-current-status build))))
(#:priority . ,(build-priority build))
(#:finished . ,(bool->int finished?))
(#:buildproducts . ,(list->vector
(assq-ref build #:buildproducts)))))
(#:buildproducts . ,(list->vector (build-products build)))))
(define (evaluation->json-object evaluation)
"Turn EVALUATION into a representation suitable for 'json->scm'."
;; XXX: Since #:checkouts is a list of alists, we must turn it into a vector
;; so that 'json->scm' converts it to a JSON array.
`(,@(alist-delete #:checkouts evaluation eq?)
(#:checkouts . ,(list->vector
(assq-ref evaluation #:checkouts)))))
`((#:id . ,(evaluation-id evaluation))
(#:specification . ,(evaluation-specification-name evaluation))
(#:status . ,(evaluation-current-status evaluation))
(#:timestamp . ,(evaluation-completion-time evaluation))
(#:checkouttime . ,(evaluation-checkout-time evaluation))
(#:evaltime . ,(evaluation-start-time evaluation))
(#:checkouts
. ,(list->vector
(map (lambda (checkout)
`((#:commit . ,(checkout-commit checkout))
(#:channel . ,(checkout-channel checkout))
(#:directory . ,(checkout-directory checkout))))
(evaluation-checkouts evaluation))))))
(define (specification->json-object spec)
"Turn SPEC into a representation suitable for 'json->scm'."
@ -243,7 +254,7 @@ Hydra format."
border-high-time border-low-time
border-high-id border-low-id)
"Return the HTML page representing EVALUATION."
(define id (assq-ref evaluation #:id))
(define id (evaluation-summary-id evaluation))
(define builds-id-max (db-get-builds-max id status))
(define builds-id-min (db-get-builds-min id status))
(define specification (db-get-evaluation-specification id))
@ -252,8 +263,9 @@ Hydra format."
(define checkouts (latest-checkouts specification* id))
(define builds
(vector->list
(handle-builds-request
(with-time-logging
"builds request for evaluation page"
(db-get-builds
`((evaluation . ,id)
(status . ,(and=> status string->symbol))
,@(if paginate?
@ -366,7 +378,7 @@ Hydra format."
(machine-status name workers
(map (lambda (worker)
(filter (lambda (build)
(string=? (assq-ref build #:worker)
(string=? (build-worker build)
(worker-name worker)))
builds))
workers)
@ -452,7 +464,7 @@ passed, only display JOBS targeting this SYSTEM."
(car systems)))
(dashboard (db-get-dashboard dashboard-id))
(names (and dashboard
(assq-ref dashboard #:jobs)))
(dashboard-job-ids dashboard)))
(prev (db-get-previous-eval evaluation-id))
(next (db-get-next-eval evaluation-id)))
(html-page
@ -612,6 +624,12 @@ passed, only display JOBS targeting this SYSTEM."
#:body (string-append "Resource not found: "
resource_name)))
(define (job->alist job)
;; Convert JOB to an alist representation suitable for JSON conversion.
`((build . ,(job-build-id job))
(status . ,(job-status job))
(name . ,(job-name job))))
(log-info "~a ~a" (request-method request)
(uri-path (request-uri request)))
@ -681,7 +699,7 @@ passed, only display JOBS targeting this SYSTEM."
(('GET "admin" "evaluation" id "cancel")
(let* ((eval (db-get-evaluation id))
(specification (assq-ref eval #:specification)))
(specification (evaluation-specification-name eval)))
(db-cancel-pending-builds! (string->number id))
(respond
(build-response
@ -693,7 +711,7 @@ passed, only display JOBS targeting this SYSTEM."
(('GET "admin" "evaluation" id "restart")
(let* ((eval (db-get-evaluation id))
(specification (assq-ref eval #:specification)))
(specification (evaluation-specification-name eval)))
(db-restart-evaluation! (string->number id))
(respond
(build-response
@ -705,7 +723,7 @@ passed, only display JOBS targeting this SYSTEM."
(('GET "admin" "evaluation" id "retry")
(let* ((eval (db-get-evaluation id))
(specification (assq-ref eval #:specification)))
(specification (evaluation-specification-name eval)))
(db-retry-evaluation! (string->number id))
(respond
(build-response
@ -747,32 +765,33 @@ passed, only display JOBS targeting this SYSTEM."
(respond-build-not-found id))))
(('GET "build" (= string->number id) "details")
(let* ((build (and id (db-get-build id)))
(products (and build (assoc-ref build #:buildproducts)))
(products (and build (build-products build)))
(dependencies
(and build
(db-get-builds
`((ids . ,(assoc-ref build #:builddependencies))))))
`((ids . ,(build-dependencies/id build))))))
(history
(db-get-builds
`((jobset . ,(assq-ref build #:specification))
(job . ,(assq-ref build #:job-name))
(oldevaluation . ,(assq-ref build #:eval-id))
(status . done)
(order . evaluation)
(nr . 10)))))
(and build
(db-get-builds
`((jobset . ,(build-specification-name build))
(job . ,(build-job-name build))
(oldevaluation . ,(build-evaluation-id build))
(status . done)
(order . evaluation)
(nr . 10))))))
(if build
(respond-html
(html-page
(string-append "Build " (number->string id))
(build-details build dependencies products history)
`(((#:name . ,(assq-ref build #:specification))
`(((#:name . ,(build-specification-name build))
(#:link
. ,(string-append "/jobset/"
(assq-ref build #:specification)))))))
(build-specification-name build)))))))
(respond-build-not-found id))))
(('GET "build" (= string->number id) "log" "raw")
(let* ((build (and id (db-get-build id)))
(log (and build (assq-ref build #:log))))
(log (and build (build-log build))))
(if (and log (file-exists? log))
(respond-compressed-file log)
(respond-not-found (uri->string (request-uri request))))))
@ -780,7 +799,7 @@ passed, only display JOBS targeting this SYSTEM."
(let ((output (db-get-output
(string-append (%store-prefix) "/" id))))
(if output
(let ((build (db-get-build (assq-ref output #:derivation))))
(let ((build (db-get-build (output-derivation output))))
(respond-json
(object->json-string
(append output
@ -793,11 +812,12 @@ passed, only display JOBS targeting this SYSTEM."
(respond-json
(object->json-string
(list->vector
(db-get-jobs eval-id
`((names
. ,(and=> (assq-ref params 'names)
(cut string-split <> #\,)))
,@params)))))
(map job->alist
(db-get-jobs eval-id
`((names
. ,(and=> (assq-ref params 'names)
(cut string-split <> #\,)))
,@params))))))
(respond-json-with-error 500 "Parameter not defined!"))))
(('GET "api" "jobs" "history")
(let* ((params (request-parameters request))
@ -846,7 +866,7 @@ passed, only display JOBS targeting this SYSTEM."
(respond-json-with-error 500 "Parameter not defined!"))))
(('GET "api" "evaluations")
(let* ((params (request-parameters request))
(spec (assq-ref params 'spec)) ;optional
(spec (assq-ref params 'spec)) ;optional
;; 'nr parameter is mandatory to limit query size.
(nr (assq-ref params 'nr)))
(if nr
@ -900,11 +920,7 @@ passed, only display JOBS targeting this SYSTEM."
(db-get-specifications)
evals
(db-get-evaluations-absolute-summary
(map (lambda (e)
`((#:id . ,(assq-ref
(assq-ref e #:evaluation)
#:id))))
evals))
(map evaluation-id evals))
;; Get all the latest evaluations, regardless of their
;; status.
(db-get-latest-evaluations #:status #f)))
@ -912,13 +928,12 @@ passed, only display JOBS targeting this SYSTEM."
(('GET "dashboard" id)
(let ((dashboard (db-get-dashboard id)))
(if dashboard
(let* ((spec (assq-ref dashboard #:specification))
(let* ((spec (dashboard-specification-name dashboard))
(evaluations (db-get-latest-evaluations))
(evaluation
(any (lambda (eval)
(and (string=? (assq-ref eval #:specification)
spec)
(assq-ref eval #:evaluation)))
(string=? (evaluation-specification-name eval)
spec))
evaluations))
(uri
(string->uri-reference
@ -1144,9 +1159,8 @@ passed, only display JOBS targeting this SYSTEM."
"Workers status"
(let* ((workers (db-get-workers))
(builds (db-worker-current-builds))
(builds*
(db-get-build-percentages builds)))
(workers-status workers builds*))
(percentages (db-get-build-percentages builds)))
(workers-status workers builds percentages))
'())))
(('GET "metrics")

12
src/cuirass/notification.scm
View File

@ -95,7 +95,7 @@
(define (build-weather-text build)
"Return the build weather string."
(let ((weather (assq-ref build #:weather)))
(let ((weather (build-current-weather build)))
(cond
((= weather weather-success)
"fixed")
@ -104,14 +104,14 @@
(define (build-details-url build)
"Return the build details URL for BUILD."
(let ((id (assq-ref build #:id))
(let ((id (build-id build))
(url (or (%cuirass-url) "")))
(string-append url "/build/" (number->string id) "/details")))
(define (notification-subject build)
"Return the subject for the given NOTIFICATION."
(let* ((job-name (assq-ref build #:job-name))
(specification (assq-ref build #:specification))
(let* ((job-name (build-job-name build))
(specification (build-specification-name build))
(weather-text (build-weather-text build)))
(format #f "Build ~a on ~a is ~a."
job-name specification weather-text)))
@ -119,8 +119,8 @@
(define (notification-text build)
"Return the text for the given NOTIFICATION."
(let* ((url (build-details-url build))
(job-name (assq-ref build #:job-name))
(specification (assq-ref build #:specification))
(job-name (build-job-name build))
(specification (build-specification-name build))
(weather-text (build-weather-text build)))
(format #f "The build ~a for specification ~a is ~a. You can find \
the detailed information about this build here: ~a."

12
src/cuirass/rss.scm
View File

@ -130,23 +130,23 @@ list ATTRS and the child nodes in BODY."
(define (build-details-url build)
"Return the build details URL for BUILD."
(let ((id (assq-ref build #:id))
(let ((id (build-id build))
(url (or (%cuirass-url) "")))
(string-append url "/build/" (number->string id) "/details")))
(define* (build->rss-item build)
"Convert BUILD into an RSS <item> node."
(let* ((url (build-details-url build))
(id (assq-ref build #:id))
(job-name (assq-ref build #:job-name))
(specification (assq-ref build #:specification))
(weather (assq-ref build #:weather))
(id (build-id build))
(job-name (build-job-name build))
(specification (build-specification-name build))
(weather (build-current-weather build))
(weather-text (cond
((= weather (build-weather new-success))
"fixed")
((= weather (build-weather new-failure))
"broken")))
(stoptime (assq-ref build #:stoptime)))
(stoptime (build-completion-time build)))
`(item
(guid ,url)
(title

41
src/cuirass/scripts/evaluate.scm
View File

@ -1,5 +1,5 @@
;;;; evaluate -- convert a specification to a job list
;;; Copyright © 2016, 2018, 2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016, 2018, 2022, 2023 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2017, 2018, 2021 Mathieu Othacehe <othacehe@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
@ -27,7 +27,7 @@
#:use-module (guix derivations)
#:use-module (guix inferior)
#:use-module (guix monads)
#:use-module (guix store)
#:use-module ((guix store) #:hide (build))
#:autoload (guix ui) (show-what-to-build*)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
@ -38,14 +38,36 @@
"Return the list of CHANNEL-INSTANCE records describing the given
CHECKOUTS."
(map (lambda (checkout)
(let ((channel (assq-ref checkout #:channel))
(directory (assq-ref checkout #:directory))
(commit (assq-ref checkout #:commit)))
(let ((channel (checkout-channel checkout))
(directory (checkout-directory checkout))
(commit (checkout-commit checkout)))
(checkout->channel-instance directory
#:name channel
#:commit commit)))
checkouts))
(define (user-alists->builds jobs specification-name evaluation-id)
"Convert JOBS, the user-supplied list of job alists for SPECIFICATION-NAME and
EVALUATION-ID, into a list of <build> records."
(map (lambda (alist)
(build (evaluation-id evaluation-id)
(specification-name specification-name)
(job-name (assq-ref alist #:job-name))
(nix-name (assq-ref alist #:nix-name))
(system (assq-ref alist #:system))
(timeout (assq-ref alist #:timeout))
(max-silent-time (assq-ref alist #:max-silent-time))
(derivation (assq-ref alist #:derivation))
(dependencies (assq-ref alist #:inputs))
(outputs
(map (match-lambda
((name . item)
(output (name name)
(item item)
(derivation derivation))))
(or (assq-ref alist #:outputs) '())))))
jobs))
(define* (inferior-evaluation store profile
#:key
eval-id instances
@ -75,7 +97,14 @@ Pass the BUILD, CHANNELS and SYSTEMS arguments to the EVAL-PROC procedure."
`(lambda (store)
(,eval-proc store ',args)))))
(close-inferior inferior)
(db-register-builds jobs eval-id spec))))
;; EVAL-PROC returns a list of job alists: this has the advantage of
;; being serializable and immune to ABI and API changes. Here, convert
;; it to <build> records for internal consumption.
(db-register-builds (user-alists->builds jobs
(specification-name spec)
eval-id)
spec))))
(define (channel-instances->profile instances)
"Return a directory containing a guix filetree defined by INSTANCES, a list

8
src/cuirass/scripts/remote-server.scm
View File

@ -255,10 +255,10 @@ be used to reply to the worker."
(worker-name worker)))
(let ((build (pop-build name)))
(if build
(let ((derivation (assq-ref build #:derivation))
(priority (assq-ref build #:priority))
(timeout (assq-ref build #:timeout))
(max-silent (assq-ref build #:max-silent)))
(let ((derivation (build-derivation build))
(priority (build-priority build))
(timeout (build-timeout build))
(max-silent (build-max-silent-time build)))
(when (and (%debug) worker)
(log-debug "~a (~a): build ~a submitted."
(worker-address worker)

278
src/cuirass/templates.scm
View File

@ -32,13 +32,11 @@
#:use-module (guix derivations)
#:use-module (guix packages)
#:use-module (guix progress)
#:use-module (guix store)
#:use-module ((guix store) #:hide (build))
#:use-module ((guix utils) #:select (string-replace-substring
version>?))
#:use-module (cuirass config)
#:use-module ((cuirass database) #:select (build-status
build-weather
evaluation-status))
#:use-module (cuirass database)
#:use-module (cuirass remote)
#:use-module (cuirass specification)
#:export (html-page
@ -269,14 +267,13 @@ system whose names start with " (code "guile-") ":" (br)
(define (specifications-table specs evaluations summaries latest-evaluations)
"Return HTML for the SPECS table."
(define (spec->latest-eval-ok name)
(find (lambda (s)
(string=? (assq-ref s #:specification) name))
(find (lambda (e)
(string=? (evaluation-specification-name e) name))
evaluations))
(define (spec->latest-eval name)
(any (lambda (s)
(and (string=? (assq-ref s #:specification) name)
(assq-ref s #:evaluation)))
(find (lambda (e)
(string=? (evaluation-specification-name e) name))
latest-evaluations))
(define (eval-summary eval)
@ -288,8 +285,8 @@ system whose names start with " (code "guile-") ":" (br)
summaries))
(define (summary->percentage summary)
(let ((total (assq-ref summary #:total))
(succeeded (assq-ref summary #:succeeded)))
(let ((total (evaluation-summary-total summary))
(succeeded (evaluation-summary-succeeded summary)))
(nearest-exact-integer (* 100 (/ succeeded total)))))
`((div (@ (class "d-flex flex-row mb-3"))
@ -381,7 +378,7 @@ system whose names start with " (code "guile-") ":" (br)
(specification-name spec)))
(last-eval-status-ok?
(and last-eval
(<= (assq-ref last-eval #:status)
(<= (evaluation-current-status last-eval)
(evaluation-status succeeded))))
(percentage
(and summary (summary->percentage summary)))
@ -406,11 +403,11 @@ system whose names start with " (code "guile-") ":" (br)
(div
(@ (class "job-rel d-none"))
,(successful-build-badge
(assq-ref summary #:succeeded))
(evaluation-summary-succeeded summary))
,(failed-build-badge
(assq-ref summary #:failed))
(evaluation-summary-failed summary))
,(scheduled-build-badge
(assq-ref summary #:scheduled)))))
(evaluation-summary-scheduled summary)))))
((and last-eval (not last-eval-status-ok?))
`((center
,@(evaluation-badges last-eval #f))))
@ -668,20 +665,20 @@ the existing SPEC otherwise."
(define (build-details build dependencies products history)
"Return HTML showing details for the BUILD."
(define status (assq-ref build #:status))
(define weather (assq-ref build #:weather))
(define status (build-current-status build))
(define weather (build-current-weather build))
(define evaluation
(assq-ref build #:eval-id))
(build-evaluation-id build))
(define (find-dependency id)
(find (lambda (build)
(eq? (assoc-ref build #:id) id))
(= (build-id build) id))
dependencies))
(define (history-table-row build)
(define status
(assq-ref build #:status))
(build-current-status build))
`(tr
(td (span (@ (class ,(status-class status))
@ -689,11 +686,11 @@ the existing SPEC otherwise."
(aria-hidden "true"))
""))
(th (@ (scope "row"))
(a (@ (href "/build/" ,(assq-ref build #:id) "/details"))
,(assq-ref build #:id)))
(td ,(assq-ref build #:nix-name))
(a (@ (href "/build/" ,(build-id build) "/details"))
,(build-id build)))
(td ,(build-nix-name build))
(td ,(if (completed? status)
(time->string (assq-ref build #:stoptime))
(time->string (build-completion-time build))
"—"))))
`((div (@ (class "d-flex flex-row mb-3"))
@ -712,13 +709,13 @@ the existing SPEC otherwise."
(li (@ (role "menuitem"))
(a (@ (class "dropdown-item")
(href "/admin/build/"
,(assq-ref build #:id) "/restart"))
,(build-id build) "/restart"))
" Restart")))))
(table
(@ (class "table table-sm table-hover"))
(tbody
(tr (th "Build ID")
(td ,(assq-ref build #:id)))
(td ,(build-id build)))
(tr (th "Evaluation")
(td (a (@ (href ,(string-append "/eval/"
(number->string evaluation))))
@ -728,13 +725,13 @@ the existing SPEC otherwise."
(title ,(status-title status)))
,(string-append " " (status-title status)))))
(tr (th "System")
(td ,(assq-ref build #:system)))
(td ,(build-system build)))
(tr (th "Name")
(td ,(assq-ref build #:nix-name)))
(td ,(build-nix-name build)))
(tr (th "Duration")
(td ,(let ((timestamp (time-second (current-time time-utc)))
(start (assq-ref build #:starttime))
(stop (assq-ref build #:stoptime)))
(start (build-start-time build))
(stop (build-completion-time build)))
(cond
((and (> start 0) (> stop 0))
(string-append (number->string (- stop start))
@ -745,7 +742,7 @@ the existing SPEC otherwise."
(else "—")))))
(tr (th "Finished")
(td ,(if (completed? status)
(time->string (assq-ref build #:stoptime))
(time->string (build-completion-time build))
"—")))
(tr (th "Weather")
(td (span (@ (class ,(weather-class weather))
@ -758,16 +755,16 @@ the existing SPEC otherwise."
(= (build-status succeeded) status)
(= (build-status failed) status)
(= (build-status canceled) status))
`(a (@ (href "/build/" ,(assq-ref build #:id) "/log/raw"))
`(a (@ (href "/build/" ,(build-id build) "/log/raw"))
"raw")
"—")))
(tr (th "Derivation")
(td (pre ,(assq-ref build #:derivation))))
(td (pre ,(build-derivation build))))
(tr (th "Dependencies")
(td
(@ (class "dependencies"))
,@(let ((dependencies
(assq-ref build #:builddependencies))
(build-dependencies/id build))
(max-items 10))
(if (> (length dependencies) 0)
`(,(map (lambda (id index)
@ -800,18 +797,18 @@ the existing SPEC otherwise."
'()))
'("—")))))
(tr (th "Outputs")
(td ,(map (match-lambda ((out (#:path . path))
`(pre ,path)))
(assq-ref build #:outputs))))
(td ,(map (lambda (output)
`(pre ,(output-item output)))
(build-outputs build))))
,@(if (null? products)
'()
(let ((product-items
(map
(lambda (product)
(let* ((id (assq-ref product #:id))
(size (assq-ref product #:file-size))
(type (assq-ref product #:type))
(path (assq-ref product #:path))
(let* ((id (build-product-id product))
(size (build-product-file-size product))
(type (build-product-type product))
(path (build-product-file product))
(href (format #f "/download/~a" id)))
`(a (@ (href ,href))
(li (@ (class "list-group-item"))
@ -880,26 +877,28 @@ the existing SPEC otherwise."
(let ((changes
(string-join
(map (lambda (checkout)
(let ((input (assq-ref checkout #:channel))
(commit (assq-ref checkout #:commit)))
(let ((input (checkout-channel checkout))
(commit (checkout-commit checkout)))
(format #f "~a → ~a" input (substring commit 0 7))))
checkouts)
", ")))
(if (string=? changes "") '(em "None") changes)))
(define (evaluation-badges evaluation absolute)
(let ((status (assq-ref evaluation #:status)))
(let ((status (build-summary-status evaluation)))
(if (= status (evaluation-status started))
'((em "In progress…"))
(cond
((= status (evaluation-status failed))
`((a (@ (href "/eval/" ,(assq-ref evaluation #:id) "/log/raw")
`((a (@ (href "/eval/" ,(build-summary-evaluation-id evaluation)
"/log/raw")
(class "oi oi-x text-danger")
(title "Failed")
(aria-hidden "true"))
"")))
((= status (evaluation-status aborted))
`((a (@ (href "/eval/" ,(assq-ref evaluation #:id) "/log/raw")
`((a (@ (href "/eval/" ,(build-summary-evaluation-id evaluation)
"/log/raw")
(class "oi oi-x text-warning")
(title "Aborted")
(aria-hidden "true"))
@ -907,28 +906,28 @@ the existing SPEC otherwise."
((= status (evaluation-status succeeded))
`((div
(@ (class "job-abs d-none"))
,(successful-build-badge (assq-ref absolute #:succeeded))
,(failed-build-badge (assq-ref absolute #:failed))
,(scheduled-build-badge (assq-ref absolute #:scheduled)))
,(successful-build-badge (evaluation-summary-succeeded absolute))
,(failed-build-badge (evaluation-summary-failed absolute))
,(scheduled-build-badge (evaluation-summary-scheduled absolute)))
(div
(@ (class "job-rel"))
,(successful-build-badge (assq-ref evaluation #:succeeded)
,(successful-build-badge (evaluation-summary-succeeded evaluation)
(string-append
"/eval/"
(number->string
(assq-ref evaluation #:id))
(evaluation-summary-id evaluation))
"?status=succeeded"))
,(failed-build-badge (assq-ref evaluation #:failed)
,(failed-build-badge (evaluation-summary-failed evaluation)
(string-append
"/eval/"
(number->string
(assq-ref evaluation #:id))
(evaluation-summary-id evaluation))
"?status=failed"))
,(scheduled-build-badge (assq-ref evaluation #:scheduled)
,(scheduled-build-badge (evaluation-summary-scheduled evaluation)
(string-append
"/eval/"
(number->string
(assq-ref evaluation #:id))
(evaluation-summary-id evaluation))
"?status=pending")))))))))
(define* (evaluation-info-table name evaluations id-min id-max
@ -936,9 +935,11 @@ the existing SPEC otherwise."
"Return HTML for the EVALUATION table NAME. ID-MIN and ID-MAX are
global minimal and maximal id."
(define (eval-absolute-summary eval)
(find (lambda (e)
(= (assq-ref e #:evaluation) (assq-ref eval #:id)))
absolute-summary))
(pk 'abs-sum eval absolute-summary '====>
(find (lambda (e)
(= (evaluation-summary-id e)
(build-summary-evaluation-id eval)))
absolute-summary)))
`((div (@ (class "d-flex flex-row mb-3"))
(div (@ (class "lead mr-auto"))
@ -976,15 +977,17 @@ the existing SPEC otherwise."
(th (@ (scope "col")) "Action")))
(tbody
,@(map
(lambda (row)
(lambda (summary)
`(tr (th (@ (scope "row"))
(a (@ (href "/eval/" ,(assq-ref row #:id)))
,(assq-ref row #:id)))
(td ,(input-changes (assq-ref row #:checkouts)))
(a (@ (href
"/eval/"
,(build-summary-evaluation-id summary)))
,(build-summary-evaluation-id summary)))
(td ,(input-changes (build-summary-checkouts summary)))
(td
,@(evaluation-badges row
(eval-absolute-summary row)))
,(let* ((id (assq-ref row #:id))
,@(evaluation-badges summary
(eval-absolute-summary summary)))
,(let* ((id (build-summary-evaluation-id summary))
(title
(string-append "Dashboard evaluation "
(number->string id))))
@ -994,7 +997,7 @@ the existing SPEC otherwise."
(@ (class
,(string-append
"oi oi-monitor d-inline-block "
(if (eq? (assq-ref row #:status)
(if (eq? (build-summary-status summary)
(evaluation-status succeeded))
"visible"
"invisible")))
@ -1026,25 +1029,25 @@ the existing SPEC otherwise."
(li (@ (role "menuitem"))
(a (@ (class "dropdown-item")
(href "/admin/evaluation/"
,(assq-ref row #:id)
,(build-summary-evaluation-id summary)
"/cancel"))
" Cancel pending builds"))
(li (@ (role "menuitem"))
(a (@ (class "dropdown-item")
(href "/admin/evaluation/"
,(assq-ref row #:id)
,(build-summary-evaluation-id summary)
"/restart"))
" Restart all builds"))
(li (@ (role "menuitem"))
(a (@ (class "dropdown-item")
(href "/admin/evaluation/"
,(assq-ref row #:id)
,(build-summary-evaluation-id summary)
"/retry"))
" Retry the evaluation")))))))))
evaluations)))))
,(if (null? evaluations)
(pagination "" "" "" "")
(let* ((eval-ids (map (cut assq-ref <> #:id) evaluations))
(let* ((eval-ids (map build-summary-evaluation-id evaluations))
(page-id-min (last eval-ids))
(page-id-max (first eval-ids)))
(pagination
@ -1127,10 +1130,10 @@ and BUILD-MAX are global minimal and maximal (stoptime, rowid) pairs."
(define (table-row build)
(define status
(assq-ref build #:buildstatus))
(build-current-status build))
(define weather
(assq-ref build #:weather))
(build-current-weather build))
`(tr
(td (span (@ (class ,(status-class status))
@ -1142,25 +1145,25 @@ and BUILD-MAX are global minimal and maximal (stoptime, rowid) pairs."
(aria-hidden "true"))
""))
(th (@ (scope "row"))
(a (@ (href "/build/" ,(assq-ref build #:id) "/details"))
,(assq-ref build #:id)))
(td ,(assq-ref build #:jobset))
(a (@ (href "/build/" ,(build-id build) "/details"))
,(build-id build)))
(td ,(build-specification-name build))
(td ,(if (completed? status)
(time->string (assq-ref build #:stoptime))
(time->string (build-completion-time build))
"—"))
(td ,(assq-ref build #:job))
(td ,(assq-ref build #:nixname))
(td ,(assq-ref build #:system))
(td ,(build-job-name build))
(td ,(build-nix-name build))
(td ,(build-system build))
(td ,(if (completed-with-logs? status)
`(a (@ (href "/build/" ,(assq-ref build #:id) "/log/raw"))
`(a (@ (href "/build/" ,(build-id build) "/log/raw"))
"raw")
"—"))))
(define (build-id build)
(define (page-boundary-build-id build)
(match build
((stoptime id) id)))
(define (build-stoptime build)
(define (page-boundary-build-stoptime build)
(match build
((stoptime id) stoptime)))
@ -1173,36 +1176,36 @@ and BUILD-MAX are global minimal and maximal (stoptime, rowid) pairs."
(tbody ,@(map table-row builds)))))
,(if (null? builds)
(pagination "" "" "" "")
(let* ((build-time-ids (map (lambda (row)
(list (assq-ref row #:stoptime)
(assq-ref row #:id)))
(let* ((build-time-ids (map (lambda (build)
(list (build-completion-time build)
(build-id build)))
builds))
(page-build-min (last build-time-ids))
(page-build-max (first build-time-ids)))
(pagination
(format
#f "?border-high-time=~d&border-high-id=~d~@[&status=~a~]"
(build-stoptime build-max)
(1+ (build-id build-max))
(page-boundary-build-stoptime build-max)
(1+ (page-boundary-build-id build-max))
status)
(if (equal? page-build-max build-max)
""
(format
#f "?border-low-time=~d&border-low-id=~d~@[&status=~a~]"
(build-stoptime page-build-max)
(build-id page-build-max)
(page-boundary-build-stoptime page-build-max)
(page-boundary-build-id page-build-max)
status))
(if (equal? page-build-min build-min)
""
(format
#f "?border-high-time=~d&border-high-id=~d~@[&status=~a~]"
(build-stoptime page-build-min)
(build-id page-build-min)
(page-boundary-build-stoptime page-build-min)
(page-boundary-build-id page-build-min)
status))
(format
#f "?border-low-time=~d&border-low-id=~d~@[&status=~a~]"
(build-stoptime build-min)
(1- (build-id build-min))
(page-boundary-build-stoptime build-min)
(1- (page-boundary-build-id build-min))
status))))))
;; FIXME: Copied from (guix scripts describe).
@ -1255,7 +1258,7 @@ the nearest exact even integer."
(th (@ (class "border-0") (scope "col")) "Commit")))
(tbody
,@(map (lambda (checkout)
(let* ((name (assq-ref checkout #:channel))
(let* ((name (checkout-channel checkout))
(channel (find (lambda (channel)
(eq? (channel-name channel)
name))
@ -1264,7 +1267,7 @@ the nearest exact even integer."
;; inputs.
(if channel
(let ((url (channel-url channel))
(commit (assq-ref checkout #:commit)))
(commit (checkout-commit checkout)))
`(tr (td ,url)
(td (code ,(commit-hyperlink url commit)))))
'())))
@ -1298,14 +1301,13 @@ the nearest exact even integer."
builds-id-min builds-id-max)
"Return HTML for an evaluation page, containing a table of builds for that
evaluation."
(define id (assq-ref evaluation #:id))
(define total (assq-ref evaluation #:total))
(define succeeded (assq-ref evaluation #:succeeded))
(define timestamp (assq-ref evaluation #:timestamp))
(define evaltime (assq-ref evaluation #:evaltime))
(define failed (assq-ref evaluation #:failed))
(define scheduled (assq-ref evaluation #:scheduled))
(define spec (assq-ref evaluation #:spec))
(define id (evaluation-summary-id evaluation))
(define total (evaluation-summary-total evaluation))
(define succeeded (evaluation-summary-succeeded evaluation))
(define timestamp (evaluation-summary-start-time evaluation))
(define evaltime (evaluation-summary-completion-time evaluation))
(define failed (evaluation-summary-failed evaluation))
(define scheduled (evaluation-summary-scheduled evaluation))
(define duration (- evaltime timestamp))
@ -1411,7 +1413,7 @@ and BUILD-MAX are global minimal and maximal row identifiers."
(define (table-row build)
(define status
(assq-ref build #:buildstatus))
(build-current-status build))
`(tr
(td (span (@ (class ,(status-class status))
@ -1419,17 +1421,17 @@ and BUILD-MAX are global minimal and maximal row identifiers."
(aria-hidden "true"))
""))
(th (@ (scope "row"))
(a (@ (href "/build/" ,(assq-ref build #:id) "/details"))
,(assq-ref build #:id)))
(td ,(assq-ref build #:jobset))
(a (@ (href "/build/" ,(build-id build) "/details"))
,(build-id build)))
(td ,(build-job-name build))
(td ,(if (completed? status)
(time->string (assq-ref build #:stoptime))
(time->string (build-completion-time build))
"—"))
(td ,(assq-ref build #:job))
(td ,(assq-ref build #:nixname))
(td ,(assq-ref build #:system))
(td ,(build-job-name build))
(td ,(build-nix-name build))
(td ,(build-system build))
(td ,(if (completed-with-logs? status)
`(a (@ (href "/build/" ,(assq-ref build #:id) "/log/raw"))
`(a (@ (href "/build/" ,(build-id build) "/log/raw"))
"raw")
"—"))))
@ -1474,13 +1476,13 @@ and BUILD-MAX are global minimal and maximal row identifiers."
(define (build-row build)
`(tr
(th (@ (scope "row"))
(a (@ (href "/build/" ,(assq-ref build #:id) "/details"))
,(assq-ref build #:id)))
(td ,(assq-ref build #:job-name))
(a (@ (href "/build/" ,(build-id build) "/details"))
,(build-id build)))
(td ,(build-job-name build))
(td ,(time->string
(assq-ref build #:starttime)))
(td ,(assq-ref build #:system))
(td (a (@ (href "/build/" ,(assq-ref build #:id) "/log/raw"))
(build-start-time build)))
(td ,(build-system build))
(td (a (@ (href "/build/" ,(build-id build) "/log/raw"))
"raw"))))
`((p (@ (class "lead")) "Running builds")
@ -1705,7 +1707,7 @@ completed builds divided by the time required to build them.")
#:labels '("Pending builds")
#:colors (list "#3e95cd")))))
(define (workers-status workers builds)
(define (workers-status workers builds percentages)
(define (machine-row machine)
(let* ((workers (sort (filter-map
(lambda (worker)
@ -1719,7 +1721,7 @@ completed builds divided by the time required to build them.")
(match (filter
(lambda (build)
(let ((build-worker
(assq-ref build #:worker)))
(build-worker build)))
(and build-worker
(string=? build-worker worker))))
builds)
@ -1729,11 +1731,11 @@ completed builds divided by the time required to build them.")
`(div (@ (class "col-sm-4 mt-3"))
(a (@(href "/machine/" ,machine))
(h6 ,machine))
,(map (lambda (build)
,(map (lambda (build percentage)
(let ((style (format #f
"width: ~a%"
(if build
(assq-ref build #:percentage)
percentage
0))))
`(div (@ (class "progress mt-1")
(style "height: 20px"))
@ -1749,14 +1751,14 @@ d-flex position-absolute w-100"))
(a (@ (class "text-dark text-truncate")
(style "max-width: 150px")
(href "/build/"
,(assq-ref build #:id)
,(build-id build)
"/details"))
,(assq-ref build #:job-name)))
,(build-job-name build)))
'(em
(@ (class "justify-content-center
text-dark d-flex position-absolute w-100"))
"idle"))))))
builds))))
builds percentages))))
(let ((machines (reverse
(sort (delete-duplicates
@ -1825,9 +1827,9 @@ text-dark d-flex position-absolute w-100"))
`(a (@ (class "text-truncate")
(style "max-width: 150px")
(href "/build/"
,(assq-ref build #:id)
,(build-id build)
"/details"))
,(assq-ref build #:job-name)))))
,(build-job-name build)))))
(td ,(time->string
(worker-last-seen worker)))))
workers builds)))))
@ -1886,24 +1888,24 @@ text-dark d-flex position-absolute w-100"))
(define* (evaluation-dashboard evaluation systems
#:key
(checkouts (assq-ref evaluation #:checkouts))
(checkouts (evaluation-checkouts evaluation))
channels
current-system
dashboard-id
names
prev-eval
next-eval)
(define evaluation-id
(assq-ref evaluation #:id))
(define id
(evaluation-id evaluation))
(define time
(assq-ref evaluation #:evaltime))
(evaluation-completion-time evaluation))
(let ((jobs
(if names
(format #f "/api/jobs?evaluation=~a&names=~a"
evaluation-id names)
id names)
(format #f "/api/jobs?evaluation=~a&system=~a"
evaluation-id current-system))))
id current-system))))
`((nav
(@ (aria-label "Evaluation navigation")
(class "eval-nav"))
@ -1912,8 +1914,8 @@ text-dark d-flex position-absolute w-100"))
(p (@ (class "lead mb-0 mr-3"))
"Dashboard for "
(a (@ (href ,(string-append "/eval/"
(number->string evaluation-id))))
"evaluation #" ,(number->string evaluation-id))))
(number->string id))))
"evaluation #" ,(number->string id))))
(li (@ (class
,(string-append "page-item "
(if prev-eval
@ -1965,7 +1967,7 @@ text-dark d-flex position-absolute w-100"))
(if names
"d-none"
"")))
(action "/eval/" ,evaluation-id "/dashboard")
(action "/eval/" ,id "/dashboard")
(method "GET"))
(div (@ (class "col-auto"))
(select (@ (id "system")
@ -2022,9 +2024,9 @@ content as a string."
(if summary
(let* ((succeeded
(assq-ref summary #:succeeded))
(evaluation-summary-succeeded summary))
(total
(assq-ref summary #:total))
(evaluation-summary-total summary))
(percentage
(nearest-exact-integer
(* 100 (/ succeeded total))))

449
tests/database.scm
View File

@ -86,15 +86,18 @@
#:key
(job-name "job")
(outputs
`(("foo" . ,(format #f "~a.output" drv)))))
`((#:derivation . ,drv)
(#:eval-id . ,eval-id)
(#:job-name . ,job-name)
(#:timestamp . ,(time-second (current-time time-utc)))
(#:system . "x86_64-linux")
(#:nix-name . "foo")
(#:log . "log")
(#:outputs . ,outputs)))
(list
(output (name "foo")
(derivation drv)
(item (format #f "~a.output" drv))))))
(build (derivation drv)
(evaluation-id eval-id)
(specification-name "whatever")
(job-name job-name)
(system "x86_64-linux")
(nix-name "foo")
(log "log")
(outputs outputs)))
(define %dummy-worker
(worker
@ -179,7 +182,7 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0, 0);")
(test-equal "db-get-latest-checkout"
'("fakesha3" "fakesha4")
(with-fibers
(map (cut assq-ref <> #:commit)
(map checkout-commit
(list (db-get-latest-checkout "guix" 'guix 3)
(db-get-latest-checkout "guix" 'my-channel 3)))))
@ -198,30 +201,28 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0, 0);")
(test-equal "db-add-build"
"/foo.drv"
(with-fibers
(let ((build (make-dummy-build "/foo.drv")))
(db-add-build build))))
(test-equal "db-add-build duplicate"
"/foo.drv"
(with-fibers
(let ((build (make-dummy-build "/foo.drv")))
(db-add-build build))))
(let* ((build (make-dummy-build "/foo.drv"))
(id (db-add-build build)))
(and (not (db-add-build build)) ;duplicate
(build-derivation (db-get-build id))))))
(test-assert "db-add-build-product"
(with-fibers
(db-add-build-product `((#:build . 1)
(#:type . "1")
(#:file-size . 1)
(#:checksum . "sum")
(#:path . "path")))))
(db-add-build-product (build-product (build-id 1)
(type "1")
(file-size 1)
(checksum "sum")
(file "path")))))
(test-equal "db-get-output"
'((#:derivation . "/foo.drv") (#:name . "foo"))
(output (name "foo") (derivation "/foo.drv")
(item "/foo.drv.output"))
(with-fibers
(db-get-output "/foo.drv.output")))
(db-get-output "/foo.drv.output")))
(test-equal "db-get-outputs"
'(("foo" (#:path . "/foo.drv.output")))
(list (output (name "foo") (derivation "/foo.drv")
(item "/foo.drv.output")))
(with-fibers
(db-get-outputs "/foo.drv")))
@ -232,44 +233,62 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0, 0);")
(test-assert "db-register-builds"
(with-fibers
(let ((drv "/test.drv"))
(db-register-builds `(((#:job-name . "test")
(#:derivation . ,drv)
(#:system . "x86_64-linux")
(#:nix-name . "test")
(#:log . "log")
(#:outputs .
(("foo" . ,(format #f "~a.output" drv))
("foo2" . ,(format #f "~a.output.2" drv))))))
2 (db-get-specification "guix")))))
(db-register-builds
(list (build (job-name "test")
(evaluation-id 2)
(specification-name "whatever")
(derivation drv)
(system "x86_64-linux")
(nix-name "test")
(log "log")
(outputs
(list (output
(name "foo")
(derivation drv)
(item (string-append drv ".output")))
(output
(name "foo2")
(derivation drv)
(item (string-append drv ".output.2")))))))
(db-get-specification "guix")))))
(test-assert "db-get-jobs"
(with-fibers
(match (db-get-jobs 2
'((#:system . "x86_64-linux")))
((job)
(string=? (assq-ref job #:name) "test")))))
(string=? (job-name job) "test")))))
(test-assert "db-get-jobs names"
(with-fibers
(match (db-get-jobs 2
'((names "test")))
((job)
(string=? (assq-ref job #:name) "test")))))
(string=? (job-name job) "test")))))
(test-assert "db-register-builds same-outputs"
(with-fibers
(let ((drv "/test2.drv"))
(db-add-evaluation "guix"
(make-dummy-instances "fakesha5" "fakesha6"))
(db-register-builds `(((#:job-name . "test")
(#:derivation . ,drv)
(#:system . "x86_64-linux")
(#:nix-name . "test")
(#:log . "log")
(#:outputs .
(("foo" . "/test.drv.output")
("foo2" . "/test.drv.output.2")))))
4 (db-get-specification "guix")))))
(db-register-builds
(list (build (job-name "test")
(evaluation-id 4)
(specification-name "whatever")
(derivation drv)
(system "x86_64-linux")
(nix-name "test")
(log "log")
(outputs
(list (output
(name "foo")
(derivation drv)
(item "/test.drv.output"))
(output
(name "foo2")
(derivation drv)
(item "/test.drv.output.2"))))))
(db-get-specification "guix")))))
(test-equal "db-get-previous-eval"
1
@ -280,14 +299,12 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0, 0);")
(with-fibers
(not (db-get-next-eval 3))))
(test-assert "db-get-jobs same-outputs"
(test-equal "db-get-jobs same-outputs"
"/test.drv"
(with-fibers
(match (db-get-jobs 4 '())
((job)
(string=? (assq-ref (db-get-build
(assq-ref job #:build))
#:derivation)
"/test.drv")))))
(build-derivation (db-get-build (job-build-id job)))))))
(test-assert "db-get-jobs-history"
(with-fibers
@ -316,40 +333,38 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0, 0);")
'((nr . 1)
(query . "status:failed test")))
((build) build))))
(list
(assoc-ref build #:id)
(assoc-ref build #:status)
(assoc-ref build #:job-name)))))
(list (build-id build)
(build-current-status build)
(build-job-name build)))))
(test-assert "db-get-builds"
(test-equal "db-get-builds + build-outputs"
(list (output (name "foo") (derivation "/test.drv")
(item "/test.drv.output"))
(output (name "foo2") (derivation "/test.drv")
(item "/test.drv.output.2")))
(with-fibers
(let* ((build (match (db-get-builds `((order . build-id)
(status . failed)))
((build) build)))
(outputs (assq-ref build #:outputs)))
(equal? outputs
'(("foo" (#:path . "/test.drv.output"))
("foo2" (#:path . "/test.drv.output.2")))))))
(match (db-get-builds `((order . build-id)
(status . failed)))
((build)
(build-outputs build)))))
(test-equal "db-get-builds job-name"
"/foo.drv"
(with-fibers
(let ((build (match (db-get-builds `((order . build-id)
(job . "job")))
((build) build))))
(assoc-ref build #:derivation))))
(match (db-get-builds `((order . build-id)
(job . "job")))
((build)
(build-derivation build)))))
(test-equal "db-get-build"
"/foo.drv"
(with-fibers
(let ((build (db-get-build 1)))
(assoc-ref build #:derivation))))
(build-derivation (db-get-build 1))))
(test-equal "db-get-build derivation"
1
(with-fibers
(let ((build (db-get-build "/foo.drv")))
(assoc-ref build #:id))))
(build-id (db-get-build "/foo.drv"))))
(test-equal "db-get-pending-derivations"
'("/foo.drv")
@ -360,19 +375,19 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0, 0);")
'("fakesha1" "fakesha2")
(with-fibers
(make-dummy-instances "fakesha1" "fakesha2")
(map (cut assq-ref <> #:commit) (db-get-checkouts 2))))
(map checkout-commit (db-get-checkouts 2))))
(test-equal "db-get-evaluation"
"guix"
(with-fibers
(let ((evaluation (db-get-evaluation 2)))
(assq-ref evaluation #:specification))))
(evaluation-specification-name evaluation))))
(test-equal "db-get-evaluations"
'("guix" "guix")
(with-fibers
(map (lambda (eval)
(assq-ref eval #:specification))
(evaluation-specification-name eval))
(db-get-evaluations 2))))
(test-equal "db-get-evaluations-build-summary"
@ -381,10 +396,9 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0, 0);")
(let ((summaries
(db-get-evaluations-build-summary "guix" 3 #f #f)))
(map (lambda (summary)
(list
(assq-ref summary #:succeeded)
(assq-ref summary #:failed)
(assq-ref summary #:scheduled)))
(list (build-summary-succeeded summary)
(build-summary-failed summary)
(build-summary-scheduled summary)))
summaries))))
(test-equal "db-get-evaluation-absolute-summary"
@ -393,10 +407,9 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0, 0);")
(let ((summary
(db-get-evaluation-absolute-summary
(db-get-latest-evaluation "guix"))))
(list
(assq-ref summary #:succeeded)
(assq-ref summary #:failed)
(assq-ref summary #:scheduled)))))
(list (evaluation-summary-succeeded summary)
(evaluation-summary-failed summary)
(evaluation-summary-scheduled summary)))))
(test-equal "db-get-evaluations-absolute-summary"
'((0 1 0) (0 1 0))
@ -406,10 +419,9 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0, 0);")
(summaries
(db-get-evaluations-absolute-summary evaluations)))
(map (lambda (summary)
(list
(assq-ref summary #:succeeded)
(assq-ref summary #:failed)
(assq-ref summary #:scheduled)))
(list (evaluation-summary-succeeded summary)
(evaluation-summary-failed summary)
(evaluation-summary-scheduled summary)))
summaries))))
(test-equal "db-get-evaluations-id-min"
@ -442,33 +454,33 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0, 0);")
(with-fibers
(match (db-get-latest-evaluations)
((eval)
(assq-ref (assq-ref eval #:evaluation) #:id)))))
(evaluation-id eval)))))
(test-equal "db-get-latest-evaluations 2"
4
(with-fibers
(match (db-get-latest-evaluations #:status #f)
((eval)
(assq-ref (assq-ref eval #:evaluation) #:id)))))
(evaluation-id eval)))))
(test-equal "db-get-evaluation-summary"
'(2 0 1 1)
(with-fibers
(let* ((summary (db-get-evaluation-summary 2))
(total (assq-ref summary #:total))
(succeeded (assq-ref summary #:succeeded))
(failed (assq-ref summary #:failed))
(scheduled (assq-ref summary #:scheduled)))
(total (evaluation-summary-total summary))
(succeeded (evaluation-summary-succeeded summary))
(failed (evaluation-summary-failed summary))
(scheduled (evaluation-summary-scheduled summary)))
(list total succeeded failed scheduled))))
(test-equal "db-get-evaluation-summary empty"
'(0 0 0 0)
(with-fibers
(let* ((summary (db-get-evaluation-summary 3))
(total (assq-ref summary #:total))
(succeeded (assq-ref summary #:succeeded))
(failed (assq-ref summary #:failed))
(scheduled (assq-ref summary #:scheduled)))
(total (evaluation-summary-total summary))
(succeeded (evaluation-summary-succeeded summary))
(failed (evaluation-summary-failed summary))
(scheduled (evaluation-summary-scheduled summary)))
(list total succeeded failed scheduled))))
(test-equal "db-get-builds-query-min"
@ -501,13 +513,14 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0, 0);")
(db-get-evaluation-specification 2)))
(test-equal "db-get-build-products"
`(((#:id . 1)
(#:type . "1")
(#:file-size . 1)
(#:checksum . "sum")
(#:path . "path")))
(list (build-product (id 1)
(build-id 1)
(type "1")
(file-size 1)
(checksum "sum")
(file "path")))
(with-fibers
(db-get-build-products 1)))
(db-get-build-products 1)))
(test-equal "db-get-build-product-path"
"path"
@ -538,8 +551,8 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0, 0);")
(db-remove-unresponsive-workers 50)
(and (eq? (db-get-workers) '())
(let* ((build (db-get-build drv))
(worker (assq-ref build #:worker))
(status (assq-ref build #:status)))
(worker (build-worker build))
(status (build-current-status build)))
(and (not worker)
(eq? status (build-status scheduled))))))))
@ -555,11 +568,15 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0, 0);")
(build-status succeeded)
"/foo2.log")
(with-fibers
(let* ((derivation (db-add-build
(make-dummy-build "/foo2.drv" 2
#:outputs '(("out" . "/foo")))))
(get-status (lambda* (#:optional (key #:status))
(assq-ref (db-get-build derivation) key))))
(let* ((derivation "/foo2.drv")
(get-status (lambda* (#:optional (field build-current-status))
(field (db-get-build derivation)))))
(db-add-build
(make-dummy-build derivation 2
#:outputs
(list (output
(derivation derivation)
(item "/foo")))))
(let ((status0 (get-status)))
(db-update-build-status! "/foo2.drv" (build-status started)
#:log-file "/foo2.log")
@ -570,9 +587,9 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0, 0);")
(db-update-build-status! "/foo2.drv" (build-status succeeded))
(let ((status2 (get-status))
(start (get-status #:starttime))
(end (get-status #:stoptime))
(log (get-status #:log)))
(start (get-status build-start-time))
(end (get-status build-completion-time))
(log (get-status build-log)))
(and (> start 0) (>= end start)
(list status0 status1 status2 log))))))))
@ -585,61 +602,82 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0, 0);")
(with-fibers
(exec-query (%db) "DELETE FROM Builds;")
(db-add-build (make-dummy-build "/baa.drv" 2
#:outputs `(("out" . "/baa"))))
#:outputs
(list (output
(item "/baa")
(derivation "/baa.drv")))))
(db-add-build (make-dummy-build "/bar.drv" 2
#:outputs `(("out" . "/bar"))))
#:outputs
(list (output
(item "/bar")
(derivation "/bar.drv")))))
(db-add-build (make-dummy-build "/baz.drv" 2
#:outputs `(("out" . "/baz"))))
#:outputs
(list (output
(item "/baz")
(derivation "/baz.drv")))))
(db-update-build-status! "/bar.drv" (build-status started)
#:log-file "/bar.drv.log")
(let ((summarize (lambda (alist)
(assq-ref alist #:derivation))))
(list (map summarize (db-get-builds '((nr . 3) (order . build-id))))
(map summarize (db-get-builds '()))
(map summarize (db-get-builds '((jobset . "guix"))))
(map summarize (db-get-builds '((nr . 1))))
(map summarize
(db-get-builds '((order . status+submission-time))))))))
(list (map build-derivation (db-get-builds '((nr . 3) (order . build-id))))
(map build-derivation (db-get-builds '()))
(map build-derivation (db-get-builds '((jobset . "guix"))))
(map build-derivation (db-get-builds '((nr . 1))))
(map build-derivation
(db-get-builds '((order . status+submission-time)))))))
(test-equal "db-get-pending-derivations"
'("/bar.drv" "/foo.drv")
(with-fibers
(exec-query (%db) "DELETE FROM Builds;")
(db-add-build (make-dummy-build "/foo.drv" 1
#:outputs `(("out" . "/foo"))))
#:outputs
(list (output
(item "/foo")
(derivation "/foo.drv")))))
(db-add-build (make-dummy-build "/bar.drv" 2
#:outputs `(("out" . "/bar"))))
#:outputs
(list (output
(item "/bar")
(derivation "/bar.drv")))))
(sort (db-get-pending-derivations) string<?)))
(test-assert "db-get-build-percentages"
(with-fibers
(let* ((ts (time-second (current-time time-utc)))
(old `((#:derivation . "/last.drv")
(#:eval-id . 2)
(#:job-name . "job")
(#:timestamp . ,(- ts 10))
(#:status . 0)
(#:starttime . 10)
(#:stoptime . 20)
(#:system . "x86_64-linux")
(#:nix-name . "foo")
(#:log . "log")
(#:outputs . (("out" . "/old-percentage")))))
(new `((#:derivation . "/cur.drv")
(#:eval-id . 2)
(#:job-name . "job")
(#:timestamp . ,(- ts 5))
(#:starttime . ,(- ts 5))
(#:system . "x86_64-linux")
(#:nix-name . "foo")
(#:log . "log")
(#:outputs . (("out" . "/new-percentage"))))))
(old (build (derivation "/last.drv")
(evaluation-id 2)
(job-name "job")
(specification-name "whatever")
(creation-time (- ts 10))
(status 0)
(start-time 10)
(completion-time 20)
(system "x86_64-linux")
(nix-name "foo")
(log "log")
(outputs
(list (output
(item "/old-percentage")
(derivation "/last.drv"))))))
(new (build (derivation "/cur.drv")
(evaluation-id 2)
(job-name "job")
(specification-name "whatever")
(creation-time (- ts 5))
(start-time (- ts 5))
(system "x86_64-linux")
(nix-name "foo")
(log "log")
(outputs
(list (output
(item "/new-percentage")
(derivation "/cur.drv")))))))
(db-add-build old)
(db-add-build new)
(match (db-get-build-percentages
(list (db-get-build (assq-ref new #:derivation))))
((build)
(>= (assq-ref build #:percentage) 50))))))
(list (db-get-build (build-derivation new))))
((percentage)
(>= percentage 50))))))
(test-equal "db-update-build-status!"
(list #f 1)
@ -648,20 +686,27 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0, 0);")
(make-dummy-instances "fakesha5" "fakesha6"))
(db-add-build (make-dummy-build "/old-build.drv" 3
#:job-name "job-1"
#:outputs `(("out" . "/old"))))
#:outputs
(list (output
(item "/old")
(derivation "/old-build.drv")))))
(db-add-build (make-dummy-build "/new-build.drv" 4
#:job-name "job-1"
#:outputs `(("out" . "/new"))))
#:outputs
(list (output
(item "/new")
(derivation "/new-build.drv")))))
(db-update-build-status! "/old-build.drv" 1)
(db-update-build-status! "/new-build.drv" 0)
(map (cut assq-ref <> #:last-status)
(map build-last-status
(list (db-get-build "/old-build.drv")
(db-get-build "/new-build.drv")))))
(test-equal "db-get-builds weather"
(build-weather new-success)
(with-fibers
(assq-ref (db-get-build "/new-build.drv") #:weather)))
(build-current-weather (db-get-build "/new-build.drv"))))
(test-assert "mail notification"
(with-fibers
@ -680,7 +725,7 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0, 0);")
(with-fibers
(db-update-build-status! "/old-build.drv" 0)
(db-update-build-status! "/new-build.drv" 1)
(assq-ref (db-get-build "/new-build.drv") #:weather)))
(build-current-weather (db-get-build "/new-build.drv"))))
(test-assert "mail notification, broken job"
(with-fibers
@ -699,28 +744,28 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0, 0);")
(with-fibers
(db-update-build-status! "/old-build.drv" 0)
(db-update-build-status! "/new-build.drv" 0)
(assq-ref (db-get-build "/new-build.drv") #:weather)))
(build-current-weather (db-get-build "/new-build.drv"))))
(test-equal "db-get-builds weather"
(build-weather still-failing)
(with-fibers
(db-update-build-status! "/old-build.drv" 1)
(db-update-build-status! "/new-build.drv" 1)
(assq-ref (db-get-build "/new-build.drv") #:weather)))
(build-current-weather (db-get-build "/new-build.drv"))))
(test-assert "db-restart-build!"
(with-fibers
(let ((build (db-get-build "/new-build.drv")))
(db-restart-build! (assq-ref build #:id))
(eq? (assq-ref (db-get-build "/new-build.drv") #:status)
(build-status scheduled)))))
(db-restart-build! (build-id build))
(= (build-current-status (db-get-build "/new-build.drv"))
(build-status scheduled)))))
(test-assert "db-restart-evaluation!"
(with-fibers
(let ((build (db-get-build "/old-build.drv")))
(db-restart-evaluation! (assq-ref build #:eval-id))
(eq? (assq-ref (db-get-build "/old-build.drv") #:status)
(build-status scheduled)))))
(db-restart-evaluation! (build-evaluation-id build))
(= (build-current-status (db-get-build "/old-build.drv"))
(build-status scheduled)))))
(test-assert "db-retry-evaluation!"
(with-fibers
@ -731,11 +776,11 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0, 0);")
(with-fibers
(let* ((drv "/old-build.drv")
(build (db-get-build drv))
(eval-id (assq-ref build #:eval-id)))
(eval-id (build-evaluation-id build)))
(db-update-build-status! drv (build-status started))
(db-cancel-pending-builds! eval-id)
(eq? (assq-ref (db-get-build drv) #:status)
(build-status canceled)))))
(= (build-current-status (db-get-build drv))
(build-status canceled)))))
(test-assert "db-push-notification"
(with-fibers
@ -745,7 +790,7 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0, 0);")
(from "from")
(to "to")
(server (mailer)))
(assq-ref build #:id)))))
(build-id build)))))
(test-assert "db-pop-notification"
(with-fibers
@ -753,26 +798,35 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0, 0);")
(match (db-pop-notification)
((notif . notif-build)
(and (email? notif)
(equal? build notif-build)))))))
;; <build> records cannot be compared with 'equal?' because
;; they contain procedures, hence this comparison.
(string=? (build-derivation build)
(build-derivation notif-build))
(eqv? (build-id build)
(build-id notif-build))))))))
(test-assert "set-build-successful!"
(with-fibers
(let* ((name "/foo5.drv")
(build
(make-dummy-build name #:outputs `(("out" . ,(getcwd)))))
(drv (assq-ref build #:derivation)))
(make-dummy-build name
#:outputs
(list (output
(item (getcwd))
(derivation "/foo5.drv")))))
(drv (build-derivation build)))
(db-add-build build)
(set-build-successful! drv)
(match (assq-ref (db-get-build name) #:buildproducts)
(match (build-products (db-get-build name))
((product)
(equal? (assq-ref product #:path) (getcwd)))))))
(equal? (build-product-file product) (getcwd)))))))
(test-assert "db-worker-current-builds"
(with-fibers
(let ((drv-1
(db-add-build (make-dummy-build "/build-1.drv")))
(drv-2
(db-add-build (make-dummy-build "/build-2.drv"))))
(let ((drv-1 "/build-1.drv")
(drv-2 "/build-2.drv"))
(db-add-build (make-dummy-build drv-1))
(db-add-build (make-dummy-build drv-2))
(db-add-or-update-worker %dummy-worker)
(db-update-build-worker! drv-1 "worker")
(db-update-build-worker! drv-2 "worker")
@ -780,14 +834,14 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0, 0);")
(db-update-build-status! drv-2 (build-status started))
(match (db-worker-current-builds)
((build)
(eq? (assq-ref (db-get-build drv-2) #:id)
(assq-ref build #:id)))))))
(= (build-id (db-get-build drv-2))
(build-id build)))))))
(test-equal "db-register-dashboard"
"guix"
(with-fibers
(let ((id (db-register-dashboard "guix" "emacs")))
(assq-ref (db-get-dashboard id) #:specification))))
(dashboard-specification-name (db-get-dashboard id)))))
(test-assert "db-add-build-dependencies"
(with-fibers
@ -798,10 +852,15 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0, 0);")
(with-fibers
(let* ((drv1 "/build-1.drv")
(drv2 "/build-2.drv")
(id1 (assq-ref (db-get-build drv1) #:id))
(id2 (assq-ref (db-get-build drv2) #:id)))
(id1 (build-id (db-get-build drv1)))
(id2 (build-id (db-get-build drv2))))
(match (db-get-build-dependencies id1)
((id) (eq? id id2))))))
((id) (= id id2))))))
(test-equal "build-dependencies"
'("/build-2.drv")
(with-fibers
(build-dependencies (db-get-build "/build-1.drv"))))
(test-assert "db-get-builds no-dependencies"
(with-fibers
@ -809,28 +868,24 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0, 0);")
(build-status scheduled))
(db-update-build-status! "/build-2.drv"
(build-status scheduled))
(string=? (assq-ref (db-get-pending-build "x86_64-linux")
#:derivation)
(string=? (build-derivation
(db-get-pending-build "x86_64-linux"))
"/build-2.drv")))
(test-assert "dependencies trigger"
(with-fibers
(let ((drv-1
(db-add-build (make-dummy-build "/build-dep-1.drv")))
(drv-2
(db-add-build (make-dummy-build "/build-dep-2.drv")))
(drv-3
(db-add-build (make-dummy-build "/build-dep-3.drv")))
(drv-4
(db-add-build (make-dummy-build "/build-dep-4.drv")))
(drv-5
(db-add-build (make-dummy-build "/build-dep-5.drv")))
(drv-6
(db-add-build (make-dummy-build "/build-dep-6.drv")))
(drv-7
(db-add-build (make-dummy-build "/build-dep-7.drv")))
(let ((drv-1 "/build-dep-1.drv")
(drv-2 "/build-dep-2.drv")
(drv-3 "/build-dep-3.drv")
(drv-4 "/build-dep-4.drv")
(drv-5 "/build-dep-5.drv")
(drv-6 "/build-dep-6.drv")
(drv-7 "/build-dep-7.drv")
(status (lambda (drv)
(assq-ref (db-get-build drv) #:status))))
(build-current-status (db-get-build drv)))))
(for-each (compose db-add-build make-dummy-build)
(list drv-1 drv-2 drv-3 drv-4
drv-5 drv-6 drv-7))
(db-add-build-dependencies "/build-dep-2.drv"
(list "/build-dep-1.drv"))
(db-add-build-dependencies "/build-dep-4.drv"

50
tests/http.scm
View File

@ -122,29 +122,35 @@
(test-assert "fill-db"
(let* ((build1
`((#:derivation . "/gnu/store/fake.drv")
(#:eval-id . 1)
(#:job-name . "fake-job")
(#:system . "x86_64-linux")
(#:nix-name . "fake-1.0")
(#:log . "unused so far")
(#:status . ,(build-status succeeded))
(#:outputs . (("out" . "/gnu/store/fake-1.0")))
(#:timestamp . 1501347493)
(#:starttime . 1501347493)
(#:stoptime . 1501347493)))
(build (derivation "/gnu/store/fake.drv")
(evaluation-id 1)
(specification-name "guix")
(job-name "fake-job")
(system "x86_64-linux")
(nix-name "fake-1.0")
(log "unused so far")
(status (build-status succeeded))
(outputs
(list (output
(item "/gnu/store/fake-1.0")
(derivation derivation))))
(creation-time 1501347493)
(start-time 1501347493)
(completion-time 1501347493)))
(build2
`((#:derivation . "/gnu/store/fake2.drv")
(#:eval-id . 1)
(#:job-name . "fake-job")
(#:system . "x86_64-linux")
(#:nix-name . "fake-2.0")
(#:log . "unused so far")
(#:status . ,(build-status scheduled))
(#:outputs . (("out" . "/gnu/store/fake-2.0")))
(#:timestamp . 1501347493)
(#:starttime . 0)
(#:stoptime . 0)))
(build (derivation "/gnu/store/fake2.drv")
(evaluation-id 1)
(specification-name "guix")
(job-name "fake-job")
(system "x86_64-linux")
(nix-name "fake-2.0")
(log "unused so far")
(status (build-status scheduled))
(outputs
(list (output
(item "/gnu/store/fake-2.0")
(derivation derivation))))
(creation-time 1501347493)))
(spec
(specification
(name "guix")

41
tests/remote.scm
View File

@ -16,7 +16,12 @@
;;; You should have received a copy of the GNU General Public License
;;; along with Cuirass. If not, see <http://www.gnu.org/licenses/>.
(use-modules (cuirass database)
(use-modules ((cuirass database)
#:renamer (lambda (symbol)
;; Avoid collision with #$output.
(if (eq? symbol 'output)
'make-output
symbol)))
(cuirass specification)
(gnu packages base)
(guix build utils)
@ -25,7 +30,7 @@
(guix gexp)
(guix monads)
(guix packages)
(guix store)
((guix store) #:hide (build))
(tests common)
(avahi)
(avahi client)
@ -108,16 +113,18 @@
drv
output
(timeout 0))
`((#:derivation . ,drv)
(#:eval-id . 1)
(#:job-name . "fake-job")
(#:system . "x86_64-linux")
(#:nix-name . "fake-1.0")
(#:log . "unused so far")
(#:status . ,(build-status scheduled))
(#:outputs . (("out" . ,output)))
(#:timestamp . 1501347493)
(#:timeout . ,timeout)))
(build (derivation drv)
(evaluation-id 1)
(specification-name "guix")
(job-name "fake-job")
(system "x86_64-linux")
(nix-name "fake-1.0")
(log "unused so far")
(status (build-status scheduled))
(outputs (list (make-output (item output)
(derivation drv))))
(creation-time 501347493)
(timeout timeout)))
(define guix-daemon-running?
(let ((result (delay (guard (c ((store-connection-error? c) #f))
@ -152,8 +159,7 @@
(test-skip (if (and (guix-daemon-running?) (avahi-daemon-running?)) 0 100))
(test-assert "fill-db"
(let ((build build)
(spec
(let ((spec
(specification
(name "guix")
(build 'hello)))
@ -182,7 +188,7 @@
(test-assert "build done"
(retry
(lambda ()
(eq? (assq-ref (db-get-build (force drv)) #:status)
(eq? (build-current-status (db-get-build (force drv)))
(build-status succeeded)))
#:times 10
#:delay 1))
@ -194,7 +200,8 @@
#:timeout 1))
(retry
(lambda ()
(eq? (assq-ref (db-get-build (force drv-with-timeout)) #:status)
(eq? (build-current-status
(db-get-build (force drv-with-timeout)))
(build-status failed)))
#:times 10
#:delay 1)))
@ -206,7 +213,7 @@
(db-update-build-status! (force drv) (build-status scheduled))
(retry
(lambda ()
(eq? (assq-ref (db-get-build (force drv)) #:status)
(eq? (build-current-status (db-get-build (force drv)))
(build-status succeeded)))
#:times 10
#:delay 1)))