[bug#47929] [PATCH 0/5] Add manifest support to channel-with-substitutes-available

[bug#47929] [PATCH 0/5] Add manifest support to channel-with-substitutes-available

[Mathieu Othacehe]

Hello,

This adds manifest support to channel-with-substitutes-available.  It also
allows to create CI dashboards from the guix weather command.

Thanks,

Mathieu

Mathieu Othacehe (5):
  ci: Add manifest support to channel-with-substitutes-available.
  scripts: pull: Load (gnu packages) module.
  ci: Add dashboard procedures.
  scripts: weather: Add packages dashboard support.
  ui: Disable hyperlink support inside screen.

 doc/guix.texi            |  31 +++++-
 guix/ci.scm              | 227 ++++++++++++++++++++++++++++++++++-----
 guix/scripts/pull.scm    |   3 +-
 guix/scripts/weather.scm |  32 ++++--
 guix/ui.scm              |   3 +-
 5 files changed, 256 insertions(+), 40 deletions(-)

-- 
2.31.1

[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

[bug#47929] [PATCH 2/5] scripts: pull: Load (gnu packages) module.

[Mathieu Othacehe]

This allows to pass a manifest to channel-with-substitutes-available this way:

(channel-with-substitutes-available
 %default-guix-channel
 "https://ci.guix.gnu.org"
 (specifications->manifest
  '("git" "emacs-minimal")))

* guix/scripts/pull.scm (channel-list): Load the (gnu packages) module when
evaluating the user channels list.
---
 guix/scripts/pull.scm | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 07613240a8..662239b492 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -707,7 +707,8 @@ transformations specified in OPTS (resulting from '--url', '--commit', or
     (string-append %sysconfdir "/guix/channels.scm"))
 
   (define (load-channels file)
-    (let ((result (load* file (make-user-module '((guix channels))))))
+    (let ((result (load* file (make-user-module '((guix channels)
+                                                  (gnu packages))))))
       (if (and (list? result) (every channel? result))
           result
           (leave (G_ "'~a' did not return a list of channels~%") file))))
-- 
2.31.1

[bug#47929] [PATCH 3/5] ci: Add dashboard procedures.

[Mathieu Othacehe]

* guix/ci.scm (dashboard-url, dashboard-register): New procedures.
---
 guix/ci.scm | 22 ++++++++++++++++++++++
 1 file changed, 22 insertions(+)

diff --git a/guix/ci.scm b/guix/ci.scm
index 780e90ef32..78ab739340 100644
--- a/guix/ci.scm
+++ b/guix/ci.scm
@@ -65,6 +65,8 @@
             evaluations-for-commit
 
             manifest->jobs
+            dashboard-url
+            dashboard-register
             channel-with-substitutes-available))
 
 ;;; Commentary:
@@ -282,6 +284,26 @@ evaluation with the higher successful jobs count."
            (package->job-name (package-name package)))
          packages)))
 
+(define (dashboard-url url id)
+  "Return the url of the dashboard with the given ID on the CI server at URL."
+  (format #f "~a/dashboard/~a" url id))
+
+(define* (dashboard-register url packages
+                             #:key
+                             (specification "master"))
+  "Register a dashboard for the packages jobs of the given SPECIFICATION using
+the CI server at URL.  Returns the newly created dashboard id or false if it
+could not be created."
+  (let* ((jobs (manifest->jobs
+                (packages->manifest packages)))
+         (names (string-join jobs ","))
+         (id (json->scm
+              (http-fetch
+               (format #f "~a/api/dashboard/register?spec=~a&names=~a"
+                       url specification names)))))
+    (and id
+         (assoc-ref id "id"))))
+
 (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
-- 
2.31.1

[bug#47929] [PATCH 4/5] scripts: weather: Add packages dashboard support.

[Mathieu Othacehe]

* guix/scripts/weather.scm (display-dashboard-url): New procedure.
(guix-weather): Call it.
---
 guix/scripts/weather.scm | 32 +++++++++++++++++++++++---------
 1 file changed, 23 insertions(+), 9 deletions(-)

diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm
index 5164fe0494..be0b2e3509 100644
--- a/guix/scripts/weather.scm
+++ b/guix/scripts/weather.scm
@@ -499,6 +499,17 @@ SERVER.  Display information for packages with at least THRESHOLD dependents."
              #f
              systems))))
 
+(define (display-dashboard-url server packages)
+  "Display a link to the dashboard for PACKAGES on the given CI SERVER."
+  (let* ((id (dashboard-register server packages))
+         (url (and id (dashboard-url server id))))
+    (when url
+      (format #t "~%")
+      (format #t (G_ "The packages dashboard is available ~a.~%")
+              (if (supports-hyperlinks?)
+                  (hyperlink url (G_ "here"))
+                  (format #f "here: ~a" url))))))
+
 \f
 ;;;
 ;;; Entry point.
@@ -554,15 +565,18 @@ SERVER.  Display information for packages with at least THRESHOLD dependents."
                      (report-server-coverage server items
                                              #:display-missing?
                                              (assoc-ref opts 'display-missing?)))
-                   (match (assoc-ref opts 'coverage)
-                     (#f #f)
-                     (threshold
-                      ;; PACKAGES may include non-package objects coming from a
-                      ;; manifest.  Filter them out.
-                      (report-package-coverage server
-                                               (filter package? packages)
-                                               systems
-                                               #:threshold threshold)))
+
+                   ;; PACKAGES may include non-package objects coming from a
+                   ;; manifest.  Filter them out.
+                   (let ((packages (filter package? packages)))
+                     (match (assoc-ref opts 'coverage)
+                       (#f #f)
+                       (threshold
+                        (report-package-coverage server
+                                                 packages
+                                                 systems
+                                                 #:threshold threshold)))
+                     (display-dashboard-url server packages))
 
                    (= 1 coverage))
                  urls))))))
-- 
2.31.1

[bug#47929] [PATCH 5/5] ui: Disable hyperlink support inside screen.

[Mathieu Othacehe]

Inside screen, the OSC escape sequence is interpreted but the link is not clickable.

* guix/ui.scm (supports-hyperlinks?): Return false if STY is set.
---
 guix/ui.scm | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/guix/ui.scm b/guix/ui.scm
index 7fbd4c63a2..56fbbb3db3 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -1486,7 +1486,8 @@ documented at
   ;; However, Emacs comint as of 26.3 does not ignore it and instead lets it
   ;; through, hence the 'INSIDE_EMACS' special case below.
   (and (isatty?* port)
-       (not (getenv "INSIDE_EMACS"))))
+       (not (or (getenv "INSIDE_EMACS")
+                (getenv "STY"))))) ;screen doesn't support hyperlinks.
 
 (define* (file-hyperlink file #:optional (text file))
   "Return TEXT with escapes for a hyperlink to FILE."
-- 
2.31.1