Toggle diff (296 lines)
diff --git a/doc/guix.texi b/doc/guix.texi
index b9019d5550..c39bbdb3d5 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -5201,11 +5201,32 @@ server at @url{https://ci.guix.gnu.org}.
"https://ci.guix.gnu.org"))
@end lisp
-Note that this does not mean that all the packages that you will
-install after running @command{guix pull} will have available
-substitutes. It only ensures that @command{guix pull} will not try to
-compile package definitions. This is particularly useful when using
-machines with limited resources.
+It is also possible to ask @command{guix pull} to use the latest commit
+with the maximal number of available substitutes for a given manifest
+this way:
+
+@lisp
+(use-modules (guix ci))
+
+(list (channel-with-substitutes-available
+ %default-guix-channel
+ "https://ci.guix.gnu.org"
+ "/path/to/manifest))
+@end lisp
+
+or this way:
+
+@lisp
+(use-modules (guix ci))
+
+(list (channel-with-substitutes-available
+ %default-guix-channel
+ "https://ci.guix.gnu.org"
+ (specifications->manifest
+ '("git" "emacs-minimal"))))
+@end lisp
+
+This is particularly useful when using machines with limited resources.
@node Creating a Channel
@section Creating a Channel
diff --git a/guix/ci.scm b/guix/ci.scm
index c70e5bb9e6..780e90ef32 100644
--- a/guix/ci.scm
+++ b/guix/ci.scm
@@ -18,10 +18,16 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix ci)
+ #:use-module (gnu packages)
+ #:use-module (guix channels)
#:use-module (guix http-client)
+ #:use-module (guix packages)
+ #:use-module (guix profiles)
+ #:use-module (guix ui)
#:use-module (guix utils)
#:use-module (json)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:use-module (guix i18n)
#:use-module (guix diagnostics)
@@ -58,6 +64,7 @@
latest-evaluations
evaluations-for-commit
+ manifest->jobs
channel-with-substitutes-available))
;;; Commentary:
@@ -67,6 +74,14 @@
;;;
;;; Code:
+;; The name of the CI specification building the 'guix-modular' package.
+(define %default-guix-specification
+ (make-parameter "guix"))
+
+;; The default name of the CI specification building all the packages.
+(define %default-package-specification
+ (make-parameter "master"))
+
(define-json-mapping <build-product> make-build-product
build-product?
json->build-product
@@ -109,6 +124,24 @@
(map json->checkout
(vector->list checkouts)))))
+(define-json-mapping <job> make-job job?
+ json->job
+ (name job-name) ;string
+ (build job-build) ;integer
+ (status job-status)) ;integer
+
+(define-json-mapping <history> make-history history?
+ json->history
+ (evaluation history-evaluation) ;integer
+ (checkouts history-checkouts "checkouts" ;<checkout>*
+ (lambda (checkouts)
+ (map json->checkout
+ (vector->list checkouts))))
+ (jobs history-jobs "jobs"
+ (lambda (jobs)
+ (map json->job
+ (vector->list jobs)))))
+
(define %query-limit
;; Max number of builds requested in queries.
1000)
@@ -172,34 +205,158 @@ as one of their inputs."
(evaluation-checkouts evaluation)))
(latest-evaluations url limit)))
-(define (find-latest-commit-with-substitutes url)
- "Return the latest commit with available substitutes for the Guix package
-definitions at URL. Return false if no commit were found."
- (let* ((job-name (string-append "guix." (%current-system)))
- (build (match (latest-builds url 1
- #:job job-name
- #:status 0) ;success
- ((build) build)
- (_ #f)))
- (evaluation (and build
- (evaluation url (build-evaluation build))))
- (commit (and evaluation
- (match (evaluation-checkouts evaluation)
- ((checkout)
- (checkout-commit checkout))))))
- commit))
-
-(define (channel-with-substitutes-available chan url)
+(define* (job url name #:key evaluation)
+ "Return the job which name is NAME for the given EVALUATION, from the CI
+server at URL."
+ (map json->job
+ (vector->list
+ (json->scm
+ (http-fetch
+ (format #f "~a/api/jobs?evaluation=~a&names=~a"
+ url evaluation name))))))
+
+(define* (jobs-history url jobs
+ #:key
+ (specification "master")
+ (limit 20))
+ "Return the job history for the SPECIFICATION jobs which names are part of
+the JOBS list, from the CI server at URL. Limit the history to the latest
+LIMIT evaluations. "
+ (let ((names (string-join jobs ",")))
+ (map json->history
+ (vector->list
+ (json->scm
+ (http-fetch
+ (format #f "~a/api/jobs/history?spec=~a&names=~a&nr=~a"
+ url specification names (number->string limit))))))))
+
+(define (sort-history-by-coverage history)
+ "Sort and return the given evaluation HISTORY list by descending successful
+jobs count. This means that the first element of the list will be the
+evaluation with the higher successful jobs count."
+ (let ((coverage
+ (map (cut fold
+ (lambda (status prev)
+ (if (eq? status 0) ;successful
+ (1+ prev)
+ prev))
+ 0 <>)
+ (map (compose
+ (cut map job-status <>) history-jobs)
+ history))))
+ (map (match-lambda
+ ((cov . hist) hist))
+ (sort (map cons coverage history)
+ (match-lambda*
+ (((c1 . h1) (c2 . h2))
+ (> c1 c2)))))))
+
+(define (channel-commit checkouts channel)
+ "Return the CHANNEL commit from CHECKOUTS."
+ (any (lambda (checkout)
+ (and (string=? (checkout-channel checkout) channel)
+ (checkout-commit checkout)))
+ checkouts))
+
+(define (package->job-name package)
+ "Return the CI job name for the given PACKAGE name."
+ (string-append package "." (%current-system)))
+
+(define (manifest->jobs manifest)
+ "Return the list of job names that are part of the given MANIFEST."
+ (define (load-manifest file)
+ (let ((user-module (make-user-module '((guix profiles) (gnu)))))
+ (load* file user-module)))
+
+ (let* ((manifest (cond
+ ((string? manifest)
+ (load-manifest manifest))
+ ((manifest? manifest)
+ manifest)
+ (else #f)))
+ (packages (delete-duplicates
+ (map manifest-entry-item
+ (manifest-transitive-entries manifest))
+ eq?)))
+ (map (lambda (package)
+ (package->job-name (package-name package)))
+ packages)))
+
+(define* (latest-checkouts-with-substitutes url jobs)
+ "Return a list of latest checkouts, sorted by descending substitutes
+coverage of the given JOBS list on the CI server at URL. Only evaluations for
+which the Guix package is built are considered.
+
+If JOBS is false, return a list of latest checkouts for which the Guix package
+is built. Return false if no checkouts were found."
+ (define guix-history
+ (filter (lambda (hist)
+ (let ((jobs (history-jobs hist)))
+ (match jobs
+ ((job)
+ (eq? (job-status job) 0))
+ (else #f))))
+ (jobs-history url (list (package->job-name "guix"))
+ #:specification
+ (%default-guix-specification))))
+
+ (define (guix-commit checkouts)
+ (let ((name (symbol->string
+ (channel-name %default-guix-channel))))
+ (channel-commit checkouts name)))
+
+ (define (guix-package-available? hist)
+ (any (lambda (guix-hist)
+ (string=? (guix-commit
+ (history-checkouts hist))
+ (guix-commit
+ (history-checkouts guix-hist)))
+ hist)
+ guix-history))
+
+ (define (first-checkout checkouts)
+ (match checkouts
+ ((checkouts _ ...)
+ checkouts)
+ (() #f)))
+
+ (if jobs
+ (let* ((jobs-history
+ (sort-history-by-coverage
+ (jobs-history url jobs
+ #:specification
+ (%default-package-specification))))
+ (checkouts
+ (map history-checkouts
+ (filter-map guix-package-available?
+ jobs-history))))
+ (first-checkout checkouts))
+ (first-checkout
+ (map history-checkouts guix-history))))
+
+(define* (channel-with-substitutes-available chan url
+ #:optional manifest)
"Return a channel inheriting from CHAN but which commit field is set to the
latest commit with available substitutes for the Guix package definitions at
-URL. The current system is taken into account.
+URL. If the MANIFEST argument is passed, return the latest commit with the
+maximal substitutes coverage of MANIFEST. MANIFEST can be an absolute path as
+a string, or a <manifest> record. The current system is taken into account.
If no commit with available substitutes were found, the commit field is set to
false and a warning message is printed."
- (let ((commit (find-latest-commit-with-substitutes url)))
- (unless commit
+ (let* ((jobs (and manifest
+ (manifest->jobs manifest)))
+ (checkouts
+ (latest-checkouts-with-substitutes url jobs)))
+ (unless checkouts
(warning (G_ "could not find available substitutes at ~a~%")
url))
- (channel
- (inherit chan)
- (commit commit))))
+ (let* ((name (channel-name chan))
+ (name-str (if (symbol? name)
+ (symbol->string name)
+ name))
+ (commit (and checkouts
+ (channel-commit checkouts name-str))))
+ (channel
+ (inherit chan)
+ (commit commit)))))
--
2.31.1
