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

  • Open
  • quality assurance status badge
Details
One participant
  • Mathieu Othacehe
Owner
unassigned
Submitted by
Mathieu Othacehe
Severity
normal
M
M
Mathieu Othacehe wrote on 21 Apr 2021 14:16
(address . guix-patches@gnu.org)(name . Mathieu Othacehe)(address . othacehe@gnu.org)
20210421121610.2045-1-othacehe@gnu.org
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
M
M
Mathieu Othacehe wrote on 21 Apr 2021 14:21
[PATCH 1/5] ci: Add manifest support to channel-with-substitutes-available.
(address . 47929@debbugs.gnu.org)(name . Mathieu Othacehe)(address . othacehe@gnu.org)
20210421122108.2344-1-othacehe@gnu.org
* 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(-)

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
M
M
Mathieu Othacehe wrote on 21 Apr 2021 14:21
[PATCH 2/5] scripts: pull: Load (gnu packages) module.
(address . 47929@debbugs.gnu.org)(name . Mathieu Othacehe)(address . othacehe@gnu.org)
20210421122108.2344-2-othacehe@gnu.org
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(-)

Toggle diff (16 lines)
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
M
M
Mathieu Othacehe wrote on 21 Apr 2021 14:21
[PATCH 3/5] ci: Add dashboard procedures.
(address . 47929@debbugs.gnu.org)(name . Mathieu Othacehe)(address . othacehe@gnu.org)
20210421122108.2344-3-othacehe@gnu.org
* guix/ci.scm (dashboard-url, dashboard-register): New procedures.
---
guix/ci.scm | 22 ++++++++++++++++++++++
1 file changed, 22 insertions(+)

Toggle diff (42 lines)
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
M
M
Mathieu Othacehe wrote on 21 Apr 2021 14:21
[PATCH 4/5] scripts: weather: Add packages dashboard support.
(address . 47929@debbugs.gnu.org)(name . Mathieu Othacehe)(address . othacehe@gnu.org)
20210421122108.2344-4-othacehe@gnu.org
* 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(-)

Toggle diff (52 lines)
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))))))
+
;;;
;;; 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
M
M
Mathieu Othacehe wrote on 21 Apr 2021 14:21
[PATCH 5/5] ui: Disable hyperlink support inside screen.
(address . 47929@debbugs.gnu.org)(name . Mathieu Othacehe)(address . othacehe@gnu.org)
20210421122108.2344-5-othacehe@gnu.org
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(-)

Toggle diff (16 lines)
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
?