mirror of
https://codeberg.org/guix/guix.git
synced 2026-04-28 06:34:05 +00:00
Compare commits
7 Commits
wip-full-s
...
version-1.
| Author | SHA1 | Date | |
|---|---|---|---|
|
8d84a9ee71 | ||
|
|
c13ad2b889 | ||
|
|
7546a1d3c0 | ||
|
|
1b0bfb5df1 | ||
|
|
8603bcd582 | ||
|
|
f350df405f | ||
|
|
91bcb1d043 |
@@ -182,32 +182,6 @@ as well as images, OS examples, and translations."
|
||||
"-c" "EXTRA_HEAD=<meta name=\"viewport\" \
|
||||
content=\"width=device-width, initial-scale=1\" />"))
|
||||
|
||||
(define guile-lib/htmlprag-fixed
|
||||
;; Guile-Lib with a hotfix for (htmlprag).
|
||||
(package
|
||||
(inherit guile-lib)
|
||||
(arguments
|
||||
(substitute-keyword-arguments (package-arguments guile-lib)
|
||||
((#:phases phases '%standard-phases)
|
||||
`(modify-phases ,phases
|
||||
(add-before 'build 'fix-htmlprag
|
||||
(lambda _
|
||||
;; When parsing
|
||||
;; "<body><blockquote><p>foo</p>\n</blockquote></body>",
|
||||
;; 'html->shtml' would mistakenly close 'blockquote' right
|
||||
;; before <p>. This patch removes 'p' from the
|
||||
;; 'parent-constraints' alist to fix that.
|
||||
(substitute* "src/htmlprag.scm"
|
||||
(("^[[:blank:]]*\\(p[[:blank:]]+\\. \\(body td th\\)\\).*")
|
||||
""))
|
||||
#t))
|
||||
(add-before 'check 'skip-known-failure
|
||||
(lambda _
|
||||
;; XXX: The above change causes one test failure among
|
||||
;; the htmlprag tests.
|
||||
(setenv "XFAIL_TESTS" "htmlprag.scm")
|
||||
#t))))))))
|
||||
|
||||
(define (normalize-language-code language) ;XXX: deduplicate
|
||||
;; Normalize LANGUAGE. For instance, "zh_CN" becomes "zh-cn".
|
||||
(string-map (match-lambda
|
||||
@@ -224,7 +198,7 @@ key is an identifier and the associated value is the URL reference pointing to
|
||||
that identifier. The URL is constructed by concatenating BASE-URL to the
|
||||
actual file name."
|
||||
(define build
|
||||
(with-extensions (list guile-lib/htmlprag-fixed)
|
||||
(with-extensions (list guile-lib)
|
||||
(with-imported-modules '((guix build utils))
|
||||
#~(begin
|
||||
(use-modules (guix build utils)
|
||||
@@ -236,6 +210,8 @@ actual file name."
|
||||
(ice-9 threads)
|
||||
(ice-9 pretty-print))
|
||||
|
||||
(%strict-tokenizer? #t)
|
||||
|
||||
(define file-url
|
||||
(let ((prefix (string-append #$manual "/")))
|
||||
(lambda (file)
|
||||
@@ -380,7 +356,7 @@ actual file name."
|
||||
to (1) add them a link to SYNTAX-CSS-URL, and (2) highlight the syntax of all
|
||||
its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')."
|
||||
(define build
|
||||
(with-extensions (list guile-lib/htmlprag-fixed guile-syntax-highlight)
|
||||
(with-extensions (list guile-lib guile-syntax-highlight)
|
||||
(with-imported-modules '((guix build utils))
|
||||
#~(begin
|
||||
(use-modules (htmlprag)
|
||||
@@ -394,6 +370,8 @@ its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')."
|
||||
(ice-9 threads)
|
||||
(ice-9 vlist))
|
||||
|
||||
(%strict-tokenizer? #t)
|
||||
|
||||
(define (pair-open/close lst)
|
||||
;; Pair 'open' and 'close' tags produced by 'highlights' and
|
||||
;; produce nested 'paren' tags instead.
|
||||
|
||||
@@ -2751,7 +2751,7 @@ the command prints and, similar to what we saw above, paste these two
|
||||
lines in your terminal and @file{.bash_profile}:
|
||||
|
||||
@example
|
||||
GUIX_PROFILE="$HOME/.config/guix/current/etc/profile"
|
||||
GUIX_PROFILE="$HOME/.config/guix/current"
|
||||
. "$GUIX_PROFILE/etc/profile"
|
||||
@end example
|
||||
|
||||
|
||||
561
gnu/ci.scm
561
gnu/ci.scm
@@ -3,6 +3,7 @@
|
||||
;;; Copyright © 2017, 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
||||
;;; Copyright © 2018, 2019 Clément Lassieur <clement@lassieur.org>
|
||||
;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu>
|
||||
;;; Copyright © 2020, 2021 Mathieu Othacehe <othacehe@gnu.org>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
@@ -20,7 +21,9 @@
|
||||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(define-module (gnu ci)
|
||||
#:use-module (guix channels)
|
||||
#:use-module (guix config)
|
||||
#:use-module (guix describe)
|
||||
#:use-module (guix store)
|
||||
#:use-module (guix grafts)
|
||||
#:use-module (guix profiles)
|
||||
@@ -34,7 +37,8 @@
|
||||
#:use-module (guix ui)
|
||||
#:use-module ((guix licenses)
|
||||
#:select (gpl3+ license? license-name))
|
||||
#:use-module ((guix utils) #:select (%current-system))
|
||||
#:use-module ((guix utils) #:select (%current-system
|
||||
location-file))
|
||||
#:use-module ((guix scripts system) #:select (read-operating-system))
|
||||
#:use-module ((guix scripts pack)
|
||||
#:select (lookup-compressor self-contained-tarball))
|
||||
@@ -61,67 +65,123 @@
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:use-module (ice-9 match)
|
||||
#:export (%cross-targets
|
||||
#:export (derivation->job
|
||||
image->job
|
||||
|
||||
%core-packages
|
||||
%cross-targets
|
||||
channel-source->package
|
||||
hydra-jobs))
|
||||
|
||||
arguments->systems
|
||||
cuirass-jobs))
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
;;; This file defines build jobs for the Hydra and Cuirass continuation
|
||||
;;; integration tools.
|
||||
;;; This file defines build jobs for Cuirass.
|
||||
;;;
|
||||
;;; Code:
|
||||
|
||||
(define* (package->alist store package system
|
||||
#:optional (package-derivation package-derivation))
|
||||
"Convert PACKAGE to an alist suitable for Hydra."
|
||||
(parameterize ((%graft? #f))
|
||||
(let ((drv (package-derivation store package system
|
||||
#:graft? #f)))
|
||||
`((derivation . ,(derivation-file-name drv))
|
||||
(log . ,(log-file store (derivation-file-name drv)))
|
||||
(outputs . ,(filter-map (lambda (res)
|
||||
(match res
|
||||
((name . path)
|
||||
`(,name . ,path))))
|
||||
(derivation->output-paths drv)))
|
||||
(nix-name . ,(derivation-name drv))
|
||||
(system . ,(derivation-system drv))
|
||||
(description . ,(package-synopsis package))
|
||||
(long-description . ,(package-description package))
|
||||
;; Backport from (guix channels) module.
|
||||
(define* (sexp->channel sexp #:optional (name 'channel))
|
||||
"Read SEXP, a provenance sexp as created by 'channel-instance->sexp'; use
|
||||
NAME as the channel name if SEXP does not specify it. Return #f if the sexp
|
||||
does not have the expected structure."
|
||||
(match sexp
|
||||
(('repository ('version 0)
|
||||
('url url)
|
||||
('branch branch)
|
||||
('commit commit)
|
||||
rest ...)
|
||||
;; Historically channel sexps did not include the channel name. It's OK
|
||||
;; for channels created by 'channel-instances->manifest' because the
|
||||
;; entry name is the channel name, but it was missing for entries created
|
||||
;; by 'manifest-entry-with-provenance'.
|
||||
(channel (name (match (assq 'name rest)
|
||||
(#f name)
|
||||
(('name name) name)))
|
||||
(url url)
|
||||
(branch branch)
|
||||
(commit commit)
|
||||
(introduction
|
||||
(match (assq 'introduction rest)
|
||||
(#f #f)
|
||||
(('introduction intro)
|
||||
(sexp->channel-introduction intro))))))
|
||||
|
||||
;; XXX: Hydra ignores licenses that are not a <license> structure or a
|
||||
;; list thereof.
|
||||
(license . ,(let loop ((license (package-license package)))
|
||||
(match license
|
||||
((? license?)
|
||||
(license-name license))
|
||||
((lst ...)
|
||||
(map loop license)))))
|
||||
(_ #f)))
|
||||
|
||||
(home-page . ,(package-home-page package))
|
||||
(maintainers . ("bug-guix@gnu.org"))
|
||||
(max-silent-time . ,(or (assoc-ref (package-properties package)
|
||||
'max-silent-time)
|
||||
3600)) ;1 hour by default
|
||||
(timeout . ,(or (assoc-ref (package-properties package) 'timeout)
|
||||
72000)))))) ;20 hours by default
|
||||
;; Backport from (guix describe) module.
|
||||
(define (package-channels package)
|
||||
"Return the list of channels providing PACKAGE or an empty list if it could
|
||||
not be determined."
|
||||
(match (and=> (package-location package) location-file)
|
||||
(#f '())
|
||||
(file
|
||||
(let ((file (if (string-prefix? "/" file)
|
||||
file
|
||||
(search-path %load-path file))))
|
||||
(if (and file
|
||||
(string-prefix? (%store-prefix) file))
|
||||
(filter-map
|
||||
(lambda (entry)
|
||||
(let ((item (manifest-entry-item entry)))
|
||||
(and (or (string-prefix? item file)
|
||||
(string=? "guix" (manifest-entry-name entry)))
|
||||
(manifest-entry-channel entry))))
|
||||
(current-profile-entries))
|
||||
'())))))
|
||||
|
||||
(define (package-job store job-name package system)
|
||||
(define* (derivation->job name drv
|
||||
#:key
|
||||
(max-silent-time 3600)
|
||||
(timeout 3600))
|
||||
"Return a Cuirass job called NAME and describing DRV.
|
||||
|
||||
MAX-SILENT-TIME and TIMEOUT are build options passed to the daemon when
|
||||
building the derivation."
|
||||
`((#:job-name . ,name)
|
||||
(#:derivation . ,(derivation-file-name drv))
|
||||
(#:inputs . ,(map (compose derivation-file-name
|
||||
derivation-input-derivation)
|
||||
(derivation-inputs drv)))
|
||||
(#:outputs . ,(filter-map
|
||||
(lambda (res)
|
||||
(match res
|
||||
((name . path)
|
||||
`(,name . ,path))))
|
||||
(derivation->output-paths drv)))
|
||||
(#:nix-name . ,(derivation-name drv))
|
||||
(#:system . ,(derivation-system drv))
|
||||
(#:max-silent-time . ,max-silent-time)
|
||||
(#:timeout . ,timeout)))
|
||||
|
||||
(define* (package-job store job-name package system
|
||||
#:key cross? target)
|
||||
"Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
|
||||
(let ((job-name (symbol-append job-name (string->symbol ".")
|
||||
(string->symbol system))))
|
||||
`(,job-name . ,(cut package->alist store package system))))
|
||||
(let ((job-name (string-append job-name "." system)))
|
||||
(parameterize ((%graft? #f))
|
||||
(let* ((drv (if cross?
|
||||
(package-cross-derivation store package target system
|
||||
#:graft? #f)
|
||||
(package-derivation store package system
|
||||
#:graft? #f)))
|
||||
(max-silent-time (or (assoc-ref (package-properties package)
|
||||
'max-silent-time)
|
||||
3600))
|
||||
(timeout (or (assoc-ref (package-properties package)
|
||||
'timeout)
|
||||
72000)))
|
||||
(derivation->job job-name drv
|
||||
#:max-silent-time max-silent-time
|
||||
#:timeout timeout)))))
|
||||
|
||||
(define (package-cross-job store job-name package target system)
|
||||
"Return a job called TARGET.JOB-NAME that cross-builds PACKAGE for TARGET on
|
||||
SYSTEM."
|
||||
`(,(symbol-append (string->symbol target) (string->symbol ".") job-name
|
||||
(string->symbol ".") (string->symbol system)) .
|
||||
,(cute package->alist store package system
|
||||
(lambda* (store package system #:key graft?)
|
||||
(package-cross-derivation store package target system
|
||||
#:graft? graft?)))))
|
||||
(let ((name (string-append target "." job-name "." system)))
|
||||
(package-job store name package system
|
||||
#:cross? #t
|
||||
#:target target)))
|
||||
|
||||
(define %core-packages
|
||||
;; Note: Don't put the '-final' package variants because (1) that's
|
||||
@@ -149,6 +209,7 @@ SYSTEM."
|
||||
"arm-linux-gnueabihf"
|
||||
"aarch64-linux-gnu"
|
||||
"powerpc-linux-gnu"
|
||||
"powerpc64le-linux-gnu"
|
||||
"riscv64-linux-gnu"
|
||||
"i586-pc-gnu" ;aka. GNU/Hurd
|
||||
"i686-w64-mingw32"
|
||||
@@ -197,6 +258,22 @@ SYSTEM."
|
||||
(remove (either from-32-to-64? same? pointless?)
|
||||
%cross-targets)))
|
||||
|
||||
(define* (guix-jobs store systems #:key source commit)
|
||||
"Return a list of jobs for Guix itself."
|
||||
(define build
|
||||
(primitive-load (string-append source "/build-aux/build-self.scm")))
|
||||
|
||||
(map
|
||||
(lambda (system)
|
||||
(let ((name (string->symbol
|
||||
(string-append "guix." system)))
|
||||
(drv (run-with-store store
|
||||
(build source #:version commit #:system system
|
||||
#:pull-version 1
|
||||
#:guile-version "2.2"))))
|
||||
(derivation->job name drv)))
|
||||
systems))
|
||||
|
||||
;; Architectures that are able to build or cross-build Guix System images.
|
||||
;; This does not mean that other architectures are not supported, only that
|
||||
;; they are often not fast enough to support Guix System images building.
|
||||
@@ -207,63 +284,51 @@ SYSTEM."
|
||||
(list hurd-barebones-qcow2-image
|
||||
pine64-barebones-raw-image))
|
||||
|
||||
(define (hours hours)
|
||||
(* 3600 hours))
|
||||
|
||||
(define* (image->job store image
|
||||
#:key name system)
|
||||
"Return the job for IMAGE on SYSTEM. If NAME is passed, use it as job name,
|
||||
otherwise use the IMAGE name."
|
||||
(let* ((image-name (or name
|
||||
(symbol->string (image-name image))))
|
||||
(name (string-append image-name "." system))
|
||||
(drv (run-with-store store
|
||||
(mbegin %store-monad
|
||||
(set-guile-for-build (default-guile))
|
||||
(lower-object (system-image image))))))
|
||||
(parameterize ((%graft? #f))
|
||||
(derivation->job name drv))))
|
||||
|
||||
(define (image-jobs store system)
|
||||
"Return a list of jobs that build images for SYSTEM."
|
||||
(define (->alist drv)
|
||||
`((derivation . ,(derivation-file-name drv))
|
||||
(log . ,(log-file store (derivation-file-name drv)))
|
||||
(outputs . ,(filter-map (lambda (res)
|
||||
(match res
|
||||
((name . path)
|
||||
`(,name . ,path))))
|
||||
(derivation->output-paths drv)))
|
||||
(nix-name . ,(derivation-name drv))
|
||||
(system . ,(derivation-system drv))
|
||||
(description . "Stand-alone image of the GNU system")
|
||||
(long-description . "This is a demo stand-alone image of the GNU
|
||||
system.")
|
||||
(license . ,(license-name gpl3+))
|
||||
(max-silent-time . 600)
|
||||
(timeout . 3600)
|
||||
(home-page . ,%guix-home-page-url)
|
||||
(maintainers . ("bug-guix@gnu.org"))))
|
||||
|
||||
(define (->job name drv)
|
||||
(let ((name (symbol-append name (string->symbol ".")
|
||||
(string->symbol system))))
|
||||
`(,name . ,(lambda ()
|
||||
(parameterize ((%graft? #f))
|
||||
(->alist drv))))))
|
||||
|
||||
(define (build-image image)
|
||||
(run-with-store store
|
||||
(mbegin %store-monad
|
||||
(set-guile-for-build (default-guile))
|
||||
(lower-object (system-image image)))))
|
||||
|
||||
(define MiB
|
||||
(expt 2 20))
|
||||
|
||||
(if (member system %guix-system-supported-systems)
|
||||
`(,(->job 'usb-image
|
||||
(build-image
|
||||
(image
|
||||
(inherit efi-disk-image)
|
||||
(operating-system installation-os))))
|
||||
,(->job 'iso9660-image
|
||||
(build-image
|
||||
(image
|
||||
(inherit (image-with-label
|
||||
iso9660-image
|
||||
(string-append "GUIX_" system "_"
|
||||
(if (> (string-length %guix-version) 7)
|
||||
(substring %guix-version 0 7)
|
||||
%guix-version))))
|
||||
(operating-system installation-os))))
|
||||
`(,(image->job store
|
||||
(image
|
||||
(inherit efi-disk-image)
|
||||
(operating-system installation-os))
|
||||
#:name "usb-image"
|
||||
#:system system)
|
||||
,(image->job
|
||||
store
|
||||
(image
|
||||
(inherit (image-with-label
|
||||
iso9660-image
|
||||
(string-append "GUIX_" system "_"
|
||||
(if (> (string-length %guix-version) 7)
|
||||
(substring %guix-version 0 7)
|
||||
%guix-version))))
|
||||
(operating-system installation-os))
|
||||
#:name "iso9660-image"
|
||||
#:system system)
|
||||
;; Only cross-compile Guix System images from x86_64-linux for now.
|
||||
,@(if (string=? system "x86_64-linux")
|
||||
(map (lambda (image)
|
||||
(->job (image-name image) (build-image image)))
|
||||
(map (cut image->job store <>
|
||||
#:system system)
|
||||
%guix-system-images)
|
||||
'()))
|
||||
'()))
|
||||
@@ -311,39 +376,17 @@ system.")
|
||||
(define* (system-test-jobs store system
|
||||
#:key source commit)
|
||||
"Return a list of jobs for the system tests."
|
||||
(define (test->thunk test)
|
||||
(lambda ()
|
||||
(define drv
|
||||
(run-with-store store
|
||||
(mbegin %store-monad
|
||||
(set-current-system system)
|
||||
(set-grafting #f)
|
||||
(set-guile-for-build (default-guile))
|
||||
(system-test-value test))))
|
||||
|
||||
`((derivation . ,(derivation-file-name drv))
|
||||
(log . ,(log-file store (derivation-file-name drv)))
|
||||
(outputs . ,(filter-map (lambda (res)
|
||||
(match res
|
||||
((name . path)
|
||||
`(,name . ,path))))
|
||||
(derivation->output-paths drv)))
|
||||
(nix-name . ,(derivation-name drv))
|
||||
(system . ,(derivation-system drv))
|
||||
(description . ,(format #f "Guix '~a' system test"
|
||||
(system-test-name test)))
|
||||
(long-description . ,(system-test-description test))
|
||||
(license . ,(license-name gpl3+))
|
||||
(max-silent-time . 600)
|
||||
(timeout . 3600)
|
||||
(home-page . ,%guix-home-page-url)
|
||||
(maintainers . ("bug-guix@gnu.org")))))
|
||||
|
||||
(define (->job test)
|
||||
(let ((name (string->symbol
|
||||
(string-append "test." (system-test-name test)
|
||||
"." system))))
|
||||
(cons name (test->thunk test))))
|
||||
(let ((name (string-append "test." (system-test-name test)
|
||||
"." system))
|
||||
(drv (run-with-store store
|
||||
(mbegin %store-monad
|
||||
(set-current-system system)
|
||||
(set-grafting #f)
|
||||
(set-guile-for-build (default-guile))
|
||||
(system-test-value test)))))
|
||||
|
||||
(derivation->job name drv)))
|
||||
|
||||
(if (member system %guix-system-supported-systems)
|
||||
;; Override the value of 'current-guix' used by system tests. Using a
|
||||
@@ -356,63 +399,45 @@ system.")
|
||||
'()))
|
||||
|
||||
(define (tarball-jobs store system)
|
||||
"Return Hydra jobs to build the self-contained Guix binary tarball."
|
||||
(define (->alist drv)
|
||||
`((derivation . ,(derivation-file-name drv))
|
||||
(log . ,(log-file store (derivation-file-name drv)))
|
||||
(outputs . ,(filter-map (lambda (res)
|
||||
(match res
|
||||
((name . path)
|
||||
`(,name . ,path))))
|
||||
(derivation->output-paths drv)))
|
||||
(nix-name . ,(derivation-name drv))
|
||||
(system . ,(derivation-system drv))
|
||||
(description . "Stand-alone binary Guix tarball")
|
||||
(long-description . "This is a tarball containing binaries of Guix and
|
||||
all its dependencies, and ready to be installed on \"foreign\" distributions.")
|
||||
(license . ,(license-name gpl3+))
|
||||
(home-page . ,%guix-home-page-url)
|
||||
(maintainers . ("bug-guix@gnu.org"))))
|
||||
|
||||
"Return jobs to build the self-contained Guix binary tarball."
|
||||
(define (->job name drv)
|
||||
(let ((name (symbol-append name (string->symbol ".")
|
||||
(string->symbol system))))
|
||||
`(,name . ,(lambda ()
|
||||
(parameterize ((%graft? #f))
|
||||
(->alist drv))))))
|
||||
(let ((name (string-append name "." system)))
|
||||
(parameterize ((%graft? #f))
|
||||
(derivation->job name drv))))
|
||||
|
||||
;; XXX: Add a job for the stable Guix?
|
||||
(list (->job 'binary-tarball
|
||||
(run-with-store store
|
||||
(mbegin %store-monad
|
||||
(set-guile-for-build (default-guile))
|
||||
(>>= (profile-derivation (packages->manifest (list guix)))
|
||||
(lambda (profile)
|
||||
(self-contained-tarball "guix-binary" profile
|
||||
#:localstatedir? #t
|
||||
#:compressor
|
||||
(lookup-compressor "xz")))))
|
||||
#:system system))))
|
||||
(list
|
||||
(->job "binary-tarball"
|
||||
(run-with-store store
|
||||
(mbegin %store-monad
|
||||
(set-guile-for-build (default-guile))
|
||||
(>>= (profile-derivation (packages->manifest (list guix)))
|
||||
(lambda (profile)
|
||||
(self-contained-tarball "guix-binary" profile
|
||||
#:profile-name "current-guix"
|
||||
#:localstatedir? #t
|
||||
#:compressor
|
||||
(lookup-compressor "xz")))))
|
||||
#:system system))))
|
||||
|
||||
(define job-name
|
||||
;; Return the name of a package's job.
|
||||
(compose string->symbol
|
||||
(cut package-full-name <> "-")))
|
||||
package-name)
|
||||
|
||||
(define package->job
|
||||
(let ((base-packages
|
||||
(delete-duplicates
|
||||
(append-map (match-lambda
|
||||
((_ package _ ...)
|
||||
(match (package-transitive-inputs package)
|
||||
(((_ inputs _ ...) ...)
|
||||
inputs))))
|
||||
((_ package _ ...)
|
||||
(match (package-transitive-inputs package)
|
||||
(((_ inputs _ ...) ...)
|
||||
inputs))))
|
||||
(%final-inputs)))))
|
||||
(lambda (store package system)
|
||||
"Return a job for PACKAGE on SYSTEM, or #f if this combination is not
|
||||
valid."
|
||||
(cond ((member package base-packages)
|
||||
(package-job store (symbol-append 'base. (job-name package))
|
||||
(package-job store (string-append "base." (job-name package))
|
||||
package system))
|
||||
((supported-package? package system)
|
||||
(let ((drv (package-derivation store package system
|
||||
@@ -446,14 +471,15 @@ valid."
|
||||
packages)))
|
||||
#:select? (const #t))) ;include hidden packages
|
||||
|
||||
(define (arguments->manifests arguments)
|
||||
(define (arguments->manifests arguments channels)
|
||||
"Return the list of manifests extracted from ARGUMENTS."
|
||||
(map (match-lambda
|
||||
((input-name . relative-path)
|
||||
(let* ((checkout (assq-ref arguments (string->symbol input-name)))
|
||||
(base (assq-ref checkout 'file-name)))
|
||||
(in-vicinity base relative-path))))
|
||||
(assq-ref arguments 'manifests)))
|
||||
(map (lambda (manifest)
|
||||
(any (lambda (checkout)
|
||||
(let ((path (in-vicinity checkout manifest)))
|
||||
(and (file-exists? path)
|
||||
path)))
|
||||
(map channel-url channels)))
|
||||
arguments))
|
||||
|
||||
(define (manifests->packages store manifests)
|
||||
"Return the list of packages found in MANIFESTS."
|
||||
@@ -469,100 +495,123 @@ valid."
|
||||
load-manifest)
|
||||
manifests))))
|
||||
|
||||
(define (find-current-checkout arguments)
|
||||
"Find the first checkout of ARGUMENTS that provided the current file.
|
||||
Return #f if no such checkout is found."
|
||||
(let ((current-root
|
||||
(canonicalize-path
|
||||
(string-append (dirname (current-filename)) "/.."))))
|
||||
(find (lambda (argument)
|
||||
(and=> (assq-ref argument 'file-name)
|
||||
(lambda (name)
|
||||
(string=? name current-root)))) arguments)))
|
||||
(define (arguments->systems arguments)
|
||||
"Return the systems list from ARGUMENTS."
|
||||
(match (assoc-ref arguments 'systems)
|
||||
(#f %cuirass-supported-systems)
|
||||
((lst ...) lst)
|
||||
((? string? str) (call-with-input-string str read))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Hydra entry point.
|
||||
;;; Cuirass entry point.
|
||||
;;;
|
||||
|
||||
(define (hydra-jobs store arguments)
|
||||
"Return Hydra jobs."
|
||||
(define (cuirass-jobs store arguments)
|
||||
"Register Cuirass jobs."
|
||||
(define subset
|
||||
(match (assoc-ref arguments 'subset)
|
||||
("core" 'core) ; only build core packages
|
||||
("hello" 'hello) ; only build hello
|
||||
(((? string?) (? string?) ...) 'list) ; only build selected list of packages
|
||||
("manifests" 'manifests) ; only build packages in the list of manifests
|
||||
(_ 'all))) ; build everything
|
||||
(assoc-ref arguments 'subset))
|
||||
|
||||
(define systems
|
||||
(match (assoc-ref arguments 'systems)
|
||||
(#f %hydra-supported-systems)
|
||||
((lst ...) lst)
|
||||
((? string? str) (call-with-input-string str read))))
|
||||
(arguments->systems arguments))
|
||||
|
||||
(define checkout
|
||||
(or (find-current-checkout arguments)
|
||||
(assq-ref arguments 'superior-guix-checkout)))
|
||||
(define channels
|
||||
(let ((channels (assq-ref arguments 'channels)))
|
||||
(map sexp->channel channels)))
|
||||
|
||||
(define guix
|
||||
(find guix-channel? channels))
|
||||
|
||||
(define commit
|
||||
(assq-ref checkout 'revision))
|
||||
(channel-commit guix))
|
||||
|
||||
(define source
|
||||
(assq-ref checkout 'file-name))
|
||||
(channel-url guix))
|
||||
|
||||
;; Turn off grafts. Grafting is meant to happen on the user's machines.
|
||||
(parameterize ((%graft? #f))
|
||||
;; Return one job for each package, except bootstrap packages.
|
||||
(append-map (lambda (system)
|
||||
(format (current-error-port)
|
||||
"evaluating for '~a' (heap size: ~a MiB)...~%"
|
||||
system
|
||||
(round
|
||||
(/ (assoc-ref (gc-stats) 'heap-size)
|
||||
(expt 2. 20))))
|
||||
(invalidate-derivation-caches!)
|
||||
(case subset
|
||||
((all)
|
||||
;; Build everything, including replacements.
|
||||
(let ((all (all-packages))
|
||||
(job (lambda (package)
|
||||
(package->job store package
|
||||
system))))
|
||||
(append (filter-map job all)
|
||||
(image-jobs store system)
|
||||
(system-test-jobs store system
|
||||
#:source source
|
||||
#:commit commit)
|
||||
(tarball-jobs store system)
|
||||
(cross-jobs store system))))
|
||||
((core)
|
||||
;; Build core packages only.
|
||||
(append (map (lambda (package)
|
||||
(package-job store (job-name package)
|
||||
package system))
|
||||
%core-packages)
|
||||
(cross-jobs store system)))
|
||||
((hello)
|
||||
;; Build hello package only.
|
||||
(let ((hello (specification->package "hello")))
|
||||
(list (package-job store (job-name hello) hello system))))
|
||||
((list)
|
||||
;; Build selected list of packages only.
|
||||
(let* ((names (assoc-ref arguments 'subset))
|
||||
(packages (map specification->package names)))
|
||||
(map (lambda (package)
|
||||
(package-job store (job-name package)
|
||||
package system))
|
||||
packages)))
|
||||
((manifests)
|
||||
;; Build packages in the list of manifests.
|
||||
(let* ((manifests (arguments->manifests arguments))
|
||||
(packages (manifests->packages store manifests)))
|
||||
(map (lambda (package)
|
||||
(package-job store (job-name package)
|
||||
package system))
|
||||
packages)))
|
||||
(else
|
||||
(error "unknown subset" subset))))
|
||||
systems)))
|
||||
(append-map
|
||||
(lambda (system)
|
||||
(format (current-error-port)
|
||||
"evaluating for '~a' (heap size: ~a MiB)...~%"
|
||||
system
|
||||
(round
|
||||
(/ (assoc-ref (gc-stats) 'heap-size)
|
||||
(expt 2. 20))))
|
||||
(invalidate-derivation-caches!)
|
||||
(match subset
|
||||
('all
|
||||
;; Build everything, including replacements.
|
||||
(let ((all (all-packages))
|
||||
(job (lambda (package)
|
||||
(package->job store package system))))
|
||||
(append
|
||||
(filter-map job all)
|
||||
(cross-jobs store system))))
|
||||
('core
|
||||
;; Build core packages only.
|
||||
(append
|
||||
(map (lambda (package)
|
||||
(package-job store (job-name package)
|
||||
package system))
|
||||
%core-packages)
|
||||
(cross-jobs store system)))
|
||||
('guix
|
||||
;; Build Guix modules only.
|
||||
(guix-jobs store systems
|
||||
#:source source
|
||||
#:commit commit))
|
||||
('hello
|
||||
;; Build hello package only.
|
||||
(let ((hello (specification->package "hello")))
|
||||
(list (package-job store (job-name hello)
|
||||
hello system))))
|
||||
('images
|
||||
;; Build Guix System images only.
|
||||
(image-jobs store system))
|
||||
('system-tests
|
||||
;; Build Guix System tests only.
|
||||
(system-test-jobs store system
|
||||
#:source source
|
||||
#:commit commit))
|
||||
('tarball
|
||||
;; Build Guix tarball only.
|
||||
(tarball-jobs store system))
|
||||
(('custom . modules)
|
||||
;; Build custom modules jobs only.
|
||||
(append-map
|
||||
(lambda (module)
|
||||
(let ((proc (module-ref
|
||||
(resolve-interface module)
|
||||
'cuirass-jobs)))
|
||||
(proc store arguments)))
|
||||
modules))
|
||||
(('channels . channels)
|
||||
;; Build only the packages from CHANNELS.
|
||||
(let ((all (all-packages)))
|
||||
(filter-map
|
||||
(lambda (package)
|
||||
(any (lambda (channel)
|
||||
(and (member (channel-name channel) channels)
|
||||
(package->job store package system)))
|
||||
(package-channels package)))
|
||||
all)))
|
||||
(('packages . rest)
|
||||
;; Build selected list of packages only.
|
||||
(let ((packages (map specification->package rest)))
|
||||
(map (lambda (package)
|
||||
(package-job store (job-name package)
|
||||
package system))
|
||||
packages)))
|
||||
(('manifests . rest)
|
||||
;; Build packages in the list of manifests.
|
||||
(let* ((manifests (arguments->manifests rest channels))
|
||||
(packages (manifests->packages store manifests)))
|
||||
(map (lambda (package)
|
||||
(package-job store (job-name package)
|
||||
package system))
|
||||
packages)))
|
||||
(else
|
||||
(error "unknown subset" subset))))
|
||||
systems)))
|
||||
|
||||
@@ -41,7 +41,7 @@ msgstr ""
|
||||
"Project-Id-Version: guix-manual 1.2.0-pre3\n"
|
||||
"Report-Msgid-Bugs-To: bug-guix@gnu.org\n"
|
||||
"POT-Creation-Date: 2020-11-05 17:27+0100\n"
|
||||
"PO-Revision-Date: 2020-11-20 14:37+0100\n"
|
||||
"PO-Revision-Date: 2020-11-24 17:52+0100\n"
|
||||
"Last-Translator: Julien Lepiller <julien@lepiller.eu>\n"
|
||||
"Language-Team: French <traduc@traduc.org>\n"
|
||||
"Language: fr\n"
|
||||
@@ -15988,7 +15988,7 @@ msgstr "{Procédure Scheme} copy-recursively @var{source} @var{destination} @"
|
||||
#: doc/guix.texi:8277
|
||||
msgid "[#:log (current-output-port)] [#:follow-symlinks? #f] [#:keep-mtime? #f] Copy @var{source} directory to @var{destination}. Follow symlinks if @var{follow-symlinks?} is true; otherwise, just preserve them. When @var{keep-mtime?} is true, keep the modification time of the files in @var{source} on those of @var{destination}. Write verbose output to the @var{log} port."
|
||||
msgstr ""
|
||||
"[#:log (current-output-port)] [#:follow-symlinks ? #f] [#:keep-mtime ? #f] \n"
|
||||
"[#:log (current-output-port)] [#:follow-symlinks? #f] [#:keep-mtime? #f] \n"
|
||||
"Copie le répertoire @var{source} dans @var{destination}. Suivez les liens symboliques si @var{follow-symlinks?} est vrai ; sinon, conservez-les. Lorsque @var{keep-mtime?} est vrai, conservez les heures de modification des fichiers dans @var{source} sur celles de @var{destination}. Écrivez une sortie verbeuse sur le port @var{log}."
|
||||
|
||||
#. type: deffn
|
||||
@@ -16091,7 +16091,7 @@ msgstr "{Procédure Scheme} find-files @var{dir} [@var{pred}] @"
|
||||
#: doc/guix.texi:8336
|
||||
msgid "[#:stat lstat] [#:directories? #f] [#:fail-on-error? #f] Return the lexicographically sorted list of files under @var{dir} for which @var{pred} returns true. @var{pred} is passed two arguments: the absolute file name, and its stat buffer; the default predicate always returns true. @var{pred} can also be a regular expression, in which case it is equivalent to @code{(file-name-predicate @var{pred})}. @var{stat} is used to obtain file information; using @code{lstat} means that symlinks are not followed. If @var{directories?} is true, then directories will also be included. If @var{fail-on-error?} is true, raise an exception upon error."
|
||||
msgstr ""
|
||||
"[#:stat lstat] [#:directories ? #f] [#:fail-on-error ? #f] \n"
|
||||
"[#:stat lstat] [#:directories? #f] [#:fail-on-error? #f] \n"
|
||||
"Renvoie la liste des fichiers triés lexicographiquement sous @var{dir} pour lesquels @var{pred} renvoie « vrai ». Deux arguments sont passés à @var{pred} : le nom absolu du fichier et son tampon stat ; le prédicat par défaut renvoie toujours « vrai ». @var{pred} peut également être une expression régulière, auquel cas elle est équivalente à @code{(file-name-predicate @var{pred})}. @var{stat} est utilisé pour obtenir des informations sur les fichiers ; l'utilisation de @code{lstat} signifie que les liens symboliques ne sont pas suivis. Si @var{directories?} est vrai, alors les répertoires seront également inclus. Si @var{fail-on-error?} est vrai, il lance une exception en cas d'erreur."
|
||||
|
||||
#. type: Plain text
|
||||
|
||||
Reference in New Issue
Block a user