Package: guix-patches;
Reported by: Mathieu Othacehe <othacehe <at> gnu.org>
Date: Wed, 21 Apr 2021 12:17:01 UTC
Severity: normal
Tags: patch
To reply to this bug, email your comments to 47929 AT debbugs.gnu.org.
Toggle the display of automated, internal messages from the tracker.
View this report as an mbox folder, status mbox, maintainer mbox
guix-patches <at> gnu.org:bug#47929; Package guix-patches.
(Wed, 21 Apr 2021 12:17:01 GMT) Full text and rfc822 format available.Mathieu Othacehe <othacehe <at> gnu.org>:guix-patches <at> gnu.org.
(Wed, 21 Apr 2021 12:17:01 GMT) Full text and rfc822 format available.Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):
From: Mathieu Othacehe <othacehe <at> gnu.org> To: guix-patches <at> gnu.org Cc: Mathieu Othacehe <othacehe <at> gnu.org> Subject: [PATCH 0/5] Add manifest support to channel-with-substitutes-available Date: Wed, 21 Apr 2021 14:16:10 +0200
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
guix-patches <at> gnu.org:bug#47929; Package guix-patches.
(Wed, 21 Apr 2021 12:22:02 GMT) Full text and rfc822 format available.Message #8 received at 47929 <at> debbugs.gnu.org (full text, mbox):
From: Mathieu Othacehe <othacehe <at> gnu.org> To: 47929 <at> debbugs.gnu.org Cc: Mathieu Othacehe <othacehe <at> gnu.org> Subject: [PATCH 1/5] ci: Add manifest support to channel-with-substitutes-available. Date: Wed, 21 Apr 2021 14:21:04 +0200
* 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
guix-patches <at> gnu.org:bug#47929; Package guix-patches.
(Wed, 21 Apr 2021 12:22:02 GMT) Full text and rfc822 format available.Message #11 received at 47929 <at> debbugs.gnu.org (full text, mbox):
From: Mathieu Othacehe <othacehe <at> gnu.org> To: 47929 <at> debbugs.gnu.org Cc: Mathieu Othacehe <othacehe <at> gnu.org> Subject: [PATCH 2/5] scripts: pull: Load (gnu packages) module. Date: Wed, 21 Apr 2021 14:21:05 +0200
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
guix-patches <at> gnu.org:bug#47929; Package guix-patches.
(Wed, 21 Apr 2021 12:22:03 GMT) Full text and rfc822 format available.Message #14 received at 47929 <at> debbugs.gnu.org (full text, mbox):
From: Mathieu Othacehe <othacehe <at> gnu.org> To: 47929 <at> debbugs.gnu.org Cc: Mathieu Othacehe <othacehe <at> gnu.org> Subject: [PATCH 3/5] ci: Add dashboard procedures. Date: Wed, 21 Apr 2021 14:21:06 +0200
* 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
guix-patches <at> gnu.org:bug#47929; Package guix-patches.
(Wed, 21 Apr 2021 12:22:03 GMT) Full text and rfc822 format available.Message #17 received at 47929 <at> debbugs.gnu.org (full text, mbox):
From: Mathieu Othacehe <othacehe <at> gnu.org> To: 47929 <at> debbugs.gnu.org Cc: Mathieu Othacehe <othacehe <at> gnu.org> Subject: [PATCH 4/5] scripts: weather: Add packages dashboard support. Date: Wed, 21 Apr 2021 14:21:07 +0200
* 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))))))
+
;;;
;;; 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
guix-patches <at> gnu.org:bug#47929; Package guix-patches.
(Wed, 21 Apr 2021 12:22:03 GMT) Full text and rfc822 format available.Message #20 received at 47929 <at> debbugs.gnu.org (full text, mbox):
From: Mathieu Othacehe <othacehe <at> gnu.org> To: 47929 <at> debbugs.gnu.org Cc: Mathieu Othacehe <othacehe <at> gnu.org> Subject: [PATCH 5/5] ui: Disable hyperlink support inside screen. Date: Wed, 21 Apr 2021 14:21:08 +0200
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
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.