[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[no subject]
|
From: |
Mathieu Othacehe |
|
Date: |
Fri, 5 Mar 2021 03:09:50 -0500 (EST) |
branch: master
commit 325edf2ffa3cfca35cbedbcabd88b778374808fb
Author: Mathieu Othacehe <othacehe@gnu.org>
AuthorDate: Wed Mar 3 15:25:04 2021 +0100
Rewrite evaluation.
---
Makefile.am | 1 +
bin/cuirass.in | 10 +-
bin/evaluate.in | 220 +++++++++++++-----------------------
src/cuirass/base.scm | 252 ++++++++++--------------------------------
src/cuirass/database.scm | 179 ++++++++++++------------------
src/cuirass/http.scm | 67 ++++++-----
src/cuirass/metrics.scm | 3 +-
src/cuirass/notification.scm | 118 +++++++++++++-------
src/cuirass/specification.scm | 153 +++++++++++++++++++++++++
src/cuirass/templates.scm | 123 +++++++++++++--------
src/schema.sql | 34 ++----
tests/database.scm | 113 ++++++++++---------
tests/http.scm | 77 +++++++------
tests/metrics.scm | 7 +-
14 files changed, 663 insertions(+), 694 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index 06f0f5f..928d201 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -63,6 +63,7 @@ dist_pkgmodule_DATA = \
src/cuirass/remote-worker.scm \
src/cuirass/rss.scm \
src/cuirass/send-events.scm \
+ src/cuirass/specification.scm \
src/cuirass/ui.scm \
src/cuirass/utils.scm \
src/cuirass/templates.scm \
diff --git a/bin/cuirass.in b/bin/cuirass.in
index 8dbb14f..e6f7564 100644
--- a/bin/cuirass.in
+++ b/bin/cuirass.in
@@ -33,6 +33,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
(cuirass logging)
(cuirass metrics)
(cuirass notification)
+ (cuirass specification)
(cuirass utils)
(cuirass watchdog)
(cuirass zabbix)
@@ -149,13 +150,8 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0"
"$@"
(with-database
(with-notification
(and specfile
- (let ((new-specs (save-module-excursion
- (lambda ()
- (set-current-module
- (make-user-module '()))
- (primitive-load specfile)))))
-
- (for-each db-add-specification new-specs)))
+ (for-each db-add-specification
+ (read-specifications specfile)))
(and paramfile (read-parameters paramfile))
(if one-shot?
diff --git a/bin/evaluate.in b/bin/evaluate.in
index 19d0f12..aa87ddc 100644
--- a/bin/evaluate.in
+++ b/bin/evaluate.in
@@ -6,7 +6,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
;;;; evaluate -- convert a specification to a job list
;;; Copyright © 2016, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
-;;; Copyright © 2017, 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2017, 2018, 2021 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;;
;;; This file is part of Cuirass.
@@ -25,148 +25,86 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0"
"$@"
;;; along with Cuirass. If not, see <http://www.gnu.org/licenses/>.
-;; Note: Do not use any Guix modules (see below).
-(use-modules (ice-9 match)
+(use-modules (cuirass database)
+ (cuirass specification)
+ (guix channels)
+ (guix inferior)
+ (guix licenses)
+ (guix store)
+ (guix utils)
+ (ice-9 match)
(ice-9 pretty-print)
- (srfi srfi-1)
- (srfi srfi-26))
-
-(define (ref module name)
- "Dynamically link variable NAME under MODULE and return it."
- (let ((m (resolve-interface module)))
- (module-ref m name)))
-
-(define (absolutize directory load-path)
- (if (string-prefix? "/" load-path)
- load-path
- (string-append directory "/" load-path)))
-
-(define (input-checkout checkouts input-name)
- "Find in CHECKOUTS the CHECKOUT corresponding to INPUT-NAME, and return it."
- (find (lambda (checkout)
- (string=? (assq-ref checkout #:input)
- input-name))
- checkouts))
-
-(define (spec-source spec checkouts)
- "Find in CHECKOUTS the directory where the #:PROC-INPUT repository of SPEC
-has been checked out, and return it."
- (let* ((input-name (assq-ref spec #:proc-input))
- (checkout (input-checkout checkouts input-name)))
- (assq-ref checkout #:directory)))
-
-(define (spec-load-path spec checkouts)
- "Find in CHECKOUTS the load paths of each SPEC's #:LOAD-PATH-INPUTS and
-return them as a list."
- (map (lambda (input-name)
- (let* ((checkout (input-checkout checkouts input-name))
- (directory (assq-ref checkout #:directory))
- (load-path (assq-ref checkout #:load-path)))
- (absolutize directory load-path)))
- (assq-ref spec #:load-path-inputs)))
-
-(define (spec-package-path spec checkouts)
- "Find in CHECKOUTS the package paths of each SPEC's #:PACKAGE-PATH-INPUTS
-and return them as a colon separated string."
- (let* ((input-names (assq-ref spec #:package-path-inputs))
- (checkouts (map (cut input-checkout checkouts <>) input-names)))
- (string-join
- (map
- (lambda (checkout)
- (let ((directory (assq-ref checkout #:directory))
- (load-path (assq-ref checkout #:load-path)))
- (absolutize directory load-path)))
- checkouts)
- ":")))
-
-(define (format-checkouts checkouts)
- "Format checkouts the way Hydra does: #:NAME becomes the key as a symbol,
-#:DIRECTORY becomes FILE-NAME and #:COMMIT becomes REVISION. The other
-entries are added because they could be useful during the evaluation."
- (map
- (lambda (checkout)
- (let loop ((in checkout)
- (out '())
- (name #f))
- (match in
- (()
- (cons name out))
- (((#:input . val) . rest)
- (loop rest out (string->symbol val)))
- (((#:directory . val) . rest)
- (loop rest (cons `(file-name . ,val) out) name))
- (((#:commit . val) . rest)
- (loop rest (cons `(revision . ,val) out) name))
- (((keyword . val) . rest)
- (loop rest (cons `(,(keyword->symbol keyword) . ,val) out) name)))))
- checkouts))
+ (ice-9 threads))
+
+(define (checkouts->channel-instances checkouts)
+ "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)))
+ (checkout->channel-instance directory
+ #:name channel
+ #:commit commit)))
+ checkouts))
+
+(define* (inferior-evaluation store instances
+ #:key
+ eval-id spec build systems)
+ "Spawn an inferior on INSTANCES that uses the given STORE. Withing that
+inferior, call PROC with PROC-ARGS arguments from MODULE. Pass PROC a
+register procedure that writes its arguments on a socket. Listen that socket
+for new jobs and register them using REGISTER-JOB procedure."
+ ;; The module where the below procedure is defined.
+ (define eval-module '(gnu ci))
+
+ ;; The Guix procedure for job evaluation.
+ (define eval-proc 'cuirass-jobs)
+
+ (let* ((cached (cached-channel-instance store instances))
+ (inferior (open-inferior cached))
+ (channels (map channel-instance->sexp instances))
+ (args `((channels . ,channels)
+ (systems . ,systems)
+ (subset . ,build))))
+ (inferior-eval `(use-modules ,eval-module) inferior)
+ (let ((jobs
+ (inferior-eval-with-store
+ inferior store
+ `(lambda (store)
+ (,eval-proc store ',args)))))
+ (db-register-builds jobs eval-id spec))))
(define* (main #:optional (args (command-line)))
+ "This procedure spawns an inferior on the given channels. An evaluation
+procedure is called within that inferior. The evaluation procedure is passed
+a job registration callback. The registered jobs are then read on a socket
+nd registered in database."
(match args
- ((command spec-str checkouts-str)
- ;; Load FILE, a Scheme file that defines Hydra jobs.
- ;;
- ;; Until FILE is loaded, we must *not* load any Guix module because the
- ;; user may be providing its own with #:LOAD-PATH-INPUTS, which could
- ;; differ from ours. The 'ref' procedure helps us achieve this.
- (let* ((%user-module (make-fresh-user-module))
- (spec (with-input-from-string spec-str read))
- (checkouts (with-input-from-string checkouts-str read))
- (source (spec-source spec checkouts))
- (file (assq-ref spec #:proc-file))
- (stdout (current-output-port))
- (stderr (current-error-port)))
- (setenv "GUIX_PACKAGE_PATH" (spec-package-path spec checkouts))
-
- ;; Since we have relative file name canonicalization by default, better
- ;; change to SOURCE to make sure things like 'include' with relative
- ;; file names work as expected.
- (chdir source)
-
- ;; Change '%load-path' once and for all. We need it to be effective
- ;; both when we load FILE and when we later call the thunks.
- (set! %load-path (append (spec-load-path spec checkouts) %load-path))
-
- (save-module-excursion
- (lambda ()
- (set-current-module %user-module)
- (primitive-load file)))
-
- ;; From there on we can access Guix modules.
-
- (let ((store ((ref '(guix store) 'open-connection)))
- (set-build-options (ref '(guix store)
- 'set-build-options)))
- (unless (assoc-ref spec #:use-substitutes?)
- ;; Make sure we don't resort to substitutes.
- (set-build-options store #:use-substitutes? #f #:substitute-urls
'()))
-
- ;; Grafts can trigger early builds. We do not want that to happen
- ;; during evaluation, so use a sledgehammer to catch such problems.
- ;; An exception, though, is the evaluation of Guix itself, which
- ;; requires building a "trampoline" program.
- (let ((real-build-things (ref '(guix store) 'build-things)))
- (module-set! (resolve-module '(guix store))
- 'build-things
- (lambda (store . args)
- (simple-format stderr "warning:
-building things during evaluation~%")
- (simple-format stderr
- "'build-things' arguments: ~S~%"
- args)
- (apply real-build-things store args))))
-
- ;; Call the entry point of FILE and print the resulting job sexp.
- (let* ((proc (module-ref %user-module (assq-ref spec #:proc)))
- (args `(,@(format-checkouts checkouts)
- ,@(or (assq-ref spec #:proc-args) '())))
- (thunks (proc store args)))
- (pretty-print
- `(evaluation ,(map (lambda (thunk) (thunk))
- thunks))
- stdout)))))
- ((command _ ...)
- (simple-format (current-error-port) "Usage: ~A FILE
-Evaluate the Hydra jobs defined in FILE.~%"
- command)
+ ((command database eval-str)
+ (parameterize ((%package-database database))
+ (with-database
+ (let* ((eval-id (with-input-from-string eval-str read))
+ (name (db-get-evaluation-specification eval-id))
+ (spec (db-get-specification name))
+ (checkouts (db-get-checkouts eval-id))
+ (instances (checkouts->channel-instances checkouts))
+ (build (specification-build spec))
+ (systems (specification-systems spec)))
+
+ (par-for-each
+ (lambda (system)
+ (with-store store
+ (set-build-options store
+ #:use-substitutes? #f
+ #:substitute-urls '())
+ (inferior-evaluation store instances
+ #:eval-id eval-id
+ #:spec spec
+ #:build build
+ #:systems (list system))))
+ systems)
+ (display 'done)))))
+ (x
+ (format (current-error-port) "Wrong command: ~a~%." x)
(exit 1))))
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index 8528409..6c09783 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -1,7 +1,7 @@
;;; base.scm -- Cuirass base module
;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
-;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2017, 2020, 2021 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;;
@@ -26,10 +26,12 @@
#:use-module (cuirass logging)
#:use-module (cuirass database)
#:use-module (cuirass remote)
+ #:use-module (cuirass specification)
#:use-module (cuirass utils)
#:use-module ((cuirass config) #:select (%localstatedir))
#:use-module (gnu packages)
#:use-module (guix build utils)
+ #:use-module (guix channels)
#:use-module (guix derivations)
#:use-module (guix store)
#:use-module (guix ui)
@@ -62,9 +64,6 @@
#:export (;; Procedures.
call-with-time-display
read-parameters
- fetch-input
- fetch-inputs
- compile
evaluate
build-derivations&
set-build-successful!
@@ -198,86 +197,6 @@ values."
(lambda (key err)
(report-git-error err))))
-(define* (fetch-input store input #:key writable-copy?) ;TODO fix desc
- "Get the latest version of repository inputified in INPUT. Return an
-association list containing the input name, the content of the git repository
-at URL copied into a store directory and the sha1 of the top level commit in
-this directory.
-
-When WRITABLE-COPY? is true, return a writable copy; otherwise, return a
-read-only directory."
-
- (define (add-origin branch)
- "Prefix branch name with origin if no remote is specified."
- (if (string-index branch #\/)
- branch
- (string-append "origin/" branch)))
-
- (let ((name (assq-ref input #:name))
- (url (assq-ref input #:url))
- (branch (and=> (assq-ref input #:branch)
- (lambda (b)
- `(branch . ,(add-origin b)))))
- (commit (and=> (assq-ref input #:commit)
- (lambda (c)
- `(commit . ,c))))
- (tag (and=> (assq-ref input #:tag)
- (lambda (t)
- `(tag . ,t)))))
- (let*-values (((directory commit)
- (latest-repository-commit store url
- #:cache-directory
- (%package-cachedir)
- #:ref (or branch commit tag)))
- ((timestamp)
- (time-second (current-time time-utc))))
- ;; TODO: When WRITABLE-COPY? is true, we could directly copy the
- ;; checkout directly in a writable location instead of copying it to the
- ;; store first.
- (let ((directory (if writable-copy?
- (make-writable-copy directory
- (string-append
- (%package-cachedir) "/" name))
- directory)))
- `((#:input . ,name)
- (#:directory . ,directory)
- (#:commit . ,commit)
- (#:timestamp . ,timestamp)
- (#:load-path . ,(assq-ref input #:load-path))
- (#:no-compile? . ,(assq-ref input #:no-compile?)))))))
-
-(define (make-writable-copy source target)
- "Create TARGET and make it a writable copy of directory SOURCE; delete
-TARGET beforehand if it exists. Return TARGET."
- (define (chmod+w file stat _)
- (chmod file (logior #o200 (stat:perms stat))))
-
- (mkdir-p (dirname target))
- ;; Remove any directory with the same name.
- (false-if-exception (delete-file-recursively target))
- (copy-recursively source target)
-
- ;; Make all the files in TARGET writable.
- (file-system-fold (const #t) ;enter?
- chmod+w ;leaf
- chmod+w ;down
- (const #t) ;up
- (const #t) ;skip
- (const #f) ;error
- *unspecified* ;init
- target)
-
- target)
-
-(define (compile dir)
- ;; Required for fetching Guix bootstrap tarballs.
- "Compile files in repository in directory DIR."
- (with-directory-excursion dir
- (or (file-exists? "configure") (system* "./bootstrap"))
- (or (file-exists? "Makefile")
- (system* "./configure" "--localstatedir=/var"))
- (zero? (system* "make" "-j" (number->string (current-processor-count))))))
-
(define-condition-type &evaluation-error &error
evaluation-error?
(name evaluation-error-spec-name)
@@ -322,7 +241,7 @@ fibers."
"/log/cuirass/evaluations/"
(number->string eval-id) ".gz"))
-(define (evaluate store spec eval-id checkouts)
+(define (evaluate store spec eval-id)
"Evaluate and build package derivations defined in SPEC, using CHECKOUTS.
Return a list of jobs that are associated to EVAL-ID."
(define log-file
@@ -355,8 +274,8 @@ Return a list of jobs that are associated to EVAL-ID."
(with-error-to-port (cdr log-pipe)
(lambda ()
(open-pipe* OPEN_READ "evaluate"
- (object->string spec)
- (object->string checkouts))))))
+ (%package-database)
+ (object->string eval-id))))))
(result (match (read/non-blocking port)
;; If an error occured during evaluation report it,
;; otherwise, suppose that data read from port are
@@ -367,16 +286,13 @@ Return a list of jobs that are associated to EVAL-ID."
(close-port (cdr log-pipe))
(raise (condition
(&evaluation-error
- (name (assq-ref spec #:name))
+ (name (specification-name spec))
(id eval-id)))))
- (data data))))
+ (_ #t))))
(close-port (cdr log-pipe))
(close-pipe port)
- (match result
- (('evaluation jobs)
- (let* ((spec-name (assq-ref spec #:name)))
- (log-message "evaluation ~a for '~a' completed" eval-id spec-name)
- jobs)))))
+ (let ((spec-name (specification-name spec)))
+ (log-message "evaluation ~a for '~a' completed" eval-id spec-name))))
;;;
@@ -479,7 +395,7 @@ build products."
(assq-ref build #:specification)))))
(when (and spec build)
(create-build-outputs build
- (assq-ref spec #:build-outputs))))
+ (specification-build-outputs spec))))
(db-update-build-status! drv (build-status succeeded)
#:log-file log))
@@ -670,17 +586,17 @@ started)."
(spawn-builds store valid))
(log-message "done with restarted builds"))))
-(define (create-build-outputs build product-specs)
+(define (create-build-outputs build build-outputs)
"Given BUILDS a list of built derivations, save the build products described
-by PRODUCT-SPECS."
+by BUILD-OUTPUTS."
(define (build-has-products? job-regex)
(let ((job-name (assq-ref build #:job-name)))
(string-match job-regex job-name)))
- (define* (find-product build spec)
+ (define* (find-product build build-output)
(let* ((outputs (assq-ref build #:outputs))
- (output (assq-ref spec #:output))
- (path (assq-ref spec #:path))
+ (output (build-output-output build-output))
+ (path (build-output-path build-output-path))
(root (and=> (assoc-ref outputs output)
(cut assq-ref <> #:path))))
(and root
@@ -691,27 +607,28 @@ by PRODUCT-SPECS."
(define (file-size file)
(stat:size (stat file)))
- (for-each (lambda (spec)
- (let ((product (and (build-has-products? (assq-ref spec #:job))
- (find-product build spec))))
+ (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-message "Adding build product ~a" product)
- (db-add-build-product `((#:build . ,(assq-ref build #:id))
- (#:type . ,(assq-ref spec #:type))
- (#:file-size . ,(file-size product))
- ;; TODO: Implement it.
- (#:checksum . "")
- (#:path . ,product))))))
- product-specs))
-
-(define (build-packages store jobs eval-id)
+ (db-add-build-product
+ `((#:build . ,(assq-ref build #:id))
+ (#:type . ,(build-output-type build-output-type))
+ (#:file-size . ,(file-size product))
+ ;; TODO: Implement it.
+ (#:checksum . "")
+ (#:path . ,product))))))
+ build-outputs))
+
+(define (build-packages store eval-id)
"Build JOBS and return a list of Build results."
+ (define builds
+ (db-get-builds `((evaluation . ,eval-id))))
+
(define derivations
- (let* ((name (db-get-evaluation-specification eval-id))
- (specification (db-get-specification name)))
- (with-time-logging
- (format #f "evaluation ~a registration" eval-id)
- (db-register-builds jobs eval-id specification))))
+ (map (cut assq-ref <> #:derivation) builds))
(log-message "evaluation ~a registered ~a new derivations"
eval-id (length derivations))
@@ -719,22 +636,22 @@ by PRODUCT-SPECS."
(evaluation-status succeeded))
(unless (%build-remote?)
- (spawn-builds store derivations))
-
- (let* ((results (filter-map (cut db-get-build <>) derivations))
- (status (map (cut assq-ref <> #: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))
- (fail (- (length derivations) success)))
-
- (log-message "outputs:\n~a" (string-join outs "\n"))
- results))
+ (spawn-builds store derivations)
+
+ (let* ((results (filter-map (cut db-get-build <>) derivations))
+ (status (map (cut assq-ref <> #: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))
+ (fail (- (length derivations) success)))
+
+ (log-message "outputs:\n~a" (string-join outs "\n"))
+ results)))
(define (prepare-git)
"Prepare Guile-Git's TLS support and all."
@@ -748,68 +665,21 @@ by PRODUCT-SPECS."
(when (or directory file)
(set-tls-certificate-locations! directory file)))))
-(define (compile? checkout)
- (not (assq-ref checkout #:no-compile?)))
-
-(define (fetch-inputs spec)
- "Fetch all inputs of SPEC in parallel."
- (let* ((inputs (assq-ref spec #:inputs))
- (thunks
- (map
- (lambda (input)
- (lambda ()
- (with-store store
- (log-message "fetching input '~a' of spec '~a'"
- (assq-ref input #:name)
- (assq-ref spec #:name))
- ;; XXX: Work around: https://issues.guix.gnu.org/44742.
- (parameterize ((current-error-port (%make-void-port "rw+")))
- (fetch-input store input
- #:writable-copy? (compile? input))))))
- inputs))
- (results (map %non-blocking thunks)))
- (map (lambda (checkout)
- (log-message "fetched input '~a' of spec '~a' (commit ~s)"
- (assq-ref checkout #:input)
- (assq-ref spec #:name)
- (assq-ref checkout #:commit))
- checkout)
- results)))
-
-(define (compile-checkouts spec checkouts)
- "Compile CHECKOUTS in parallel."
- (let* ((thunks
- (map
- (lambda (checkout)
- (lambda ()
- (log-message "compiling input '~a' of spec '~a' (commit ~s)"
- (assq-ref checkout #:input)
- (assq-ref spec #:name)
- (assq-ref checkout #:commit))
- (compile checkout)))
- checkouts))
- (results (map %non-blocking thunks)))
- (map (lambda (checkout)
- (log-message "compiled input '~a' of spec '~a' (commit ~s)"
- (assq-ref checkout #:input)
- (assq-ref spec #:name)
- (assq-ref checkout #:commit))
- checkout)
- results)))
-
(define (process-specs jobspecs)
"Evaluate and build JOBSPECS and store results in the database."
(define (process spec)
(with-store store
- (let* ((name (assoc-ref spec #:name))
+ (let* ((name (specification-name spec))
(timestamp (time-second (current-time time-utc)))
- (checkouts (fetch-inputs spec))
+ (channels (specification-channels spec))
+ (instances (non-blocking
+ (latest-channel-instances store channels
+ #:authenticate? #f)))
(checkouttime (time-second (current-time time-utc)))
- (eval-id (db-add-evaluation name checkouts
+ (eval-id (db-add-evaluation name instances
#:timestamp timestamp
#:checkouttime checkouttime)))
(when eval-id
- (compile-checkouts spec (filter compile? checkouts))
(spawn-fiber
(lambda ()
(guard (c ((evaluation-error? c)
@@ -820,11 +690,9 @@ by PRODUCT-SPECS."
#f))
(log-message "evaluating spec '~a'" name)
(with-store store
- (let ((jobs (evaluate store spec eval-id checkouts)))
- (db-set-evaluation-time eval-id)
- (log-message "building ~a jobs for '~a'"
- (length jobs) name)
- (build-packages store jobs eval-id))))))
+ (evaluate store spec eval-id)
+ (db-set-evaluation-time eval-id)
+ (build-packages store eval-id)))))
;; 'spawn-fiber' returns zero values but we need one.
*unspecified*))))
@@ -836,6 +704,6 @@ by PRODUCT-SPECS."
(process spec))
(lambda (key error)
(log-message "Git error while fetching inputs of '~a': ~s~%"
- (assq-ref spec #:name)
+ (specification-name spec)
(git-error-message error)))))
jobspecs))
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index cc4ff5a..c882d57 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -26,7 +26,9 @@
#:use-module (cuirass config)
#:use-module (cuirass notification)
#:use-module (cuirass remote)
+ #:use-module (cuirass specification)
#:use-module (cuirass utils)
+ #:use-module (guix channels)
#:use-module (squee)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
@@ -46,11 +48,9 @@
exec-query/bind-params
expect-one-row
read-sql-file
- db-add-input
db-add-checkout
db-add-specification
db-remove-specification
- db-get-inputs
db-get-specification
db-get-specifications
evaluation-status
@@ -371,99 +371,55 @@ database object."
"Close database object DB."
(pg-conn-finish db))
-(define (db-add-input spec-name input)
- (with-db-worker-thread db
- (exec-query/bind db "\
-INSERT INTO Inputs (specification, name, url, load_path, branch, \
-tag, revision, no_compile_p) VALUES ("
- spec-name ", "
- (assq-ref input #:name) ", "
- (assq-ref input #:url) ", "
- (assq-ref input #:load-path) ", "
- (assq-ref input #:branch) ", "
- (assq-ref input #:tag) ", "
- (assq-ref input #:commit) ", "
- (if (assq-ref input #:no-compile?) 1 0) ")
-ON CONFLICT ON CONSTRAINT inputs_pkey DO NOTHING;")))
-
-(define (db-add-checkout spec-name eval-id checkout)
- "Insert CHECKOUT associated with SPEC-NAME and EVAL-ID. If a checkout with
+(define* (db-add-checkout spec-name eval-id instance
+ #:key timestamp)
+ "Insert INSTANCE associated with SPEC-NAME and EVAL-ID. If a checkout with
the same revision already exists for SPEC-NAME, return #f."
- (with-db-worker-thread db
- (match (expect-one-row
- (exec-query/bind db "\
-INSERT INTO Checkouts (specification, revision, evaluation, input,
+ (let ((channel (channel-instance-channel instance)))
+ (with-db-worker-thread db
+ (match (expect-one-row
+ (exec-query/bind db "\
+INSERT INTO Checkouts (specification, revision, evaluation, channel,
directory, timestamp) VALUES ("
- spec-name ", "
- (assq-ref checkout #:commit) ", "
- eval-id ", "
- (assq-ref checkout #:input) ", "
- (assq-ref checkout #:directory) ", "
- (or (assq-ref checkout #:timestamp) 0) ")
+ spec-name ", "
+ (channel-instance-commit instance) ", "
+ eval-id ", "
+ (symbol->string (channel-name channel)) ", "
+ (channel-instance-checkout instance) ", "
+ (or timestamp 0) ")
ON CONFLICT ON CONSTRAINT checkouts_pkey DO NOTHING
RETURNING (specification, revision);"))
- (x x)
- (() #f))))
+ (x x)
+ (() #f)))))
(define (db-add-specification spec)
- "Store SPEC in database the database. SPEC inputs are stored in the INPUTS
-table."
+ "Store SPEC in database."
(with-db-worker-thread db
(match (expect-one-row
(exec-query/bind db "\
-INSERT INTO Specifications (name, load_path_inputs, \
-package_path_inputs, proc_input, proc_file, proc, proc_args, \
-build_outputs, notifications, priority) \
+INSERT INTO Specifications (name, build, channels, \
+build_outputs, notifications, priority, systems) \
VALUES ("
- (assq-ref spec #:name) ", "
- (assq-ref spec #:load-path-inputs) ", "
- (assq-ref spec #:package-path-inputs) ", "
- (assq-ref spec #:proc-input) ", "
- (assq-ref spec #:proc-file) ", "
- (symbol->string (assq-ref spec #:proc)) ", "
- (assq-ref spec #:proc-args) ", "
- (assq-ref spec #:build-outputs) ", "
- (or (assq-ref spec #:notifications) '()) ", "
- (or (assq-ref spec #:priority) max-priority) ")
+ (specification-name spec) ", "
+ (specification-build spec) ", "
+ (map channel->sexp
+ (specification-channels spec)) ", "
+ (map build-output->sexp
+ (specification-build-outputs spec)) ", "
+ (map notification->sexp
+ (specification-notifications spec)) ", "
+ (specification-priority spec) ", "
+ (specification-systems spec) ")
ON CONFLICT ON CONSTRAINT specifications_pkey DO NOTHING
RETURNING name;"))
- ((name)
- (for-each (lambda (input)
- (db-add-input (assq-ref spec #:name) input))
- (assq-ref spec #:inputs))
- name)
+ ((name) name)
(else #f))))
(define (db-remove-specification name)
- "Remove the specification matching NAME from the database and its inputs."
+ "Remove the specification matching NAME from the database."
(with-db-worker-thread db
- (exec-query db "BEGIN TRANSACTION;")
- (exec-query/bind db "\
-DELETE FROM Inputs WHERE specification=" name ";")
(exec-query/bind db "\
-DELETE FROM Specifications WHERE name=" name ";")
- (exec-query db "COMMIT;")))
-
-(define (db-get-inputs spec-name)
- (with-db-worker-thread db
- (let loop ((rows (exec-query/bind
- db "SELECT * FROM Inputs WHERE specification="
- spec-name "ORDER BY name;"))
- (inputs '()))
- (match rows
- (() (reverse inputs))
- (((specification name url load-path branch tag revision no-compile-p)
- . rest)
- (loop rest
- (cons `((#:name . ,name)
- (#:url . ,url)
- (#:load-path . ,load-path)
- (#:branch . ,branch)
- (#:tag . ,tag)
- (#:commit . ,revision)
- (#:no-compile? . ,(positive?
- (string->number no-compile-p))))
- inputs)))))))
+DELETE FROM Specifications WHERE name=" name ";")))
(define (db-get-specification name)
"Retrieve a specification in the database with the given NAME."
@@ -474,31 +430,31 @@ DELETE FROM Specifications WHERE name=" name ";")
(let loop
((rows (if name
(exec-query/bind db "
-SELECT * FROM Specifications WHERE name =" name ";")
+SELECT name, build, channels, build_outputs, notifications,\
+priority, systems FROM Specifications WHERE name =" name ";")
(exec-query db "
-SELECT * FROM Specifications ORDER BY name ASC;")))
+SELECT name, build, channels, build_outputs, notifications,\
+priority, systems FROM Specifications ORDER BY name ASC;")))
(specs '()))
(match rows
(() (reverse specs))
- (((name load-path-inputs package-path-inputs proc-input proc-file proc
- proc-args build-outputs priority notifications)
+ (((name build channels build-outputs notifications priority systems)
. rest)
(loop rest
- (cons `((#:name . ,name)
- (#:load-path-inputs .
- ,(with-input-from-string load-path-inputs read))
- (#:package-path-inputs .
- ,(with-input-from-string package-path-inputs read))
- (#:proc-input . ,proc-input)
- (#:proc-file . ,proc-file)
- (#:proc . ,(with-input-from-string proc read))
- (#:proc-args . ,(with-input-from-string proc-args read))
- (#:inputs . ,(db-get-inputs name))
- (#:build-outputs .
- ,(with-input-from-string build-outputs read))
- (#:notifications .
- ,(with-input-from-string notifications read))
- (#:priority . ,(string->number priority)))
+ (cons (specification
+ (name name)
+ (build (with-input-from-string build read))
+ (channels
+ (map sexp->channel
+ (with-input-from-string channels read)))
+ (build-outputs
+ (map sexp->build-output
+ (with-input-from-string build-outputs read)))
+ (notifications
+ (map sexp->notification
+ (with-input-from-string notifications read)))
+ (priority (string->number priority))
+ (systems (with-input-from-string systems read)))
specs)))))))
(define-enumeration evaluation-status
@@ -518,12 +474,12 @@ INSERT INTO Events (type, timestamp, event_json) VALUES ("
");")
#t)))
-(define* (db-add-evaluation spec-name checkouts
+(define* (db-add-evaluation spec-name instances
#:key
(checkouttime 0)
(evaltime 0)
timestamp)
- "Add a new evaluation for SPEC-NAME only if one of the CHECKOUTS is new.
+ "Add a new evaluation for SPEC-NAME only if one of the INSTANCES is new.
Otherwise, return #f."
(define now
(or timestamp (time-second (current-time time-utc))))
@@ -539,10 +495,12 @@ VALUES (" spec-name "," (evaluation-status started) ","
now "," checkouttime "," evaltime ")
RETURNING id;"))
((id) (string->number id))))
- (new-checkouts (filter-map
- (cut db-add-checkout spec-name eval-id <>)
- checkouts)))
- (if (null? new-checkouts)
+ (new-instances (filter-map
+ (lambda (instance)
+ (db-add-checkout spec-name eval-id instance
+ #:timestamp timestamp))
+ instances)))
+ (if (null? new-instances)
(begin (exec-query db "ROLLBACK;")
#f)
(begin (db-add-event 'evaluation
@@ -715,7 +673,7 @@ where id = " build-id ") d;
(not (null? new-outputs))))
(define (build-priority priority)
- (let ((spec-priority (assq-ref specification #:priority)))
+ (let ((spec-priority (specification-priority specification)))
(+ (* spec-priority 10) priority)))
(define (register job)
@@ -750,7 +708,7 @@ where id = " build-id ") d;
(#:starttime . 0)
(#:stoptime . 0))))
(if period
- (let* ((spec (assq-ref specification #:name))
+ (let* ((spec (specification-name specification))
(time
(db-get-time-since-previous-build job-name spec))
(add-build? (cond
@@ -838,7 +796,8 @@ UPDATE Builds SET stoptime =" now
(let* ((build (db-get-build drv))
(spec (assq-ref build #:specification))
(specification (db-get-specification spec))
- (notifications (assq-ref specification #:notifications)))
+ (notifications
+ (specification-notifications specification)))
(send-notifications notifications #:build build)
(db-add-event 'build
now
@@ -1244,16 +1203,16 @@ SELECT derivation FROM Builds WHERE Builds.status <
0;"))))
(define (db-get-checkouts eval-id)
(with-db-worker-thread db
(let loop ((rows (exec-query/bind
- db "SELECT revision, input, directory FROM Checkouts
-WHERE evaluation =" eval-id ";"))
+ db "SELECT revision, channel, directory FROM Checkouts
+WHERE evaluation =" eval-id " ORDER BY channel ASC;"))
(checkouts '()))
(match rows
(() (reverse checkouts))
- (((revision input directory)
+ (((revision channel directory)
. rest)
(loop rest
(cons `((#:commit . ,revision)
- (#:input . ,input)
+ (#:channel . ,(string->symbol channel))
(#:directory . ,directory))
checkouts)))))))
diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index 4b5cbf9..0182d2c 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -28,8 +28,10 @@
#:use-module (cuirass metrics)
#:use-module (cuirass utils)
#:use-module (cuirass logging)
+ #:use-module (cuirass notification)
#:use-module (cuirass remote)
#:use-module (cuirass rss)
+ #:use-module (cuirass specification)
#:use-module (cuirass zabbix)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
@@ -47,6 +49,7 @@
#:use-module ((rnrs bytevectors) #:select (utf8->string))
#:use-module (sxml simple)
#:use-module (cuirass templates)
+ #:use-module (guix channels)
#:use-module (guix progress)
#:use-module (guix utils)
#:use-module ((guix store) #:select (%store-prefix))
@@ -129,31 +132,42 @@
(define (specification->json-object spec)
"Turn SPEC into a representation suitable for 'json->scm'."
- (define (atom? x)
- (not (pair? x)))
-
- (define (atom-list? obj)
- (and (list? obj)
- (every atom? obj)))
-
- `((#:name . ,(assq-ref spec #:name))
- (#:load-path-inputs . ,(list->vector
- (assq-ref spec #:load-path-inputs)))
- (#:package-path-inputs . ,(list->vector
- (assq-ref spec #:package-path-inputs)))
- (#:proc-input . ,(assq-ref spec #:proc-input))
- (#:proc-file . ,(assq-ref spec #:proc-file))
- (#:proc . ,(assq-ref spec #:proc))
- (#:proc-args . ,(map (match-lambda
- ((key . arg)
- (cons key (if (atom-list? arg)
- (list->vector arg)
- arg))))
- (assq-ref spec #:proc-args)))
- (#:inputs . ,(list->vector
- (assq-ref spec #:inputs)))
+ (define (channel->json-object channel)
+ `((#:name . ,(channel-name channel))
+ (#:url . ,(channel-url channel))
+ (#:branch . ,(channel-branch channel))
+ (#:commit . ,(channel-commit channel))))
+
+ (define (build-output->json-object build-output)
+ `((#:job . ,(build-output-job build-output))
+ (#:type . ,(build-output-type build-output))
+ (#:output . ,(build-output-output build-output))
+ (#:path . ,(build-output-path build-output))))
+
+ (define (notification->json-object notif)
+ (cond
+ ((email? notif)
+ `((#:type . email)
+ (#:from . ,(email-from notif))
+ (#:to . ,(email-to notif))
+ (#:server . ,(email-server notif))))
+ ((mastodon? notif)
+ `((#:type . mastodon)))))
+
+ `((#:name . ,(specification-name spec))
+ (#:build . ,(specification-build spec))
+ (#:channels . ,(list->vector
+ (map channel->json-object
+ (specification-channels spec))))
(#:build-outputs . ,(list->vector
- (assq-ref spec #:build-outputs)))))
+ (map build-output->json-object
+ (specification-build-outputs spec))))
+ (#:notifications . ,(list->vector
+ (map notification->json-object
+ (specification-notifications spec))))
+ (#:priority . ,(specification-priority spec))
+ (#:systems . ,(list->vector
+ (specification-systems spec)))))
(define (handle-build-request build-id)
"Retrieve build identified by BUILD-ID over the database and convert it to
@@ -211,8 +225,9 @@ Hydra format."
(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))
+ (define channels (specification-channels
+ (db-get-specification specification)))
(define checkouts (db-get-checkouts id))
- (define inputs (db-get-inputs specification))
(define builds
(vector->list
@@ -229,8 +244,8 @@ Hydra format."
(html-page
"Evaluation"
(evaluation-build-table evaluation
+ #:channels channels
#:checkouts checkouts
- #:inputs inputs
#:status status
#:builds builds
#:builds-id-min builds-id-min
diff --git a/src/cuirass/metrics.scm b/src/cuirass/metrics.scm
index f993cf2..efd6d16 100644
--- a/src/cuirass/metrics.scm
+++ b/src/cuirass/metrics.scm
@@ -19,6 +19,7 @@
(define-module (cuirass metrics)
#:use-module (cuirass database)
#:use-module (cuirass logging)
+ #:use-module (cuirass specification)
#:use-module (guix records)
#:use-module (squee)
#:use-module (srfi srfi-1)
@@ -375,7 +376,7 @@ UPDATE SET value = " value ", timestamp = " now ";"))
;; Limit to the evaluations that were added during the past three days.
(with-db-worker-thread db
(let ((specifications
- (map (cut assq-ref <> #:name) (db-get-specifications)))
+ (map specification-name (db-get-specifications)))
(evaluations (db-latest-evaluations)))
(exec-query db "BEGIN TRANSACTION;")
diff --git a/src/cuirass/notification.scm b/src/cuirass/notification.scm
index 3de7f5b..5688c77 100644
--- a/src/cuirass/notification.scm
+++ b/src/cuirass/notification.scm
@@ -22,12 +22,68 @@
#:use-module (cuirass mastodon)
#:use-module (cuirass parameters)
#:use-module (cuirass utils)
- #:export (notification-type
- notification-event
+ #:use-module (guix records)
+ #:use-module (ice-9 match)
+ #:export (email
+ email?
+ email-from
+ email-to
+ email-server
+
+ mastodon
+ mastodon?
+
+ notification->sexp
+ sexp->notification
with-notification
send-notifications))
+
+;;;
+;;; Notification types.
+;;;
+
+(define-record-type* <email>
+ email make-email
+ email?
+ (from email-from) ;string
+ (to email-to) ;string
+ (server email-server)) ;string
+
+(define-record-type* <mastodon>
+ mastodon make-mastodon
+ mastodon?)
+
+(define (notification->sexp notif)
+ "Return an sexp describing NOTIF."
+ (cond
+ ((email? notif)
+ `(email
+ (from ,(email-from notif))
+ (to ,(email-to notif))
+ (server ,(email-server notif))))
+ ((mastodon? notif)
+ '(mastodon))))
+
+(define (sexp->notification sexp)
+ "Return the notification corresponding to SEXP."
+ (match sexp
+ (('email ('from from)
+ ('to to)
+ ('server server))
+ (email
+ (from from)
+ (to to)
+ (server server)))
+ (('mastodon)
+ (mastodon))))
+
+
+;;;
+;;; Send notifications.
+;;;
+
;; XXX: Some redefinitions to avoid a circular dependency with the (cuirass
;; database) module.
(define weather-success 0)
@@ -54,15 +110,6 @@ interfering with fibers."
(lambda args
exp ...)))
-(define-enumeration notification-type
- (email 0)
- (mastodon 1))
-
-(define-enumeration notification-event
- (always 0)
- (broken-builds 1)
- (fixed-builds 2))
-
(define (build-weather-text build)
"Return the build weather string."
(let ((weather (assq-ref build #:weather)))
@@ -78,19 +125,17 @@ interfering with fibers."
(url (or (%cuirass-url) "")))
(string-append url "/build/" (number->string id) "/details")))
-(define (notification-subject notification)
+(define (notification-subject build)
"Return the subject for the given NOTIFICATION."
- (let* ((build (assq-ref notification #:build))
- (job-name (assq-ref build #:job-name))
+ (let* ((job-name (assq-ref build #:job-name))
(specification (assq-ref build #:specification))
(weather-text (build-weather-text build)))
(format #f "Build ~a on ~a is ~a."
job-name specification weather-text)))
-(define (notification-text notification)
+(define (notification-text build)
"Return the text for the given NOTIFICATION."
- (let* ((build (assq-ref notification #:build))
- (url (build-details-url build))
+ (let* ((url (build-details-url build))
(job-name (assq-ref build #:job-name))
(specification (assq-ref build #:specification))
(weather-text (build-weather-text build)))
@@ -98,13 +143,13 @@ interfering with fibers."
the detailed information about this build here: ~a."
job-name specification weather-text url)))
-(define (notification-email notification)
+(define (send-email* notif build)
"Send an email for the given NOTIFICATION."
- (let* ((from (assq-ref notification #:from))
- (to (assq-ref notification #:to))
- (server (assq-ref notification #:server))
- (subject (notification-subject notification))
- (text (notification-text notification)))
+ (let* ((from (email-from notif))
+ (to (email-to notif))
+ (server (email-server notif))
+ (subject (notification-subject build))
+ (text (notification-text build)))
(catch #t
(lambda ()
(send-email server
@@ -116,9 +161,9 @@ the detailed information about this build here: ~a."
(log-message "Failed to send the email notification: ~a."
args)))))
-(define (notification-mastodon notification)
+(define (send-mastodon build)
"Send a new status for the given NOTIFICATION."
- (let ((text (notification-text notification)))
+ (let ((text (notification-text build)))
(catch #t
(lambda ()
(send-status text))
@@ -131,22 +176,9 @@ the detailed information about this build here: ~a."
(with-notification-worker-thread
(for-each
(lambda (notification)
- (let* ((event (assq-ref notification #:event))
- (type (assq-ref notification #:type))
- (weather (assq-ref build #:weather))
- (success? (eq? weather weather-success))
- (failure? (eq? weather weather-failure)))
- (when (or
- (and (eq? event (notification-event always))
- (or success? failure?))
- (and (eq? event (notification-event broken-builds))
- failure?)
- (and (eq? event (notification-event fixed-builds))
- success?))
- (let ((notification* (acons #:build build notification)))
- (cond
- ((eq? type (notification-type email))
- (notification-email notification*))
- ((eq? type (notification-type mastodon))
- (notification-mastodon notification*)))))))
+ (cond
+ ((email? notification)
+ (send-email* notification build))
+ ((mastodon? notification)
+ (send-mastodon build))))
notifications)))
diff --git a/src/cuirass/specification.scm b/src/cuirass/specification.scm
new file mode 100644
index 0000000..79565bf
--- /dev/null
+++ b/src/cuirass/specification.scm
@@ -0,0 +1,153 @@
+;;; specification.scm -- Specification definition.
+;;; Copyright © 2021 Mathieu Othacehe <othacehe@gnu.org>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (cuirass specification)
+ #:use-module (guix channels)
+ #:use-module (guix records)
+ #:use-module (guix ui)
+ #:use-module (guix utils)
+ #:use-module (ice-9 match)
+ #:export (build-output
+ build-output?
+ build-output-job
+ build-output-type
+ build-output-output
+ build-output-path
+
+ build-output->sexp
+ sexp->build-output
+
+ channel->sexp
+
+ specification
+ specification?
+ specification-name
+ specification-build
+ specification-channels
+ specification-priority
+ specification-build-outputs
+ specification-notifications
+ specification-systems
+
+ specification->sexp
+ sexp->specification
+ read-specifications))
+
+
+;;;
+;;; Build output record.
+;;;
+
+(define-record-type* <build-output>
+ build-output make-build-output
+ build-output?
+ (job build-output-job) ;string
+ (type build-output-type) ;string
+ (output build-output-output) ;string
+ (path build-output-path)) ;string
+
+(define (build-output->sexp build-output)
+ "Return an sexp describing BUILD-OUTPUT."
+ `(build-output
+ (job ,(build-output-job build-output))
+ (type ,(build-output-type build-output))
+ (output ,(build-output-output build-output))
+ (path ,(build-output-path build-output))))
+
+(define (sexp->build-output sexp)
+ "Return the build-output corresponding to SEXP."
+ (match sexp
+ (('build-output ('job job)
+ ('type type)
+ ('output output)
+ ('path path))
+ (build-output
+ (job job)
+ (type type)
+ (output output)
+ (path path)))))
+
+
+;;;
+;;; Channels.
+;;;
+
+(define (channel->sexp channel)
+ "Return an sexp describing CHANNEL."
+ `(repository
+ (version 0)
+ (url ,(channel-url channel))
+ (branch ,(channel-branch channel))
+ (commit ,(channel-commit channel))
+ (name ,(channel-name channel))))
+
+
+;;;
+;;; Specification record.
+;;;
+
+(define-record-type* <specification>
+ specification make-specification
+ specification?
+ (name specification-name) ;symbol
+ (build specification-build ;symbol
+ (default 'all))
+ (channels specification-channels ;list of <channel>
+ (default (list %default-guix-channel)))
+ (build-outputs specification-build-outputs ;list of <build-output>
+ (default '()))
+ (notifications specification-notifications
+ (default '()))
+ (priority specification-priority ;integer
+ (default 9))
+ (systems specification-systems ;list of strings
+ (default (list (%current-system)))))
+
+(define (specification->sexp spec)
+ "Return an sexp describing SPEC."
+ `(specification (name ,(specification-name spec))
+ (build ,(specification-build spec))
+ (channels ,(specification-channels spec))
+ (build-outputs ,(specification-build-outputs spec))
+ (notifications ,(specification-notifications spec))
+ (priority ,(specification-priority spec))
+ (systems ,(specification-systems spec))))
+
+(define (sexp->specification sexp)
+ "Return the specification corresponding to SEXP."
+ (match sexp
+ (('specification ('name name)
+ ('build build)
+ ('channels channels)
+ ('build-outputs build-outputs)
+ ('notifications notifications)
+ ('priority priority)
+ ('systems systems))
+ (specification (name name)
+ (build build)
+ (channels channels)
+ (build-outputs build-outputs)
+ (notifications notifications)
+ (priority priority)
+ (systems systems)))))
+
+(define (read-specifications file)
+ (let ((modules (make-user-module '((guix channels)
+ (cuirass notification)
+ (cuirass specification)))))
+ (load* file modules)))
diff --git a/src/cuirass/templates.scm b/src/cuirass/templates.scm
index 1e3abbd..a6cef8f 100644
--- a/src/cuirass/templates.scm
+++ b/src/cuirass/templates.scm
@@ -28,6 +28,7 @@
#:use-module (srfi srfi-26)
#:use-module (json)
#:use-module (web uri)
+ #:use-module (guix channels)
#:use-module (guix derivations)
#:use-module (guix progress)
#:use-module (guix store)
@@ -37,6 +38,7 @@
build-weather
evaluation-status))
#:use-module (cuirass remote)
+ #:use-module (cuirass specification)
#:export (html-page
specifications-table
evaluation-info-table
@@ -162,27 +164,45 @@ system whose names start with " (code "guile-") ":" (br)
(define (status-class status)
(cond
- ((= (build-status submitted) status) "oi oi-clock
text-warning")
- ((= (build-status scheduled) status) "oi oi-clock
text-warning")
- ((= (build-status started) status) "oi oi-reload
text-warning")
- ((= (build-status succeeded) status) "oi oi-check
text-success")
- ((= (build-status failed) status) "oi oi-x
text-danger")
- ((= (build-status failed-dependency) status) "oi oi-warning
text-danger")
- ((= (build-status failed-other) status) "oi oi-warning
text-danger")
- ((= (build-status canceled) status) "oi oi-question-mark
text-warning")
- (else "oi oi-warning
text-danger")))
+ ((= (build-status submitted) status)
+ "oi oi-clock text-warning")
+ ((= (build-status scheduled) status)
+ "oi oi-clock text-warning")
+ ((= (build-status started) status)
+ "oi oi-reload text-warning")
+ ((= (build-status succeeded) status)
+ "oi oi-check text-success")
+ ((= (build-status failed) status)
+ "oi oi-x text-danger")
+ ((= (build-status failed-dependency) status)
+ "oi oi-warning text-danger")
+ ((= (build-status failed-other) status)
+ "oi oi-warning text-danger")
+ ((= (build-status canceled) status)
+ "oi oi-question-mark text-warning")
+ (else
+ "oi oi-warning text-danger")))
(define (status-title status)
(cond
- ((= (build-status submitted) status) "Submitted")
- ((= (build-status scheduled) status) "Scheduled")
- ((= (build-status started) status) "Started")
- ((= (build-status succeeded) status) "Succeeded")
- ((= (build-status failed) status) "Failed")
- ((= (build-status failed-dependency) status) "Failed (dependency)")
- ((= (build-status failed-other) status) "Failed (other)")
- ((= (build-status canceled) status) "Canceled")
- (else "Invalid status")))
+ ((= (build-status submitted) status)
+ "Submitted")
+ ((= (build-status scheduled) status)
+ "Scheduled")
+ ((= (build-status started) status)
+ "Started")
+ ((= (build-status succeeded) status)
+ "Succeeded")
+ ((= (build-status failed) status)
+ "Failed")
+ ((= (build-status failed-dependency) status)
+ "Failed (dependency)")
+ ((= (build-status failed-other) status)
+ "Failed (other)")
+ ((= (build-status canceled) status)
+ "Canceled")
+ (else
+ "Invalid status")))
(define* (specifications-table specs #:optional admin?)
"Return HTML for the SPECS table."
@@ -199,37 +219,42 @@ system whose names start with " (code "guile-") ":" (br)
,@(if (null? specs)
`((th (@ (scope "col")) "No elements here."))
`((thead (tr (th (@ (scope "col")) Name)
- (th (@ (scope "col")) Inputs)
+ (th (@ (scope "col")) Channels)
,@(if admin?
'((th (@ (scope "col")) Action))
'())))
(tbody
,@(map
(lambda (spec)
- `(tr (td (a (@ (href "/jobset/" ,(assq-ref spec #:name)))
- ,(assq-ref spec #:name)))
+ `(tr (td (a (@ (href "/jobset/"
+ ,(specification-name spec)))
+ ,(specification-name spec)))
(td ,(string-join
- (map (lambda (input)
+ (map (lambda (channel)
(format #f "~a (on ~a)"
- (assq-ref input #:name)
- (assq-ref input #:branch)))
- (assq-ref spec #:inputs)) ", "))
+ (channel-name channel)
+ (channel-branch channel)))
+ (specification-channels spec)) ", "))
,@(if admin?
- `((form (@ (class "form")
- (action ,(string-append
"/admin/specifications/delete/"
- (assq-ref
spec #:name)))
- (method "POST")
- (onsubmit
- ,(string-append "return
confirm('Please confirm deletion of specification "
- (assq-ref spec
#:name)
- ".');")))
+ `((form
+ (@ (class "form")
+ (action
+ ,(string-append
+ "/admin/specifications/delete/"
+ (specification-name spec)))
+ (method "POST")
+ (onsubmit
+ ,(string-append
+ "return confirm('Please confirm
deletion of specification "
+ (specification-name spec) ".');")))
`((div
(@ (class "input-group"))
- (span (@ (class "input-group-append"))
- (button
- (@ (type "submit")
- (class "btn"))
- "Remove"))))))
+ (span
+ (@ (class "input-group-append"))
+ (button
+ (@ (type "submit")
+ (class "btn"))
+ "Remove"))))))
'())))
specs))))
,@(if admin?
@@ -437,7 +462,7 @@ system whose names start with " (code "guile-") ":" (br)
(let ((changes
(string-join
(map (lambda (checkout)
- (let ((input (assq-ref checkout #:input))
+ (let ((input (assq-ref checkout #:channel))
(commit (assq-ref checkout #:commit)))
(format #f "~a → ~a" input (substring commit 0 7))))
checkouts)
@@ -496,7 +521,7 @@ system whose names start with " (code "guile-") ":" (br)
`((thead
(tr
(th (@ (scope "col")) "#")
- (th (@ (scope "col")) "Input changes")
+ (th (@ (scope "col")) "Channel changes")
(th (@ (scope "col")) Success)
(th (@ (scope "col")) Action)))
(tbody
@@ -730,8 +755,8 @@ the nearest exact even integer."
(define* (evaluation-build-table evaluation
#:key
+ channels
(checkouts '())
- (inputs '())
status builds
builds-id-min builds-id-max)
"Return HTML for an evaluation page, containing a table of builds for that
@@ -759,20 +784,20 @@ evaluation."
(seconds->string duration))))))
(table (@ (class "table table-sm table-hover"))
(thead
- (tr (th (@ (class "border-0") (scope "col")) "Input")
+ (tr (th (@ (class "border-0") (scope "col")) "Channel")
(th (@ (class "border-0") (scope "col")) "Commit")))
(tbody
,@(map (lambda (checkout)
- (let* ((name (assq-ref checkout #:input))
- (input (find (lambda (input)
- (string=? (assq-ref input #:name)
- name))
- inputs))
- (url (assq-ref input #:url))
+ (let* ((name (assq-ref checkout #:channel))
+ (channel (find (lambda (channel)
+ (eq? (channel-name channel)
+ name))
+ channels))
+ (url (channel-url channel))
(commit (assq-ref checkout #:commit)))
;; Some checkout entries may refer to removed
;; inputs.
- (if input
+ (if channel
`(tr (td ,url)
(td (code ,(commit-hyperlink url commit))))
'())))
diff --git a/src/schema.sql b/src/schema.sql
index d4929e2..b0838d6 100644
--- a/src/schema.sql
+++ b/src/schema.sql
@@ -6,29 +6,12 @@ CREATE TABLE SchemaVersion (
CREATE TABLE Specifications (
name TEXT NOT NULL PRIMARY KEY,
- load_path_inputs TEXT NOT NULL, -- list of input names whose load path will
be in Guile's %load-path
- package_path_inputs TEXT NOT NULL, -- list of input names whose load paths
will be in GUIX_PACKAGE_PATH
- proc_input TEXT NOT NULL, -- name of the input containing the proc that
does the evaluation
- proc_file TEXT NOT NULL, -- file containing the procedure that does the
evaluation, relative to proc_input
- proc TEXT NOT NULL, -- defined in proc_file
- proc_args TEXT NOT NULL, -- passed to proc
- build_outputs TEXT NOT NULL, --specify what build outputs should be made
available for download
+ build TEXT NOT NULL,
+ channels TEXT NOT NULL,
+ build_outputs TEXT NOT NULL,
+ notifications TEXT NOT NULL,
priority INTEGER NOT NULL DEFAULT 0,
- notifications TEXT
-);
-
-CREATE TABLE Inputs (
- specification TEXT NOT NULL,
- name TEXT NOT NULL,
- url TEXT NOT NULL,
- load_path TEXT NOT NULL,
- -- The following columns are optional.
- branch TEXT,
- tag TEXT,
- revision TEXT,
- no_compile_p INTEGER,
- PRIMARY KEY (specification, name),
- FOREIGN KEY (specification) REFERENCES Specifications(name)
+ systems TEXT NOT NULL
);
CREATE TABLE Evaluations (
@@ -45,13 +28,12 @@ CREATE TABLE Checkouts (
specification TEXT NOT NULL,
revision TEXT NOT NULL,
evaluation INTEGER NOT NULL,
- input TEXT NOT NULL,
+ channel TEXT NOT NULL,
directory TEXT NOT NULL,
timestamp INTEGER NOT NULL,
PRIMARY KEY (specification, revision),
FOREIGN KEY (evaluation) REFERENCES Evaluations(id),
- FOREIGN KEY (specification) REFERENCES Specifications(name),
- FOREIGN KEY (specification, input) REFERENCES Inputs(specification, name)
+ FOREIGN KEY (specification) REFERENCES Specifications(name)
);
CREATE TABLE Builds (
@@ -135,6 +117,4 @@ CREATE INDEX Evaluations_specification_index ON Evaluations
(specification, id D
CREATE INDEX Outputs_derivation_index ON Outputs (derivation);
-CREATE INDEX Inputs_index ON Inputs(specification, name, branch);
-
COMMIT;
diff --git a/tests/database.scm b/tests/database.scm
index 03fdd65..a911bf5 100644
--- a/tests/database.scm
+++ b/tests/database.scm
@@ -24,7 +24,9 @@
(cuirass notification)
(cuirass parameters)
(cuirass remote)
+ (cuirass specification)
(cuirass utils)
+ (guix channels)
((guix utils) #:select (call-with-temporary-output-file))
(rnrs io ports)
(squee)
@@ -42,43 +44,40 @@
(false-if-exception (delete-file tmp-mail))
(define example-spec
- `((#:name . "guix")
- (#:load-path-inputs . ("savannah"))
- (#:package-path-inputs . ())
- (#:proc-input . "savannah")
- (#:proc-file . "/tmp/gnu-system.scm")
- (#:proc . hydra-jobs)
- (#:proc-args (subset . "hello"))
- (#:inputs . (((#:name . "maintenance")
- (#:url . "git://git.savannah.gnu.org/guix/maintenance.git")
- (#:load-path . ".")
- (#:branch . "master")
- (#:tag . #f)
- (#:commit . #f)
- (#:no-compile? . #f))
- ((#:name . "savannah")
- (#:url . "git://git.savannah.gnu.org/guix.git")
- (#:load-path . ".")
- (#:branch . "master")
- (#:tag . #f)
- (#:commit . #f)
- (#:no-compile? . #f))))
- (#:build-outputs . ())
- (#:notifications . (((#:name . "name")
- (#:type . ,(notification-type email))
- (#:from . "from")
- (#:to . "to")
- (#:server . ,(mailer))
- (#:event . 0))))
- (#:priority . 9)))
-
-(define (make-dummy-checkouts fakesha1 fakesha2)
- `(((#:commit . ,fakesha1)
- (#:input . "savannah")
- (#:directory . "foo"))
- ((#:commit . ,fakesha2)
- (#:input . "maintenance")
- (#:directory . "bar"))))
+ (specification
+ (name "guix")
+ (build 'hello)
+ (channels
+ (list (channel
+ (name 'guix)
+ (url "git://git.savannah.gnu.org/guix.git")
+ (branch "master"))
+ (channel
+ (name 'my-channel)
+ (url "git://my-git-channel.git")
+ (branch "master"))))
+ (build-outputs
+ (list (build-output
+ (job "job")
+ (type "type")
+ (output "out")
+ (path ""))))
+ (notifications
+ (list (email
+ (from "from")
+ (to "to")
+ (server (mailer)))))))
+
+(define (make-dummy-instances fakesha1 fakesha2)
+ (list
+ (checkout->channel-instance "foo"
+ #:name 'guix
+ #:url "git://git.savannah.gnu.org/guix.git"
+ #:commit fakesha1)
+ (checkout->channel-instance "bar"
+ #:name 'my-channel
+ #:url "git://my-git-channel.git"
+ #:commit fakesha2)))
(define* (make-dummy-build drv
#:optional (eval-id 2)
@@ -130,17 +129,21 @@ INSERT INTO Evaluations (specification, status,
timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0, 0);")
(exec-query (%db) "SELECT * FROM Evaluations;")))
- (test-equal "db-get-specification"
- example-spec
- (db-get-specification "guix"))
+ (test-assert "db-get-specification"
+ (let* ((spec (db-get-specification "guix"))
+ (channels (specification-channels spec))
+ (build-outputs (specification-build-outputs spec)))
+ (and (string=? (specification-name spec) "guix")
+ (equal? (map channel-name channels) '(guix my-channel))
+ (equal? (map build-output-job build-outputs) '("job")))))
(test-equal "db-add-evaluation"
'(2 3)
(list
(db-add-evaluation "guix"
- (make-dummy-checkouts "fakesha1" "fakesha2"))
+ (make-dummy-instances "fakesha1" "fakesha2"))
(db-add-evaluation "guix"
- (make-dummy-checkouts "fakesha3" "fakesha4"))))
+ (make-dummy-instances "fakesha3" "fakesha4"))))
(test-assert "db-set-evaluation-status"
(db-set-evaluation-status 2 (evaluation-status started)))
@@ -181,14 +184,14 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0,
0, 0);")
(test-assert "db-register-builds"
(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))))))
+ (db-register-build `((#: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"))))
(test-assert "db-update-build-status!"
@@ -251,9 +254,11 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0,
0, 0);")
'("/foo.drv")
(db-get-pending-derivations))
- (test-assert "db-get-checkouts"
- (equal? (db-get-checkouts 2)
- (make-dummy-checkouts "fakesha1" "fakesha2")))
+ (test-equal "db-get-checkouts"
+ '("fakesha1" "fakesha2")
+ (begin
+ (make-dummy-instances "fakesha1" "fakesha2")
+ (map (cut assq-ref <> #:commit) (db-get-checkouts 2))))
(test-equal "db-get-evaluation"
"guix"
@@ -476,7 +481,7 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0,
0);")
(list #f 1)
(begin
(db-add-evaluation "guix"
- (make-dummy-checkouts "fakesha5" "fakesha6"))
+ (make-dummy-instances "fakesha5" "fakesha6"))
(db-add-build (make-dummy-build "/old-build.drv" 3
#:job-name "job-1"
#:outputs `(("out" . "/old"))))
diff --git a/tests/http.scm b/tests/http.scm
index b814c4e..776b8db 100644
--- a/tests/http.scm
+++ b/tests/http.scm
@@ -1,7 +1,7 @@
;;; http.scm -- tests for (cuirass http) module
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2017, 2020, 2021 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;;
;;; This file is part of Cuirass.
@@ -21,7 +21,9 @@
(use-modules (cuirass http)
(cuirass database)
+ (cuirass specification)
(cuirass utils)
+ (guix channels)
(json)
(fibers)
(squee)
@@ -81,7 +83,7 @@
(#:checkouttime . 0)
(#:evaltime . 0)
(#:checkouts . #(((#:commit . "fakesha2")
- (#:input . "savannah")
+ (#:channel . "guix")
(#:directory . "dir3")))))))
(test-group-with-cleanup "http"
@@ -151,44 +153,40 @@
(#:timestamp . 1501347493)
(#:starttime . 0)
(#:stoptime . 0)))
- (specification
- '((#:name . "guix")
- (#:load-path-inputs . ("savannah"))
- (#:package-path-inputs . ())
- (#:proc-input . "savannah")
- (#:proc-file . "/tmp/gnu-system.scm")
- (#:proc . hydra-jobs)
- (#:proc-args (subset . "hello"))
- (#:inputs . (((#:name . "savannah")
- (#:url . "git://git.savannah.gnu.org/guix.git")
- (#:load-path . ".")
- (#:branch . "master")
- (#:tag . #f)
- (#:commit . #f)
- (#:no-compile? . #f))
- ((#:name . "packages")
- (#:url . "git://git.savannah.gnu.org/guix.git")
- (#:load-path . ".")
- (#:branch . "master")
- (#:tag . #f)
- (#:commit . #f)
- (#:no-compile? . #f))))
- (#:build-outputs . ())))
+ (spec
+ (specification
+ (name "guix")
+ (build 'hello)
+ (channels
+ (list (channel
+ (name 'guix)
+ (url "https://gitlab.com/mothacehe/guix.git";)
+ (branch "master"))
+ (channel
+ (name 'packages)
+ (url "https://gitlab.com/mothacehe/guix.git";)
+ (branch "master"))))))
(checkouts1
- '(((#:commit . "fakesha1")
- (#:input . "savannah")
- (#:directory . "dir1"))
- ((#:commit . "fakesha3")
- (#:input . "packages")
- (#:directory . "dir2"))))
+ (list
+ (checkout->channel-instance "dir1"
+ #:name 'guix
+ #:url "url1"
+ #:commit "fakesha1")
+ (checkout->channel-instance "dir2"
+ #:name 'packages
+ #:url "url2"
+ #:commit "fakesha3")))
(checkouts2
- '(((#:commit . "fakesha2")
- (#:input . "savannah")
- (#:directory . "dir3"))
- ((#:commit . "fakesha3")
- (#:input . "packages")
- (#:directory . "dir4")))))
- (db-add-specification specification)
+ (list
+ (checkout->channel-instance "dir3"
+ #:name 'guix
+ #:url "dir3"
+ #:commit "fakesha2")
+ (checkout->channel-instance "dir4"
+ #:name 'packages
+ #:url "dir4"
+ #:commit "fakesha3"))))
+ (db-add-specification spec)
(db-add-evaluation "guix" checkouts1
#:timestamp 1501347493)
(db-add-evaluation "guix" checkouts2
@@ -202,8 +200,7 @@
(http-get-body (test-cuirass-uri "/specifications")))
json->scm)
(#(spec)
- (and (string=? (assoc-ref spec "name") "guix")
- (vector? (assoc-ref spec "package-path-inputs"))))))
+ (string=? (assoc-ref spec "name") "guix"))))
(test-assert "/build/1"
(lset= equal?
diff --git a/tests/metrics.scm b/tests/metrics.scm
index 7a1b0b4..e7ab5ff 100644
--- a/tests/metrics.scm
+++ b/tests/metrics.scm
@@ -47,10 +47,9 @@
(test-assert "exec-query"
(begin
(exec-query (%db) "\
-INSERT INTO Specifications (name, load_path_inputs, package_path_inputs,
-proc_input, proc_file, proc, proc_args, build_outputs, priority)
-VALUES ('guix', '()', '()', 'guix',' build-aux/cuirass/gnu-system.scm',
-'cuirass-jobs', '', '', 2);")
+INSERT INTO Specifications (name, build, channels, build_outputs,
+notifications, priority, systems)
+VALUES ('guix', 'hello', '()', '()', '()', 9, '()');")
(exec-query (%db) "\
INSERT INTO Evaluations (specification, status,
timestamp, checkouttime, evaltime) VALUES ('guix', -1, 1600174547, 0, 0);")