From c4c2449fea9b7fd78f61ffb9bbe19ab2ef6c8b41 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 26 Jul 2019 10:59:24 +0200 Subject: git: 'update-cached-checkout' supports a 'tag-or-commit' type of ref. * guix/git.scm (switch-to-ref)[obj]: Wrap in 'resolve' lambda. Add 'tag-or-commit' case. (update-cached-checkout): Document it. --- guix/git.scm | 61 +++++++++++++++++++++++++++++++++++------------------------- 1 file changed, 36 insertions(+), 25 deletions(-) (limited to 'guix') diff --git a/guix/git.scm b/guix/git.scm index 289537dedf..fb2df2de07 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -139,29 +139,40 @@ of SHA1 string." "Switch to REPOSITORY's branch, commit or tag specified by REF. Return the OID (roughly the commit hash) corresponding to REF." (define obj - (match ref - (('branch . branch) - (let ((oid (reference-target - (branch-lookup repository branch BRANCH-REMOTE)))) - (object-lookup repository oid))) - (('commit . commit) - (let ((len (string-length commit))) - ;; 'object-lookup-prefix' appeared in Guile-Git in Mar. 2018, so we - ;; can't be sure it's available. Furthermore, 'string->oid' used to - ;; read out-of-bounds when passed a string shorter than 40 chars, - ;; which is why we delay calls to it below. - (if (< len 40) - (if (module-defined? (resolve-interface '(git object)) - 'object-lookup-prefix) - (object-lookup-prefix repository (string->oid commit) len) - (raise (condition - (&message - (message "long Git object ID is required"))))) - (object-lookup repository (string->oid commit))))) - (('tag . tag) - (let ((oid (reference-name->oid repository - (string-append "refs/tags/" tag)))) - (object-lookup repository oid))))) + (let resolve ((ref ref)) + (match ref + (('branch . branch) + (let ((oid (reference-target + (branch-lookup repository branch BRANCH-REMOTE)))) + (object-lookup repository oid))) + (('commit . commit) + (let ((len (string-length commit))) + ;; 'object-lookup-prefix' appeared in Guile-Git in Mar. 2018, so we + ;; can't be sure it's available. Furthermore, 'string->oid' used to + ;; read out-of-bounds when passed a string shorter than 40 chars, + ;; which is why we delay calls to it below. + (if (< len 40) + (if (module-defined? (resolve-interface '(git object)) + 'object-lookup-prefix) + (object-lookup-prefix repository (string->oid commit) len) + (raise (condition + (&message + (message "long Git object ID is required"))))) + (object-lookup repository (string->oid commit))))) + (('tag-or-commit . str) + (if (or (> (string-length str) 40) + (not (string-every char-set:hex-digit str))) + (resolve `(tag . ,str)) ;definitely a tag + (catch 'git-error + (lambda () + (resolve `(tag . ,str))) + (lambda _ + ;; There's no such tag, so it must be a commit ID. + (resolve `(commit . ,str)))))) + (('tag . tag) + (let ((oid (reference-name->oid repository + (string-append "refs/tags/" tag)))) + (object-lookup repository oid)))))) (reset repository obj RESET_HARD) (object-id obj)) @@ -218,8 +229,8 @@ please upgrade Guile-Git.~%")))) values: the cache directory name, and the SHA1 commit (a string) corresponding to REF. -REF is pair whose key is [branch | commit | tag] and value the associated -data, respectively [ | | ]. +REF is pair whose key is [branch | commit | tag | tag-or-commit ] and value +the associated data: [ | | | ]. When RECURSIVE? is true, check out submodules as well, if any." (define canonical-ref -- cgit v1.2.3 From 177fecb57c0c9e15249bf6a49244c9dc6eb8439c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 26 Jul 2019 11:09:56 +0200 Subject: git: allows tags in its 'commit' field. Fixes . Reported by Tobias Geerinckx-Rice . * guix/git.scm (git-checkout-compiler): Pass 'tag-or-commit' to 'latest-repository-commit*'. * doc/guix.texi (Package Transformation Options): Update '--with-commit' documentation accordingly. * tests/guix-build-branch.sh: Add test. --- doc/guix.texi | 2 +- guix/git.scm | 4 ++-- tests/guix-build-branch.sh | 8 +++++++- 3 files changed, 10 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index c2da4ce173..96448c24e5 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -8048,7 +8048,7 @@ guix build --with-branch=guile-sqlite3=master cuirass @item --with-commit=@var{package}=@var{commit} This is similar to @code{--with-branch}, except that it builds from @var{commit} rather than the tip of a branch. @var{commit} must be a valid -Git commit SHA1 identifier. +Git commit SHA1 identifier or a tag. @end table @node Additional Build Options diff --git a/guix/git.scm b/guix/git.scm index fb2df2de07..85252629fc 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -330,7 +330,7 @@ Log progress and checkout info to LOG-PORT." git-checkout? (url git-checkout-url) (branch git-checkout-branch (default "master")) - (commit git-checkout-commit (default #f)) + (commit git-checkout-commit (default #f)) ;#f | tag | commit (recursive? git-checkout-recursive? (default #f))) (define* (latest-repository-commit* url #:key ref recursive? log-port) @@ -369,7 +369,7 @@ Log progress and checkout info to LOG-PORT." (($ url branch commit recursive?) (latest-repository-commit* url #:ref (if commit - `(commit . ,commit) + `(tag-or-commit . ,commit) `(branch . ,branch)) #:recursive? recursive? #:log-port (current-error-port))))) diff --git a/tests/guix-build-branch.sh b/tests/guix-build-branch.sh index e64782c831..0cec7c75db 100644 --- a/tests/guix-build-branch.sh +++ b/tests/guix-build-branch.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2018 Ludovic Courtès +# Copyright © 2018, 2019 Ludovic Courtès # # This file is part of GNU Guix. # @@ -52,5 +52,11 @@ guix gc -R "$v0_1_0_drv" | grep guile-gcrypt-git.9e3eacd test "$v0_1_0_drv" != "$latest_drv" test "$v0_1_0_drv" != "$orig_drv" +v0_1_0_drv="`guix build guix --with-commit=guile-gcrypt=v0.1.0 -d`" +guix gc -R "$v0_1_0_drv" | grep guile-gcrypt-git.v0.1.0 +guix gc -R "$v0_1_0_drv" | grep guile-gcrypt-8fe64e8 # this is the *tag* ID +test "$v0_1_0_drv" != "$latest_drv" +test "$v0_1_0_drv" != "$orig_drv" + if guix build guix --with-commit=guile-gcrypt=000 -d then false; else true; fi -- cgit v1.2.3 From 10a8c2bbc6754bddb0e5d668b3ecc9050efd820b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 26 Jul 2019 11:16:10 +0200 Subject: git: 'switch-to-ref' resolves tag targets. * guix/git.scm (switch-to-ref): In the 'tag' case, resolve the target of the tag. * tests/guix-build-branch.sh: Adjust test accordingly. --- guix/git.scm | 6 +++++- tests/guix-build-branch.sh | 2 +- 2 files changed, 6 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/git.scm b/guix/git.scm index 85252629fc..de98fed40c 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -172,7 +172,11 @@ OID (roughly the commit hash) corresponding to REF." (('tag . tag) (let ((oid (reference-name->oid repository (string-append "refs/tags/" tag)))) - (object-lookup repository oid)))))) + ;; Get the commit that the tag at OID refers to. This is not + ;; strictly needed, but it's more consistent to always return the + ;; OID of a commit. + (object-lookup repository + (tag-target-id (tag-lookup repository oid)))))))) (reset repository obj RESET_HARD) (object-id obj)) diff --git a/tests/guix-build-branch.sh b/tests/guix-build-branch.sh index 0cec7c75db..3d2a7dddf5 100644 --- a/tests/guix-build-branch.sh +++ b/tests/guix-build-branch.sh @@ -54,7 +54,7 @@ test "$v0_1_0_drv" != "$orig_drv" v0_1_0_drv="`guix build guix --with-commit=guile-gcrypt=v0.1.0 -d`" guix gc -R "$v0_1_0_drv" | grep guile-gcrypt-git.v0.1.0 -guix gc -R "$v0_1_0_drv" | grep guile-gcrypt-8fe64e8 # this is the *tag* ID +guix gc -R "$v0_1_0_drv" | grep guile-gcrypt-9e3eacd test "$v0_1_0_drv" != "$latest_drv" test "$v0_1_0_drv" != "$orig_drv" -- cgit v1.2.3 From 4d04bc50d2df32be326e0f48f378dc581f873989 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 26 Jul 2019 11:17:31 +0200 Subject: guix build: '--with-commit' recognizes "v[0-9]" tags. * guix/scripts/build.scm (transform-package-source-commit)[replace]: Special case COMMIT that starts with "v[0-9]". --- guix/scripts/build.scm | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index ec58ba871b..3ee0b737fe 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -341,10 +341,15 @@ strings like \"guile-next=cabba9e\" meaning that packages are built using (define (replace old url commit) (package (inherit old) - (version (string-append "git." - (if (< (string-length commit) 7) - commit - (string-take commit 7)))) + (version (if (and (> (string-length commit) 1) + (string-prefix? "v" commit) + (char-set-contains? char-set:digit + (string-ref commit 1))) + (string-drop commit 1) ;looks like a tag like "v1.0" + (string-append "git." + (if (< (string-length commit) 7) + commit + (string-take commit 7))))) (source (git-checkout (url url) (commit commit) (recursive? #t))))) -- cgit v1.2.3 From 5c793753b31b1dcd9a554bce953124f7ae88ca9a Mon Sep 17 00:00:00 2001 From: "Jakob L. Kreuze" Date: Wed, 24 Jul 2019 12:34:02 -0400 Subject: guix system: Add 'reconfigure' module. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/scripts/system/reconfigure.scm: New file. * Makefile.am (MODULES): Add it. * guix/scripts/system.scm (bootloader-installer-script): Export variable. * gnu/machine/ssh.scm (switch-to-system, upgrade-shepherd-services) (install-bootloader): Delete variable. * gnu/machine/ssh.scm (deploy-managed-host): Rewrite procedure. * gnu/services/herd.scm (live-service): Export variable. * gnu/services/herd.scm (live-service-canonical-name): New variable. * tests/services.scm (live-service): Delete variable. Signed-off-by: Ludovic Courtès --- Makefile.am | 1 + gnu/machine/ssh.scm | 189 ++-------------------------- gnu/services/herd.scm | 6 + guix/scripts/system/reconfigure.scm | 237 ++++++++++++++++++++++++++++++++++++ tests/services.scm | 4 - 5 files changed, 256 insertions(+), 181 deletions(-) create mode 100644 guix/scripts/system/reconfigure.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 7fa51d17ac..0bd85e8fcf 100644 --- a/Makefile.am +++ b/Makefile.am @@ -249,6 +249,7 @@ MODULES = \ guix/scripts/describe.scm \ guix/scripts/system.scm \ guix/scripts/system/search.scm \ + guix/scripts/system/reconfigure.scm \ guix/scripts/lint.scm \ guix/scripts/challenge.scm \ guix/scripts/import/crate.scm \ diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm index 278d43c10f..552eafa9de 100644 --- a/gnu/machine/ssh.scm +++ b/gnu/machine/ssh.scm @@ -17,23 +17,21 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu machine ssh) - #:use-module (gnu bootloader) #:use-module (gnu machine) #:autoload (gnu packages gnupg) (guile-gcrypt) - #:use-module (gnu services) - #:use-module (gnu services shepherd) #:use-module (gnu system) - #:use-module (guix derivations) #:use-module (guix gexp) #:use-module (guix i18n) #:use-module (guix modules) #:use-module (guix monads) #:use-module (guix records) #:use-module (guix remote) + #:use-module (guix scripts system reconfigure) #:use-module (guix ssh) #:use-module (guix store) #:use-module (ice-9 match) #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-35) #:export (managed-host-environment-type @@ -105,118 +103,6 @@ an environment type of 'managed-host." ;;; System deployment. ;;; -(define (switch-to-system machine) - "Monadic procedure creating a new generation on MACHINE and execute the -activation script for the new system configuration." - (define (remote-exp drv script) - (with-extensions (list guile-gcrypt) - (with-imported-modules (source-module-closure '((guix config) - (guix profiles) - (guix utils))) - #~(begin - (use-modules (guix config) - (guix profiles) - (guix utils)) - - (define %system-profile - (string-append %state-directory "/profiles/system")) - - (let* ((system #$drv) - (number (1+ (generation-number %system-profile))) - (generation (generation-file-name %system-profile number))) - (switch-symlinks generation system) - (switch-symlinks %system-profile generation) - ;; The implementation of 'guix system reconfigure' saves the - ;; load path and environment here. This is unnecessary here - ;; because each invocation of 'remote-eval' runs in a distinct - ;; Guile REPL. - (setenv "GUIX_NEW_SYSTEM" system) - ;; The activation script may write to stdout, which confuses - ;; 'remote-eval' when it attempts to read a result from the - ;; remote REPL. We work around this by forcing the output to a - ;; string. - (with-output-to-string - (lambda () - (primitive-load #$script)))))))) - - (let* ((os (machine-system machine)) - (script (operating-system-activation-script os))) - (mlet* %store-monad ((drv (operating-system-derivation os))) - (machine-remote-eval machine (remote-exp drv script))))) - -;; XXX: Currently, this does NOT attempt to restart running services. This is -;; also the case with 'guix system reconfigure'. -;; -;; See . -(define (upgrade-shepherd-services machine) - "Monadic procedure unloading and starting services on the remote as needed -to realize the MACHINE's system configuration." - (define target-services - ;; Monadic expression evaluating to a list of (name output-path) pairs for - ;; all of MACHINE's services. - (mapm %store-monad - (lambda (service) - (mlet %store-monad ((file ((compose lower-object - shepherd-service-file) - service))) - (return (list (shepherd-service-canonical-name service) - (derivation->output-path file))))) - (service-value - (fold-services (operating-system-services (machine-system machine)) - #:target-type shepherd-root-service-type)))) - - (define (remote-exp target-services) - (with-imported-modules '((gnu services herd)) - #~(begin - (use-modules (gnu services herd) - (srfi srfi-1)) - - (define running - (filter live-service-running (current-services))) - - (define (essential? service) - ;; Return #t if SERVICE is essential and should not be unloaded - ;; under any circumstance. - (memq (first (live-service-provision service)) - '(root shepherd))) - - (define (obsolete? service) - ;; Return #t if SERVICE can be safely unloaded. - (and (not (essential? service)) - (every (lambda (requirements) - (not (memq (first (live-service-provision service)) - requirements))) - (map live-service-requirement running)))) - - (define to-unload - (filter obsolete? - (remove (lambda (service) - (memq (first (live-service-provision service)) - (map first '#$target-services))) - running))) - - (define to-start - (remove (lambda (service-pair) - (memq (first service-pair) - (map (compose first live-service-provision) - running))) - '#$target-services)) - - ;; Unload obsolete services. - (for-each (lambda (service) - (false-if-exception - (unload-service service))) - to-unload) - - ;; Load the service files for any new services and start them. - (load-services/safe (map second to-start)) - (for-each start-service (map first to-start)) - - #t))) - - (mlet %store-monad ((target-services target-services)) - (machine-remote-eval machine (remote-exp target-services)))) - (define (machine-boot-parameters machine) "Monadic procedure returning a list of 'boot-parameters' for the generations of MACHINE's system profile, ordered from most recent to oldest." @@ -275,71 +161,20 @@ of MACHINE's system profile, ordered from most recent to oldest." (boot-parameters-kernel-arguments params)))))))) generations)))) -(define (install-bootloader machine) - "Create a bootloader entry for the new system generation on MACHINE, and -configure the bootloader to boot that generation by default." - (define bootloader-installer-script - (@@ (guix scripts system) bootloader-installer-script)) - - (define (remote-exp installer bootcfg bootcfg-file) - (with-extensions (list guile-gcrypt) - (with-imported-modules (source-module-closure '((gnu build install) - (guix store) - (guix utils))) - #~(begin - (use-modules (gnu build install) - (guix store) - (guix utils)) - (let* ((gc-root (string-append "/" %gc-roots-directory "/bootcfg")) - (temp-gc-root (string-append gc-root ".new"))) - - (switch-symlinks temp-gc-root gc-root) - - (unless (false-if-exception - (begin - ;; The implementation of 'guix system reconfigure' - ;; saves the load path here. This is unnecessary here - ;; because each invocation of 'remote-eval' runs in a - ;; distinct Guile REPL. - (install-boot-config #$bootcfg #$bootcfg-file "/") - ;; The installation script may write to stdout, which - ;; confuses 'remote-eval' when it attempts to read a - ;; result from the remote REPL. We work around this - ;; by forcing the output to a string. - (with-output-to-string - (lambda () - (primitive-load #$installer))))) - (delete-file temp-gc-root) - (error "failed to install bootloader")) - - (rename-file temp-gc-root gc-root) - #t))))) - - (mlet* %store-monad ((boot-parameters (machine-boot-parameters machine))) - (let* ((os (machine-system machine)) - (bootloader ((compose bootloader-configuration-bootloader - operating-system-bootloader) - os)) - (bootloader-target (bootloader-configuration-target - (operating-system-bootloader os))) - (installer (bootloader-installer-script - (bootloader-installer bootloader) - (bootloader-package bootloader) - bootloader-target - "/")) - (menu-entries (map boot-parameters->menu-entry boot-parameters)) - (bootcfg (operating-system-bootcfg os menu-entries)) - (bootcfg-file (bootloader-configuration-file bootloader))) - (machine-remote-eval machine (remote-exp installer bootcfg bootcfg-file))))) - (define (deploy-managed-host machine) "Internal implementation of 'deploy-machine' for MACHINE instances with an environment type of 'managed-host." (maybe-raise-unsupported-configuration-error machine) - (mbegin %store-monad - (switch-to-system machine) - (upgrade-shepherd-services machine) - (install-bootloader machine))) + (mlet %store-monad ((boot-parameters (machine-boot-parameters machine))) + (let* ((os (machine-system machine)) + (eval (cut machine-remote-eval machine <>)) + (menu-entries (map boot-parameters->menu-entry boot-parameters)) + (bootloader-configuration (operating-system-bootloader os)) + (bootcfg (operating-system-bootcfg os menu-entries))) + (mbegin %store-monad + (switch-to-system eval os) + (upgrade-shepherd-services eval os) + (install-bootloader eval bootloader-configuration bootcfg))))) ;;; diff --git a/gnu/services/herd.scm b/gnu/services/herd.scm index 0008746fe9..2207b2d34b 100644 --- a/gnu/services/herd.scm +++ b/gnu/services/herd.scm @@ -40,10 +40,12 @@ unknown-shepherd-error? unknown-shepherd-error-sexp + live-service live-service? live-service-provision live-service-requirement live-service-running + live-service-canonical-name with-shepherd-action current-services @@ -192,6 +194,10 @@ of pairs." (requirement live-service-requirement) ;list of symbols (running live-service-running)) ;#f | object +(define (live-service-canonical-name service) + "Return the 'canonical name' of SERVICE." + (first (live-service-provision service))) + (define (current-services) "Return the list of currently defined Shepherd services, represented as objects. Return #f if the list of services could not be diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm new file mode 100644 index 0000000000..8c7d461585 --- /dev/null +++ b/guix/scripts/system/reconfigure.scm @@ -0,0 +1,237 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès +;;; Copyright © 2016 Alex Kost +;;; Copyright © 2016, 2017, 2018 Chris Marusich +;;; Copyright © 2017 Mathieu Othacehe +;;; Copyright © 2018 Ricardo Wurmus +;;; Copyright © 2019 Christopher Baines +;;; Copyright © 2019 Jakob L. Kreuze +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix scripts system reconfigure) + #:autoload (gnu packages gnupg) (guile-gcrypt) + #:use-module (gnu bootloader) + #:use-module (gnu services) + #:use-module (gnu services herd) + #:use-module (gnu services shepherd) + #:use-module (gnu system) + #:use-module (guix gexp) + #:use-module (guix modules) + #:use-module (guix monads) + #:use-module (guix store) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:export (switch-system-program + switch-to-system + + upgrade-services-program + upgrade-shepherd-services + + install-bootloader-program + install-bootloader)) + +;;; Commentary: +;;; +;;; This module implements the "effectful" parts of system +;;; reconfiguration. Although building a system derivation is a pure +;;; operation, a number of impure operations must be carried out for the +;;; system configuration to be realized -- chiefly, creation of generation +;;; symlinks and invocation of activation scripts. +;;; +;;; Code: + + +;;; +;;; Profile creation. +;;; + +(define* (switch-system-program os #:optional profile) + "Return an executable store item that, upon being evaluated, will create a +new generation of PROFILE pointing to the directory of OS, switch to it +atomically, and run OS's activation script." + (program-file + "switch-to-system.scm" + (with-extensions (list guile-gcrypt) + (with-imported-modules (source-module-closure '((guix config) + (guix profiles) + (guix utils))) + #~(begin + (use-modules (guix config) + (guix profiles) + (guix utils)) + + (define profile + (or #$profile (string-append %state-directory "/profiles/system"))) + + (let* ((number (1+ (generation-number profile))) + (generation (generation-file-name profile number))) + (switch-symlinks generation #$os) + (switch-symlinks profile generation) + (setenv "GUIX_NEW_SYSTEM" #$os) + (primitive-load #$(operating-system-activation-script os)))))))) + +(define* (switch-to-system eval os #:optional profile) + "Using EVAL, a monadic procedure taking a single G-Expression as an argument, +create a new generation of PROFILE pointing to the directory of OS, switch to +it atomically, and run OS's activation script." + (eval #~(primitive-load #$(switch-system-program os profile)))) + + +;;; +;;; Services. +;;; + +(define (running-services eval) + "Using EVAL, a monadic procedure taking a single G-Expression as an argument, +return the objects that are currently running on MACHINE." + (define exp + (with-imported-modules '((gnu services herd)) + #~(begin + (use-modules (gnu services herd)) + (let ((services (current-services))) + (and services + ;; 'live-service-running' is ignored, as we can't necessarily + ;; serialize arbitrary objects. This should be fine for now, + ;; since 'machine-current-services' is not exposed publicly, + ;; and the resultant objects are only used for + ;; resolving service dependencies. + (map (lambda (service) + (list (live-service-provision service) + (live-service-requirement service))) + services)))))) + (mlet %store-monad ((services (eval exp))) + (return (map (match-lambda + ((provision requirement) + (live-service provision requirement #f))) + services)))) + +;; XXX: Currently, this does NOT attempt to restart running services. See +;; for details. +(define (upgrade-services-program service-files to-start to-unload to-restart) + "Return an executable store item that, upon being evaluated, will upgrade +the Shepherd (PID 1) by unloading obsolete services and loading new +services. SERVICE-FILES is a list of Shepherd service files to load, and +TO-START, TO-UNLOAD, and TO-RESTART are lists of the Shepherd services' +canonical names (symbols)." + (program-file + "upgrade-shepherd-services.scm" + (with-imported-modules '((gnu services herd)) + #~(begin + (use-modules (gnu services herd) + (srfi srfi-1)) + + ;; Load the service files for any new services. + (load-services/safe '#$service-files) + + ;; Unload obsolete services and start new services. + (for-each unload-service '#$to-unload) + (for-each start-service '#$to-start))))) + +(define* (upgrade-shepherd-services eval os) + "Using EVAL, a monadic procedure taking a single G-Expression as an argument, +upgrade the Shepherd (PID 1) by unloading obsolete services and loading new +services as defined by OS." + (define target-services + (service-value + (fold-services (operating-system-services os) + #:target-type shepherd-root-service-type))) + + (mlet* %store-monad ((live-services (running-services eval))) + (let*-values (((to-unload to-restart) + (shepherd-service-upgrade live-services target-services))) + (let* ((to-unload (map live-service-canonical-name to-unload)) + (to-restart (map shepherd-service-canonical-name to-restart)) + (to-start (lset-difference eqv? + (map shepherd-service-canonical-name + target-services) + (map live-service-canonical-name + live-services))) + (service-files + (map shepherd-service-file + (filter (lambda (service) + (memq (shepherd-service-canonical-name service) + to-start)) + target-services)))) + (eval #~(primitive-load #$(upgrade-services-program service-files + to-start + to-unload + to-restart))))))) + + +;;; +;;; Bootloader configuration. +;;; + +(define (install-bootloader-program installer bootloader-package bootcfg + bootcfg-file device target) + "Return an executable store item that, upon being evaluated, will install +BOOTCFG to BOOTCFG-FILE, a target file name, on DEVICE, a file system device, +at TARGET, a mount point, and subsequently run INSTALLER from +BOOTLOADER-PACKAGE." + (program-file + "install-bootloader.scm" + (with-extensions (list guile-gcrypt) + (with-imported-modules (source-module-closure '((gnu build bootloader) + (gnu build install) + (guix store) + (guix utils))) + #~(begin + (use-modules (gnu build bootloader) + (gnu build install) + (guix build utils) + (guix store) + (guix utils) + (ice-9 binary-ports) + (srfi srfi-34) + (srfi srfi-35)) + (let* ((gc-root (string-append #$target %gc-roots-directory "/bootcfg")) + (temp-gc-root (string-append gc-root ".new"))) + (switch-symlinks temp-gc-root gc-root) + (install-boot-config #$bootcfg #$bootcfg-file #$target) + ;; Preserve the previous activation's garbage collector root + ;; until the bootloader installer has run, so that a failure in + ;; the bootloader's installer script doesn't leave the user with + ;; a broken installation. + (when #$installer + (catch #t + (lambda () + (#$installer #$bootloader-package #$device #$target)) + (lambda args + (delete-file temp-gc-root) + (apply throw args)))) + (rename-file temp-gc-root gc-root))))))) + +(define* (install-bootloader eval configuration bootcfg + #:key + (run-installer? #t) + (target "/")) + "Using EVAL, a monadic procedure taking a single G-Expression as an argument, +configure the bootloader on TARGET such that OS will be booted by default and +additional configurations specified by MENU-ENTRIES can be selected." + (let* ((bootloader (bootloader-configuration-bootloader configuration)) + (installer (and run-installer? + (bootloader-installer bootloader))) + (package (bootloader-package bootloader)) + (device (bootloader-configuration-target configuration)) + (bootcfg-file (bootloader-configuration-file bootloader))) + (eval #~(primitive-load #$(install-bootloader-program installer + package + bootcfg + bootcfg-file + device + target))))) diff --git a/tests/services.scm b/tests/services.scm index 44ad0022c6..572fe38164 100644 --- a/tests/services.scm +++ b/tests/services.scm @@ -26,10 +26,6 @@ #:use-module (srfi srfi-64) #:use-module (ice-9 match)) -(define live-service - (@@ (gnu services herd) live-service)) - - (test-begin "services") (test-equal "services, default value" -- cgit v1.2.3 From 5c8c8c455420af27189d6045b3599fe6e27ad012 Mon Sep 17 00:00:00 2001 From: "Jakob L. Kreuze" Date: Wed, 24 Jul 2019 12:34:38 -0400 Subject: guix system: Reimplement 'reconfigure'. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/scripts/system.scm (switch-to-system) (upgrade-shepherd-services, install-bootloader): Delete variable. (local-eval): New variable. (install): Remove 'bootloader-installer' and 'bootcfg-file' parameters. (install): Add 'bootloader' parameter. Signed-off-by: Ludovic Courtès --- guix/scripts/system.scm | 181 ++++++++++-------------------------------------- 1 file changed, 36 insertions(+), 145 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 67a4071684..9fc3a10e98 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -41,6 +41,7 @@ delete-matching-generations) #:use-module (guix graph) #:use-module (guix scripts graph) + #:use-module (guix scripts system reconfigure) #:use-module (guix build utils) #:use-module (guix progress) #:use-module ((guix build syscalls) #:select (terminal-columns)) @@ -178,43 +179,9 @@ TARGET, and register them." (return *unspecified*))) -(define* (install-bootloader installer - #:key - bootcfg bootcfg-file - target) - "Run INSTALLER, a bootloader installation script, with error handling, in -%STORE-MONAD." - (mlet %store-monad ((installer-drv (if installer - (lower-object installer) - (return #f))) - (bootcfg (lower-object bootcfg))) - (let* ((gc-root (string-append target %gc-roots-directory - "/bootcfg")) - (temp-gc-root (string-append gc-root ".new")) - (install (and installer-drv - (derivation->output-path installer-drv))) - (bootcfg (derivation->output-path bootcfg))) - ;; Prepare the symlink to bootloader config file to make sure that it's - ;; a GC root when 'installer-drv' completes (being a bit paranoid.) - (switch-symlinks temp-gc-root bootcfg) - - (unless (false-if-exception - (begin - (install-boot-config bootcfg bootcfg-file target) - (when install - (save-load-path-excursion (primitive-load install))))) - (delete-file temp-gc-root) - (leave (G_ "failed to install bootloader ~a~%") install)) - - ;; Register bootloader config file as a GC root so that its dependencies - ;; (background image, font, etc.) are not reclaimed. - (rename-file temp-gc-root gc-root) - (return #t)))) - (define* (install os-drv target #:key (log-port (current-output-port)) - bootloader-installer install-bootloader? - bootcfg bootcfg-file) + install-bootloader? bootloader bootcfg) "Copy the closure of BOOTCFG, which includes the output of OS-DRV, to directory TARGET. TARGET must be an absolute directory name since that's what 'register-path' expects. @@ -265,10 +232,11 @@ the ownership of '~a' may be incorrect!~%") (populate os-dir target) (mwhen install-bootloader? - (install-bootloader bootloader-installer - #:bootcfg bootcfg - #:bootcfg-file bootcfg-file - #:target target)))))) + (install-bootloader local-eval bootloader bootcfg + #:target target) + (return + (info (G_ "bootloader successfully installed on '~a'~%") + (bootloader-configuration-target bootloader)))))))) ;;; @@ -335,82 +303,6 @@ unload." (warning (G_ "failed to obtain list of shepherd services~%")) (return #f))))) -(define (upgrade-shepherd-services os) - "Upgrade the Shepherd (PID 1) by unloading obsolete services and loading new -services specified in OS and not currently running. - -This is currently very conservative in that it does not stop or unload any -running service. Unloading or stopping the wrong service ('udev', say) could -bring the system down." - (define new-services - (service-value - (fold-services (operating-system-services os) - #:target-type shepherd-root-service-type))) - - ;; Arrange to simply emit a warning if the service upgrade fails. - (with-shepherd-error-handling - (call-with-service-upgrade-info new-services - (lambda (to-restart to-unload) - (for-each (lambda (unload) - (info (G_ "unloading service '~a'...~%") unload) - (unload-service unload)) - to-unload) - - (with-monad %store-monad - (munless (null? new-services) - (let ((new-service-names (map shepherd-service-canonical-name new-services)) - (to-restart-names (map shepherd-service-canonical-name to-restart)) - (to-start (filter shepherd-service-auto-start? new-services))) - (info (G_ "loading new services:~{ ~a~}...~%") new-service-names) - (unless (null? to-restart-names) - ;; Listing TO-RESTART-NAMES in the message below wouldn't help - ;; because many essential services cannot be meaningfully - ;; restarted. See . - (format #t (G_ "To complete the upgrade, run 'herd restart SERVICE' to stop, -upgrade, and restart each service that was not automatically restarted.\n"))) - (mlet %store-monad ((files (mapm %store-monad - (compose lower-object - shepherd-service-file) - new-services))) - ;; Here we assume that FILES are exactly those that were computed - ;; as part of the derivation that built OS, which is normally the - ;; case. - (load-services/safe (map derivation->output-path files)) - - (for-each start-service - (map shepherd-service-canonical-name to-start)) - (return #t))))))))) - -(define* (switch-to-system os - #:optional (profile %system-profile)) - "Make a new generation of PROFILE pointing to the directory of OS, switch to -it atomically, and then run OS's activation script." - (mlet* %store-monad ((drv (operating-system-derivation os)) - (script (lower-object (operating-system-activation-script os)))) - (let* ((system (derivation->output-path drv)) - (number (+ 1 (generation-number profile))) - (generation (generation-file-name profile number))) - (switch-symlinks generation system) - (switch-symlinks profile generation) - - (format #t (G_ "activating system...~%")) - - ;; The activation script may change $PATH, among others, so protect - ;; against that. - (save-environment-excursion - ;; Tell 'activate-current-system' what the new system is. - (setenv "GUIX_NEW_SYSTEM" system) - - ;; The activation script may modify '%load-path' & co., so protect - ;; against that. This is necessary to ensure that - ;; 'upgrade-shepherd-services' gets to see the right modules when it - ;; computes derivations with 'gexp->derivation'. - (save-load-path-excursion - (primitive-load (derivation->output-path script)))) - - ;; Finally, try to update system services. - (upgrade-shepherd-services os)))) - (define-syntax-rule (unless-file-not-found exp) (catch 'system-error (lambda () @@ -505,18 +397,13 @@ STORE is an open connection to the store." ((bootloader-configuration-file-generator bootloader) bootloader-config entries #:old-entries old-entries))) - (bootcfg-file -> (bootloader-configuration-file bootloader)) - (target -> "/") (drvs -> (list bootcfg))) (mbegin %store-monad (show-what-to-build* drvs) (built-derivations drvs) - ;; Only install bootloader configuration file. Thus, no installer is - ;; provided here. - (install-bootloader #f - #:bootcfg bootcfg - #:bootcfg-file bootcfg-file - #:target target)))))) + ;; Only install bootloader configuration file. + (install-bootloader local-eval bootloader-config bootcfg + #:run-installer? #f)))))) ;;; @@ -820,8 +707,17 @@ and TARGET arguments." (condition-message c)) (exit 1))) (#$installer #$bootloader #$device #$target) - (format #t "bootloader successfully installed on '~a'~%" - #$device)))))) + (info (G_ "bootloader successfully installed on '~a'~%") + #$device)))))) + +(define (local-eval exp) + "Evaluate EXP, a G-Expression, in-place." + (mlet* %store-monad ((lowered (lower-gexp exp)) + (_ (built-derivations (lowered-gexp-inputs lowered)))) + (save-load-path-excursion + (set! %load-path (lowered-gexp-load-path lowered)) + (set! %load-compiled-path (lowered-gexp-load-compiled-path lowered)) + (return (primitive-eval (lowered-gexp-sexp lowered)))))) (define* (perform-action action os #:key skip-safety-checks? @@ -858,19 +754,12 @@ static checks." (map boot-parameters->menu-entry (profile-boot-parameters)))) (define bootloader - (bootloader-configuration-bootloader (operating-system-bootloader os))) + (operating-system-bootloader os)) (define bootcfg (and (memq action '(init reconfigure)) (operating-system-bootcfg os menu-entries))) - (define bootloader-script - (let ((installer (bootloader-installer bootloader)) - (target (or target "/"))) - (bootloader-installer-script installer - (bootloader-package bootloader) - bootloader-target target))) - (when (eq? action 'reconfigure) (maybe-suggest-running-guix-pull)) @@ -897,9 +786,7 @@ static checks." ;; See . (drvs (mapm %store-monad lower-object (if (memq action '(init reconfigure)) - (if install-bootloader? - (list sys bootcfg bootloader-script) - (list sys bootcfg)) + (list sys bootcfg) (list sys)))) (% (if derivations-only? (return (for-each (compose println derivation-file-name) @@ -909,28 +796,32 @@ static checks." (if (or dry-run? derivations-only?) (return #f) - (let ((bootcfg-file (bootloader-configuration-file bootloader))) + (begin (for-each (compose println derivation->output-path) drvs) (case action ((reconfigure) + (newline) + (format #t (G_ "activating system...~%")) (mbegin %store-monad - (switch-to-system os) + (switch-to-system local-eval os) (mwhen install-bootloader? - (install-bootloader bootloader-script - #:bootcfg bootcfg - #:bootcfg-file bootcfg-file - #:target "/")))) + (install-bootloader local-eval bootloader bootcfg + #:target (or target "/")) + (return + (info (G_ "bootloader successfully installed on '~a'~%") + (bootloader-configuration-target bootloader)))) + (with-shepherd-error-handling + (upgrade-shepherd-services local-eval os)))) ((init) (newline) (format #t (G_ "initializing operating system under '~a'...~%") target) (install sys (canonicalize-path target) #:install-bootloader? install-bootloader? - #:bootcfg bootcfg - #:bootcfg-file bootcfg-file - #:bootloader-installer bootloader-script)) + #:bootloader bootloader + #:bootcfg bootcfg)) (else ;; All we had to do was to build SYS and maybe register an ;; indirect GC root. -- cgit v1.2.3 From 548e0af4da4e2e9311bc696831a80eedbc5b5798 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 26 Jul 2019 21:49:25 +0200 Subject: discovery: 'scheme-files' ignores hidden files. * guix/discovery.scm (scheme-files)[dot-prefixed?]: New procedure. Use it to exclude any file starting with ".". --- guix/discovery.scm | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/discovery.scm b/guix/discovery.scm index 468b6c59de..7c5fed7f0e 100644 --- a/guix/discovery.scm +++ b/guix/discovery.scm @@ -51,13 +51,15 @@ DIRECTORY is not accessible." ((? symbol? type) type))) + (define (dot-prefixed? file) + (string-prefix? "." file)) + ;; Use 'scandir*' so we can avoid an extra 'lstat' for each entry, as ;; opposed to Guile's 'scandir' or 'file-system-fold'. (fold-right (lambda (entry result) (match entry - (("." . _) - result) - ((".." . _) + (((? dot-prefixed?) . _) + ;; Exclude ".", "..", and hidden files such as backups. result) ((name . properties) (let ((absolute (string-append directory "/" name))) -- cgit v1.2.3 From 2cc5ec7f0d64e9e94f6ae637e1f9573d4b948f0a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 26 Jul 2019 23:22:28 +0200 Subject: gexp: 'compiled-modules' can cross-compile. * guix/gexp.scm (compiled-modules): Add #:target and honor it. --- guix/gexp.scm | 26 ++++++++++++++++++++++---- 1 file changed, 22 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index eef308b000..a83d7168d2 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -1345,6 +1345,7 @@ last one is created from the given object." (define* (compiled-modules modules #:key (name "module-import-compiled") (system (%current-system)) + target (guile (%guile-for-build)) (module-path %load-path) (extensions '()) @@ -1355,7 +1356,8 @@ last one is created from the given object." (pre-load-modules? #t)) "Return a derivation that builds a tree containing the `.go' files corresponding to MODULES. All the MODULES are built in a context where -they can refer to each other." +they can refer to each other. When TARGET is true, cross-compile MODULES for +TARGET, a GNU triplet." (define total (length modules)) (mlet %store-monad ((modules (imported-modules modules @@ -1374,6 +1376,12 @@ they can refer to each other." (srfi srfi-26) (system base compile)) + ;; TODO: Inline this on the next rebuild cycle. + (ungexp-splicing + (if target + (gexp ((use-modules (system base target)))) + (gexp ()))) + (define (regular? file) (not (member file '("." "..")))) @@ -1391,9 +1399,19 @@ they can refer to each other." (gexp ())))) (ungexp (* total (if pre-load-modules? 2 1))) entry) - (compile-file entry - #:output-file output - #:opts %auto-compilation-options) + + (ungexp-splicing + (if target + (gexp ((with-target (ungexp target) + (lambda () + (compile-file entry + #:output-file output + #:opts + %auto-compilation-options))))) + (gexp ((compile-file entry + #:output-file output + #:opts %auto-compilation-options))))) + (+ 1 processed)))) (define (process-directory directory output processed) -- cgit v1.2.3 From 2e8cabb8d630a8423e2e5a3bf150c1c0310b945d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 26 Jul 2019 23:48:03 +0200 Subject: gexp: 'program-file' honors the current system and cross-compilation target. Fixes . Reported by Jakob L. Kreuze . * guix/gexp.scm (program-file-compiler): Pass #:system and #:target to 'gexp->script'. (load-path-expression): Add #:system and #:target and honor them. (gexp->script): Likewise. * tests/gexp.scm ("program-file #:system"): New test. * doc/guix.texi (G-Expressions): Adjust accordingly. --- doc/guix.texi | 3 ++- guix/gexp.scm | 23 +++++++++++++++++------ tests/gexp.scm | 19 +++++++++++++++++++ 3 files changed, 38 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 96448c24e5..ccc36a8a97 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -7439,7 +7439,8 @@ This is the declarative counterpart of @code{gexp->derivation}. @end deffn @deffn {Monadic Procedure} gexp->script @var{name} @var{exp} @ - [#:guile (default-guile)] [#:module-path %load-path] + [#:guile (default-guile)] [#:module-path %load-path] @ + [#:system (%current-system)] [#:target #f] Return an executable script @var{name} that runs @var{exp} using @var{guile}, with @var{exp}'s imported modules in its search path. Look up @var{exp}'s modules in @var{module-path}. diff --git a/guix/gexp.scm b/guix/gexp.scm index a83d7168d2..45cd5869f7 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -427,7 +427,9 @@ This is the declarative counterpart of 'gexp->script'." (($ name gexp guile module-path) (gexp->script name gexp #:module-path module-path - #:guile (or guile (default-guile)))))) + #:guile (or guile (default-guile)) + #:system system + #:target target)))) (define-record-type (%scheme-file name gexp splice?) @@ -1512,7 +1514,7 @@ TARGET, a GNU triplet." 'guile-2.2)) (define* (load-path-expression modules #:optional (path %load-path) - #:key (extensions '())) + #:key (extensions '()) system target) "Return as a monadic value a gexp that sets '%load-path' and '%load-compiled-path' to point to MODULES, a list of module names. MODULES are searched for in PATH. Return #f when MODULES and EXTENSIONS are empty." @@ -1520,10 +1522,13 @@ are searched for in PATH. Return #f when MODULES and EXTENSIONS are empty." (with-monad %store-monad (return #f)) (mlet %store-monad ((modules (imported-modules modules - #:module-path path)) + #:module-path path + #:system system)) (compiled (compiled-modules modules #:extensions extensions - #:module-path path))) + #:module-path path + #:system system + #:target target))) (return (gexp (eval-when (expand load eval) (set! %load-path (cons (ungexp modules) @@ -1545,14 +1550,18 @@ are searched for in PATH. Return #f when MODULES and EXTENSIONS are empty." (define* (gexp->script name exp #:key (guile (default-guile)) - (module-path %load-path)) + (module-path %load-path) + (system (%current-system)) + target) "Return an executable script NAME that runs EXP using GUILE, with EXP's imported modules in its search path. Look up EXP's modules in MODULE-PATH." (mlet %store-monad ((set-load-path (load-path-expression (gexp-modules exp) module-path #:extensions - (gexp-extensions exp)))) + (gexp-extensions exp) + #:system system + #:target target))) (gexp->derivation name (gexp (call-with-output-file (ungexp output) @@ -1572,6 +1581,8 @@ imported modules in its search path. Look up EXP's modules in MODULE-PATH." (write '(ungexp exp) port) (chmod port #o555)))) + #:system system + #:target target #:module-path module-path))) (define* (gexp->file name exp #:key diff --git a/tests/gexp.scm b/tests/gexp.scm index 460afe7f59..5c013d838d 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -1104,6 +1104,25 @@ (return (and (zero? (close-pipe pipe)) (= 42 (string->number str))))))))) +(test-assertm "program-file #:system" + (let* ((exp (with-imported-modules '((guix build utils)) + (gexp (begin + (use-modules (guix build utils)) + (display "hi!"))))) + (system (if (string=? (%current-system) "x86_64-linux") + "armhf-linux" + "x86_64-linux")) + (file (program-file "program" exp))) + (mlet %store-monad ((drv (lower-object file system))) + (return (and (string=? (derivation-system drv) system) + (find (lambda (input) + (let ((drv (pk (derivation-input-derivation input)))) + (and (string=? (derivation-name drv) + "module-import-compiled") + (string=? (derivation-system drv) + system)))) + (derivation-inputs drv))))))) + (test-assertm "scheme-file" (let* ((text (plain-file "foo" "Hello, world!")) (scheme (scheme-file "bar" #~(list "foo" #$text)))) -- cgit v1.2.3 From 0c3c597d2ed649005798f670b13755ee55e6dc9a Mon Sep 17 00:00:00 2001 From: Leo Famulari Date: Thu, 25 Jul 2019 12:51:13 -0400 Subject: gnu: Update default Go compiler to Go 1.12. * gnu/packages/golang.scm (go): Update to go-1.12. * guix/build/go-build-system.scm (setup-go-environment): Set $GOCACHE. --- gnu/packages/golang.scm | 2 +- guix/build/go-build-system.scm | 3 +++ 2 files changed, 4 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/gnu/packages/golang.scm b/gnu/packages/golang.scm index 4a3b42f438..c67ef036ee 100644 --- a/gnu/packages/golang.scm +++ b/gnu/packages/golang.scm @@ -584,7 +584,7 @@ in the style of communicating sequential processes (@dfn{CSP}).") ,@(package-native-inputs go-1.4))) (supported-systems %supported-systems))) -(define-public go go-1.11) +(define-public go go-1.12) (define-public go-github-com-alsm-ioprogress (let ((commit "063c3725f436e7fba0c8f588547bee21ffec7ac5") diff --git a/guix/build/go-build-system.scm b/guix/build/go-build-system.scm index 858068ba98..3dac43c18a 100644 --- a/guix/build/go-build-system.scm +++ b/guix/build/go-build-system.scm @@ -135,6 +135,9 @@ of the package being built and its dependencies, and GOBIN, which determines where executables (\"commands\") are installed to. This phase is sometimes used by packages that use (guix build-system gnu) but have a handful of Go dependencies, so it should be self-contained." + ;; The Go cache is required starting in Go 1.12. We don't actually use it but + ;; we need it to be a writable directory. + (setenv "GOCACHE" "/tmp/go-cache") ;; Using the current working directory as GOPATH makes it easier for packagers ;; who need to manipulate the unpacked source code. (setenv "GOPATH" (getcwd)) -- cgit v1.2.3 From 1db6f137d93b59409fedb3deb24c876649e1b8f2 Mon Sep 17 00:00:00 2001 From: "Jakob L. Kreuze" Date: Wed, 31 Jul 2019 14:13:01 -0400 Subject: reconfigure: Reload all shepherd files when upgrading services. Fixes . Reported by Robert Vollmert . * guix/scripts/system/reconfigure.scm (upgrade-shepherd-services): Load all service files, rather than just those of services to be started. Signed-off-by: Danny Milosavljevic --- guix/scripts/system/reconfigure.scm | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm index 8c7d461585..dee0c24bd2 100644 --- a/guix/scripts/system/reconfigure.scm +++ b/guix/scripts/system/reconfigure.scm @@ -161,12 +161,7 @@ services as defined by OS." target-services) (map live-service-canonical-name live-services))) - (service-files - (map shepherd-service-file - (filter (lambda (service) - (memq (shepherd-service-canonical-name service) - to-start)) - target-services)))) + (service-files (map shepherd-service-file target-services))) (eval #~(primitive-load #$(upgrade-services-program service-files to-start to-unload -- cgit v1.2.3 From ac6b78488faa80a83e85ee38e4a701d9c3c90c46 Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Mon, 29 Jul 2019 22:01:05 +0300 Subject: build/cargo-build-system: Patch cargo checksums. * guix/build/cargo-build-system.scm (generate-all-checksums): New procedure. (update-cargo-lock, patch-cargo-checksums): New phases. (%standard-phases): Add 'update=cargo-lock after 'configure and 'patch-cargo-checksums after 'patch-generated-file-shebangs. * doc/guix.texi (Build System)[cargo-build-system]: Mention how Cargo.lock files are handled. --- doc/guix.texi | 7 ++++-- guix/build/cargo-build-system.scm | 48 ++++++++++++++++++++++++++++++++++++--- 2 files changed, 50 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index ccc36a8a97..cb60d5c7b7 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5854,8 +5854,11 @@ should be added to the package definition via the In its @code{configure} phase, this build system will make any source inputs specified in the @code{#:cargo-inputs} and @code{#:cargo-development-inputs} -parameters available to cargo. The @code{install} phase installs any crate -the binaries if they are defined by the crate. +parameters available to cargo. The @code{update-cargo-lock} phase will, +when there is a @code{Cargo.lock} file, update the @code{Cargo.lock} file +with the inputs and their versions available at build time. The +@code{install} phase installs any crate the binaries if they are defined by +the crate. @end defvr @cindex Clojure (programming language) diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index f38de16cf7..7d363a18a5 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2016 David Craven ;;; Copyright © 2017 Mathieu Othacehe ;;; Copyright © 2019 Ivan Petkov +;;; Copyright © 2019 Efraim Flashner ;;; ;;; This file is part of GNU Guix. ;;; @@ -39,6 +40,21 @@ ;; ;; Code: +;; TODO: Move this to (guix build cargo-utils). Will cause a full rebuild +;; of all rust compilers. + +(define (generate-all-checksums dir-name) + (for-each + (lambda (filename) + (let* ((dir (dirname filename)) + (checksum-file (string-append dir "/.cargo-checksum.json"))) + (when (file-exists? checksum-file) (delete-file checksum-file)) + (display (string-append + "patch-cargo-checksums: generate-checksums for " + dir "\n")) + (generate-checksums dir))) + (find-files dir-name "Cargo.toml$"))) + (define (manifest-targets) "Extract all targets from the Cargo.toml manifest" (let* ((port (open-input-pipe "cargo read-manifest")) @@ -94,8 +110,7 @@ Cargo.toml file present at its root." ;; so that we can generate any cargo checksums. ;; The --strip-components argument is needed to prevent creating ;; an extra directory within `crate-dir`. - (invoke "tar" "xvf" path "-C" crate-dir "--strip-components" "1") - (generate-checksums crate-dir))))) + (invoke "tar" "xvf" path "-C" crate-dir "--strip-components" "1"))))) inputs) ;; Configure cargo to actually use this new directory. @@ -121,6 +136,31 @@ directory = '" port) (setenv "CC" (string-append (assoc-ref inputs "gcc") "/bin/gcc")) #t) +;; The Cargo.lock file tells the build system which crates are required for +;; building and hardcodes their version and checksum. In order to build with +;; the inputs we provide, we need to recreate the file with our inputs. +(define* (update-cargo-lock #:key + (vendor-dir "guix-vendor") + #:allow-other-keys) + "Regenerate the Cargo.lock file with the current build inputs." + (when (file-exists? "Cargo.lock") + (begin + ;; Unfortunately we can't generate a Cargo.lock file until the checksums + ;; are generated, so we have an extra round of generate-all-checksums here. + (generate-all-checksums vendor-dir) + (delete-file "Cargo.lock") + (invoke "cargo" "generate-lockfile"))) + #t) + +;; After the 'patch-generated-file-shebangs phase any vendored crates who have +;; their shebangs patched will have a mismatch on their checksum. +(define* (patch-cargo-checksums #:key + (vendor-dir "guix-vendor") + #:allow-other-keys) + "Patch the checksums of the vendored crates after patching their shebangs." + (generate-all-checksums vendor-dir) + #t) + (define* (build #:key skip-build? (cargo-build-flags '("--release")) @@ -162,7 +202,9 @@ directory = '" port) (replace 'configure configure) (replace 'build build) (replace 'check check) - (replace 'install install))) + (replace 'install install) + (add-after 'configure 'update-cargo-lock update-cargo-lock) + (add-after 'patch-generated-file-shebangs 'patch-cargo-checksums patch-cargo-checksums))) (define* (cargo-build #:key inputs (phases %standard-phases) #:allow-other-keys #:rest args) -- cgit v1.2.3