summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorRicardo Wurmus <rekado@elephly.net>2019-08-06 10:07:36 +0200
committerRicardo Wurmus <rekado@elephly.net>2019-08-06 10:07:36 +0200
commit378d94e51b00c30b19a39154278d01f1f3c4dbc1 (patch)
tree0c9ed3a1c1b6db778b05ad03fa8edd91cfb737f4 /guix
parentd350d5e71434704d147b1252d21e46daf6bb9885 (diff)
parent6a5198170ed5f10e1eee2e25fc6a39f3f33a40fd (diff)
Merge remote-tracking branch 'origin/master' into wip-texlive
Diffstat (limited to 'guix')
-rw-r--r--guix/build/cargo-build-system.scm48
-rw-r--r--guix/build/go-build-system.scm3
-rw-r--r--guix/discovery.scm8
-rw-r--r--guix/docker.scm19
-rw-r--r--guix/gexp.scm49
-rw-r--r--guix/git-download.scm4
-rw-r--r--guix/git.scm69
-rw-r--r--guix/import/cpan.scm14
-rw-r--r--guix/import/crate.scm6
-rw-r--r--guix/import/gem.scm10
-rw-r--r--guix/import/github.scm13
-rw-r--r--guix/import/json.scm11
-rw-r--r--guix/import/launchpad.scm13
-rw-r--r--guix/import/pypi.scm8
-rw-r--r--guix/import/stackage.scm4
-rw-r--r--guix/import/utils.scm25
-rw-r--r--guix/scripts/build.scm13
-rw-r--r--guix/scripts/deploy.scm14
-rw-r--r--guix/scripts/import/json.scm2
-rw-r--r--guix/scripts/pack.scm2
-rw-r--r--guix/scripts/system.scm181
-rw-r--r--guix/scripts/system/reconfigure.scm232
-rw-r--r--guix/self.scm2
-rw-r--r--guix/swh.scm35
24 files changed, 502 insertions, 283 deletions
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 <david@craven.ch>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2019 Ivan Petkov <ivanppetkov@gmail.com>
+;;; Copyright © 2019 Efraim Flashner <efraim@flashner.co.il>
;;;
;;; 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)
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))
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)))
diff --git a/guix/docker.scm b/guix/docker.scm
index b1bd226fa1..c598a073f6 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -62,9 +62,9 @@
(define (manifest path id)
"Generate a simple image manifest."
- `(((Config . "config.json")
- (RepoTags . (,(generate-tag path)))
- (Layers . (,(string-append id "/layer.tar"))))))
+ `#(((Config . "config.json")
+ (RepoTags . #(,(generate-tag path)))
+ (Layers . #(,(string-append id "/layer.tar"))))))
;; According to the specifications this is required for backwards
;; compatibility. It duplicates information provided by the manifest.
@@ -81,17 +81,18 @@
`((architecture . ,arch)
(comment . "Generated by GNU Guix")
(created . ,time)
- (config . ,`((env . ,(map (match-lambda
- ((name . value)
- (string-append name "=" value)))
- environment))
+ (config . ,`((env . ,(list->vector
+ (map (match-lambda
+ ((name . value)
+ (string-append name "=" value)))
+ environment)))
,@(if entry-point
- `((entrypoint . ,entry-point))
+ `((entrypoint . ,(list->vector entry-point)))
'())))
(container_config . #nil)
(os . "linux")
(rootfs . ((type . "layers")
- (diff_ids . (,(layer-diff-id layer)))))))
+ (diff_ids . #(,(layer-diff-id layer)))))))
(define %tar-determinism-options
;; GNU tar options to produce archives deterministically.
diff --git a/guix/gexp.scm b/guix/gexp.scm
index eef308b000..45cd5869f7 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -427,7 +427,9 @@ This is the declarative counterpart of 'gexp->script'."
(($ <program-file> 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>
(%scheme-file name gexp splice?)
@@ -1345,6 +1347,7 @@ last one is created from the given <scheme-file> 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 +1358,8 @@ last one is created from the given <scheme-file> 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 +1378,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 +1401,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)
@@ -1494,7 +1514,7 @@ they can refer to each other."
'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."
@@ -1502,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)
@@ -1527,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)
@@ -1554,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/guix/git-download.scm b/guix/git-download.scm
index f904d11c25..8f84681d46 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2017 Christopher Baines <mail@cbaines.net>
;;;
@@ -85,7 +85,7 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
(module-ref (resolve-interface '(gnu packages compression)) 'zlib))
(define guile-json
- (module-ref (resolve-interface '(gnu packages guile)) 'guile-json))
+ (module-ref (resolve-interface '(gnu packages guile)) 'guile-json-3))
(define gnutls
(module-ref (resolve-interface '(gnu packages tls)) 'gnutls))
diff --git a/guix/git.scm b/guix/git.scm
index 289537dedf..de98fed40c 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -139,29 +139,44 @@ 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))))
+ ;; 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))
@@ -218,8 +233,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 [<branch name> | <sha1> | <tag name>].
+REF is pair whose key is [branch | commit | tag | tag-or-commit ] and value
+the associated data: [<branch name> | <sha1> | <tag name> | <string>].
When RECURSIVE? is true, check out submodules as well, if any."
(define canonical-ref
@@ -319,7 +334,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)
@@ -358,7 +373,7 @@ Log progress and checkout info to LOG-PORT."
(($ <git-checkout> 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/guix/import/cpan.scm b/guix/import/cpan.scm
index d4bea84353..ec86f11743 100644
--- a/guix/import/cpan.scm
+++ b/guix/import/cpan.scm
@@ -76,8 +76,8 @@
;; ssleay
;; sun
("zlib" 'zlib)
- ((x) (string->license x))
- ((lst ...) `(list ,@(map string->license lst)))
+ (#(x) (string->license x))
+ (#(lst ...) `(list ,@(map string->license lst)))
(_ #f)))
(define (module->name module)
@@ -88,10 +88,10 @@
"Return the base distribution module for a given module. E.g. the 'ok'
module is distributed with 'Test::Simple', so (module->dist-name \"ok\") would
return \"Test-Simple\""
- (assoc-ref (json-fetch-alist (string-append
- "https://fastapi.metacpan.org/v1/module/"
- module
- "?fields=distribution"))
+ (assoc-ref (json-fetch (string-append
+ "https://fastapi.metacpan.org/v1/module/"
+ module
+ "?fields=distribution"))
"distribution"))
(define (package->upstream-name package)
@@ -114,7 +114,7 @@ return \"Test-Simple\""
"Return an alist representation of the CPAN metadata for the perl module MODULE,
or #f on failure. MODULE should be e.g. \"Test::Script\""
;; This API always returns the latest release of the module.
- (json-fetch-alist (string-append "https://fastapi.metacpan.org/v1/release/" name)))
+ (json-fetch (string-append "https://fastapi.metacpan.org/v1/release/" name)))
(define (cpan-home name)
(string-append "https://metacpan.org/release/" name))
diff --git a/guix/import/crate.scm b/guix/import/crate.scm
index 29318aac0e..52c5cb1c30 100644
--- a/guix/import/crate.scm
+++ b/guix/import/crate.scm
@@ -51,7 +51,7 @@
(define (crate-kind-predicate kind)
(lambda (dep) (string=? (assoc-ref dep "kind") kind)))
- (and-let* ((crate-json (json-fetch-alist (string-append crate-url crate-name)))
+ (and-let* ((crate-json (json-fetch (string-append crate-url crate-name)))
(crate (assoc-ref crate-json "crate"))
(name (assoc-ref crate "name"))
(version (assoc-ref crate "max_version"))
@@ -63,8 +63,8 @@
string->license)
'())) ;missing license info
(path (string-append "/" version "/dependencies"))
- (deps-json (json-fetch-alist (string-append crate-url name path)))
- (deps (assoc-ref deps-json "dependencies"))
+ (deps-json (json-fetch (string-append crate-url name path)))
+ (deps (vector->list (assoc-ref deps-json "dependencies")))
(dep-crates (filter (crate-kind-predicate "normal") deps))
(dev-dep-crates
(filter (lambda (dep)
diff --git a/guix/import/gem.scm b/guix/import/gem.scm
index ea576b5e4a..0bf9ff2552 100644
--- a/guix/import/gem.scm
+++ b/guix/import/gem.scm
@@ -40,7 +40,7 @@
(define (rubygems-fetch name)
"Return an alist representation of the RubyGems metadata for the package NAME,
or #f on failure."
- (json-fetch-alist
+ (json-fetch
(string-append "https://rubygems.org/api/v1/gems/" name ".json")))
(define (ruby-package-name name)
@@ -130,14 +130,18 @@ VERSION, HASH, HOME-PAGE, DESCRIPTION, DEPENDENCIES, and LICENSES."
(assoc-ref package "info")))
(home-page (assoc-ref package "homepage_uri"))
(dependencies-names (map (lambda (dep) (assoc-ref dep "name"))
- (assoc-ref* package "dependencies" "runtime")))
+ (vector->list
+ (assoc-ref* package
+ "dependencies"
+ "runtime"))))
(dependencies (map (lambda (dep)
(if (string=? dep "bundler")
"bundler" ; special case, no prefix
(ruby-package-name dep)))
dependencies-names))
(licenses (map string->license
- (assoc-ref package "licenses"))))
+ (vector->list
+ (assoc-ref package "licenses")))))
(values (make-gem-sexp name version hash home-page synopsis
description dependencies licenses)
dependencies-names)))))
diff --git a/guix/import/github.scm b/guix/import/github.scm
index cdac70420a..fa23fa4c06 100644
--- a/guix/import/github.scm
+++ b/guix/import/github.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com>
-;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net>
;;;
@@ -130,7 +130,7 @@ repository separated by a forward slash, from a string URL of the form
(define (fetch-releases-or-tags url)
"Fetch the list of \"releases\" or, if it's empty, the list of tags for the
-repository at URL. Return the corresponding JSON dictionaries (hash tables),
+repository at URL. Return the corresponding JSON dictionaries (alists),
or #f if the information could not be retrieved.
We look at both /releases and /tags because the \"release\" feature of GitHub
@@ -172,11 +172,11 @@ empty list."
'https://github.com/arq5x/bedtools2/archive/v2.24.0.tar.gz' and the name of
the package e.g. 'bedtools2'. Return #f if there is no releases"
(define (pre-release? x)
- (hash-ref x "prerelease"))
+ (assoc-ref x "prerelease"))
(define (release->version release)
- (let ((tag (or (hash-ref release "tag_name") ;a "release"
- (hash-ref release "name"))) ;a tag
+ (let ((tag (or (assoc-ref release "tag_name") ;a "release"
+ (assoc-ref release "name"))) ;a tag
(name-length (string-length package-name)))
(cond
;; some tags include the name of the package e.g. "fdupes-1.51"
@@ -197,7 +197,8 @@ the package e.g. 'bedtools2'. Return #f if there is no releases"
tag)
(else #f))))
- (let* ((json (fetch-releases-or-tags url)))
+ (let* ((json (and=> (fetch-releases-or-tags url)
+ vector->list)))
(if (eq? json #f)
(if (%github-token)
(error "Error downloading release information through the GitHub
diff --git a/guix/import/json.scm b/guix/import/json.scm
index 81ea5e7b31..8900724dcd 100644
--- a/guix/import/json.scm
+++ b/guix/import/json.scm
@@ -1,7 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 David Thompson <davet@gnu.org>
;;; Copyright © 2015, 2016 Eric Bavier <bavier@member.fsf.org>
-;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -23,8 +23,7 @@
#:use-module (guix http-client)
#:use-module (guix import utils)
#:use-module (srfi srfi-34)
- #:export (json-fetch
- json-fetch-alist))
+ #:export (json-fetch))
(define* (json-fetch url
;; Note: many websites returns 403 if we omit a
@@ -43,9 +42,3 @@ the query."
(result (json->scm port)))
(close-port port)
result)))
-
-(define (json-fetch-alist url)
- "Return an alist representation of the JSON resource URL, or #f if URL
-returns 403 or 404."
- (and=> (json-fetch url)
- hash-table->alist))
diff --git a/guix/import/launchpad.scm b/guix/import/launchpad.scm
index ffd5e9221e..1a15f28077 100644
--- a/guix/import/launchpad.scm
+++ b/guix/import/launchpad.scm
@@ -87,15 +87,16 @@ for example, 'linuxdcpp'. Return #f if there is no releases."
;; example, "5.1.0-rc1") are assumed to be pre-releases.
(not (string-every (char-set-union (char-set #\.)
char-set:digit)
- (hash-ref x "version"))))
+ (assoc-ref x "version"))))
- (hash-ref
+ (assoc-ref
(last (remove
pre-release?
- (hash-ref (json-fetch
- (string-append "https://api.launchpad.net/1.0/"
- package-name "/releases"))
- "entries")))
+ (vector->list
+ (assoc-ref (json-fetch
+ (string-append "https://api.launchpad.net/1.0/"
+ package-name "/releases"))
+ "entries"))))
"version"))
(define (latest-release pkg)
diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm
index ab7a024ee0..9b3d80a02e 100644
--- a/guix/import/pypi.scm
+++ b/guix/import/pypi.scm
@@ -1,7 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 David Thompson <davet@gnu.org>
;;; Copyright © 2015 Cyril Roelandt <tipecaml@gmail.com>
-;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com>
@@ -56,7 +56,7 @@
(define (pypi-fetch name)
"Return an alist representation of the PyPI metadata for the package NAME,
or #f on failure."
- (json-fetch-alist (string-append "https://pypi.org/pypi/" name "/json")))
+ (json-fetch (string-append "https://pypi.org/pypi/" name "/json")))
;; For packages found on PyPI that lack a source distribution.
(define-condition-type &missing-source-error &error
@@ -69,7 +69,7 @@ or #f on failure."
(assoc-ref* pypi-package "info" "version"))))
(or (find (lambda (release)
(string=? "sdist" (assoc-ref release "packagetype")))
- releases)
+ (vector->list releases))
(raise (condition (&missing-source-error
(package pypi-package)))))))
@@ -80,7 +80,7 @@ or #f if there isn't any."
(assoc-ref* pypi-package "info" "version"))))
(or (find (lambda (release)
(string=? "bdist_wheel" (assoc-ref release "packagetype")))
- releases)
+ (vector->list releases))
#f)))
(define (python->package-name name)
diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm
index 1c1e73a723..194bea633e 100644
--- a/guix/import/stackage.scm
+++ b/guix/import/stackage.scm
@@ -60,7 +60,7 @@
(let* ((url (if (string=? "" version)
(string-append %stackage-url "/lts")
(string-append %stackage-url "/lts-" version)))
- (lts-info (json-fetch-alist url)))
+ (lts-info (json-fetch url)))
(if lts-info
(reverse lts-info)
(leave-with-message "LTS release version not found: ~a" version))))))
@@ -74,7 +74,7 @@
(define (lts-package-version pkgs-info name)
"Return the version of the package with upstream NAME included in PKGS-INFO."
(let ((pkg (find (lambda (pkg) (string=? (stackage-package-name pkg) name))
- pkgs-info)))
+ (vector->list pkgs-info))))
(stackage-package-version pkg)))
diff --git a/guix/import/utils.scm b/guix/import/utils.scm
index 84503ab907..2a3b7341fb 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -45,7 +45,6 @@
#:use-module (srfi srfi-41)
#:export (factorize-uri
- hash-table->alist
flatten
assoc-ref*
@@ -100,21 +99,6 @@ of the string VERSION is replaced by the symbol 'version."
'()
indices))))))
-(define (hash-table->alist table)
- "Return an alist represenation of TABLE."
- (map (match-lambda
- ((key . (lst ...))
- (cons key
- (map (lambda (x)
- (if (hash-table? x)
- (hash-table->alist x)
- x))
- lst)))
- ((key . (? hash-table? table))
- (cons key (hash-table->alist table)))
- (pair pair))
- (hash-map->list cons table)))
-
(define (flatten lst)
"Return a list that recursively concatenates all sub-lists of LST."
(fold-right
@@ -330,11 +314,14 @@ the expected fields of an <origin> object."
(lookup-build-system-by-name
(string->symbol (assoc-ref meta "build-system"))))
(native-inputs
- (specs->package-lists (or (assoc-ref meta "native-inputs") '())))
+ (specs->package-lists
+ (vector->list (or (assoc-ref meta "native-inputs") '#()))))
(inputs
- (specs->package-lists (or (assoc-ref meta "inputs") '())))
+ (specs->package-lists
+ (vector->list (or (assoc-ref meta "inputs") '#()))))
(propagated-inputs
- (specs->package-lists (or (assoc-ref meta "propagated-inputs") '())))
+ (specs->package-lists
+ (vector->list (or (assoc-ref meta "propagated-inputs") '#()))))
(home-page
(assoc-ref meta "home-page"))
(synopsis
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)))))
diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index 978cfb2a81..52bba3f3bf 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -23,6 +23,8 @@
#:use-module (guix scripts build)
#:use-module (guix store)
#:use-module (guix ui)
+ #:use-module (guix utils)
+ #:use-module (guix grafts)
#:use-module (ice-9 format)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-37)
@@ -40,6 +42,8 @@
(define (show-help)
(display (G_ "Usage: guix deploy [OPTION] FILE...
Perform the deployment specified by FILE.\n"))
+ (display (G_ "
+ -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\""))
(show-build-options-help)
(newline)
(display (G_ "
@@ -54,10 +58,14 @@ Perform the deployment specified by FILE.\n"))
(lambda args
(show-help)
(exit 0)))
+ (option '(#\s "system") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'system arg
+ (alist-delete 'system result eq?))))
%standard-build-options))
(define %default-options
- '((system . ,(%current-system))
+ `((system . ,(%current-system))
(substitutes? . #t)
(build-hook? . #t)
(graft? . #t)
@@ -80,5 +88,7 @@ Perform the deployment specified by FILE.\n"))
(set-build-options-from-command-line store opts)
(for-each (lambda (machine)
(info (G_ "deploying to ~a...") (machine-display-name machine))
- (run-with-store store (deploy-machine machine)))
+ (parameterize ((%current-system (assq-ref opts 'system))
+ (%graft? (assq-ref opts 'graft?)))
+ (run-with-store store (deploy-machine machine))))
machines))))
diff --git a/guix/scripts/import/json.scm b/guix/scripts/import/json.scm
index 8771e7b0eb..c9daf65479 100644
--- a/guix/scripts/import/json.scm
+++ b/guix/scripts/import/json.scm
@@ -93,7 +93,7 @@ Import and convert the JSON package definition in PACKAGE-FILE.\n"))
(let ((json (json-string->scm
(with-input-from-file file-name read-string))))
;; TODO: also print define-module boilerplate
- (package->code (alist->package (hash-table->alist json)))))
+ (package->code (alist->package json))))
(lambda _
(leave (G_ "invalid JSON in file '~a'~%") file-name))))
(()
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 01472d9768..fdb98983bf 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -479,7 +479,7 @@ the image."
(define build
;; Guile-JSON and Guile-Gcrypt are required by (guix docker).
- (with-extensions (list guile-json guile-gcrypt)
+ (with-extensions (list guile-json-3 guile-gcrypt)
(with-imported-modules `(((guix config) => ,(make-config.scm))
,@(source-module-closure
`((guix docker)
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 <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=22039#30>.
- (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 <http://bugs.gnu.org/21068>.
(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.
diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm
new file mode 100644
index 0000000000..dee0c24bd2
--- /dev/null
+++ b/guix/scripts/system/reconfigure.scm
@@ -0,0 +1,232 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
+;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
+;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(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 <live-service> 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 <live-service> 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
+;; <https://issues.guix.info/issue/33508> 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 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/guix/self.scm b/guix/self.scm
index 838ede7690..f03fe01d0c 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -50,7 +50,7 @@
(module-ref (resolve-interface module) variable))))
(match-lambda
("guile" (ref '(gnu packages commencement) 'guile-final))
- ("guile-json" (ref '(gnu packages guile) 'guile-json))
+ ("guile-json" (ref '(gnu packages guile) 'guile-json-3))
("guile-ssh" (ref '(gnu packages ssh) 'guile-ssh))
("guile-git" (ref '(gnu packages guile) 'guile-git))
("guile-sqlite3" (ref '(gnu packages guile) 'guile-sqlite3))
diff --git a/guix/swh.scm b/guix/swh.scm
index d692f81806..df2a138f04 100644
--- a/guix/swh.scm
+++ b/guix/swh.scm
@@ -138,16 +138,16 @@ following SPEC, a series of field specifications."
(json->scm input))
((string? input)
(json-string->scm input))
- ((hash-table? input)
+ ((or (null? input) (pair? input))
input))))
(let-syntax ((extract-field (syntax-rules ()
((_ table (field key json->value))
- (json->value (hash-ref table key)))
+ (json->value (assoc-ref table key)))
((_ table (field key))
- (hash-ref table key))
+ (assoc-ref table key))
((_ table (field))
- (hash-ref table
- (symbol->string 'field))))))
+ (assoc-ref table
+ (symbol->string 'field))))))
(ctor (extract-field table spec) ...)))))
(define-syntax-rule (define-json-mapping rtd ctor pred json->record
@@ -257,12 +257,13 @@ FALSE-IF-404? is true, return #f upon 404 responses."
(target-url branch-target-url))
(define (json->branches branches)
- (hash-map->list (lambda (key value)
- (make-branch key
- (string->symbol
- (hash-ref value "target_type"))
- (hash-ref value "target_url")))
- branches))
+ (map (match-lambda
+ ((key . value)
+ (make-branch key
+ (string->symbol
+ (assoc-ref value "target_type"))
+ (assoc-ref value "target_url"))))
+ branches))
;; <https://archive.softwareheritage.org/api/1/release/1f44934fb6e2cefccbecd4fa347025349fa9ff76/>
(define-json-mapping <release> make-release release?
@@ -292,9 +293,10 @@ FALSE-IF-404? is true, return #f upon 404 responses."
(license-url content-license-url "license_url"))
(define (json->checksums checksums)
- (hash-map->list (lambda (key value)
- (cons key (base16-string->bytevector value)))
- checksums))
+ (map (match-lambda
+ ((key . value)
+ (cons key (base16-string->bytevector value))))
+ checksums))
;; <https://archive.softwareheritage.org/api/1/directory/27c69c5d298a43096a53affbf881e7b13f17bdcd/>
(define-json-mapping <directory-entry> make-directory-entry directory-entry?
@@ -365,14 +367,15 @@ FALSE-IF-404? is true, return #f upon 404 responses."
json->directory-entries)
(define (json->directory-entries port)
- (map json->directory-entry (json->scm port)))
+ (map json->directory-entry
+ (vector->list (json->scm port))))
(define (origin-visits origin)
"Return the list of visits of ORIGIN, a record as returned by
'lookup-origin'."
(call (swh-url (origin-visits-url origin))
(lambda (port)
- (map json->visit (json->scm port)))))
+ (map json->visit (vector->list (json->scm port))))))
(define (visit-snapshot visit)
"Return the snapshot corresponding to VISIT."