[bug#47929] [PATCH 1/5] ci: Add manifest support to channel-with-substitutes-available.

[Mathieu Othacehe]

* guix/ci.scm (%default-guix-specification,
%default-package-specification): New variables.
(<job>, <history>): New records.
(job, job-history, sort-history-by-coverage, channel-commit,
package->job-name, manifest->jobs): New procedures.
(find-latest-commit-with-substitutes): Rename it into ...
(latest-checkouts-with-substitutes): ... this new procedure.
(channel-with-substitutes-available): Add an optional manifest argument and
honor it.
* doc/guix.texi (Channels with Substitutes): Update it.
---
 doc/guix.texi |  31 ++++++--
 guix/ci.scm   | 205 ++++++++++++++++++++++++++++++++++++++++++++------
 2 files changed, 207 insertions(+), 29 deletions(-)

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