summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorMarius Bakke <mbakke@fastmail.com>2019-07-12 01:03:53 +0200
committerMarius Bakke <mbakke@fastmail.com>2019-07-12 01:03:53 +0200
commitfb9a23a3f3ad3d7b5b7f03b2007baf27684d6bbd (patch)
treeafbd3f4f33771c61254b0c3d977092542fbe8009 /guix
parent1c4b72cb34640638e40c5190676e5c8c352d292d (diff)
parent5a836ce38c9c29e9c2bd306007347486b90c5064 (diff)
Merge branch 'master' into core-updates
Conflicts: gnu/local.mk gnu/packages/python-xyz.scm gnu/packages/xml.scm guix/gexp.scm po/guix/POTFILES.in
Diffstat (limited to 'guix')
-rw-r--r--guix/channels.scm59
-rw-r--r--guix/derivations.scm115
-rw-r--r--guix/discovery.scm4
-rw-r--r--guix/docker.scm17
-rw-r--r--guix/gexp.scm233
-rw-r--r--guix/inferior.scm9
-rw-r--r--guix/remote.scm134
-rw-r--r--guix/repl.scm86
-rw-r--r--guix/scripts/deploy.scm84
-rw-r--r--guix/scripts/environment.scm67
-rw-r--r--guix/scripts/gc.scm18
-rw-r--r--guix/scripts/pack.scm64
-rw-r--r--guix/scripts/package.scm17
-rw-r--r--guix/scripts/pull.scm4
-rw-r--r--guix/scripts/repl.scm56
-rw-r--r--guix/scripts/system.scm10
-rw-r--r--guix/self.scm3
-rw-r--r--guix/ssh.scm10
-rw-r--r--guix/store.scm11
-rw-r--r--guix/ui.scm21
20 files changed, 739 insertions, 283 deletions
diff --git a/guix/channels.scm b/guix/channels.scm
index e7278c6060..e6bb9b891b 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -349,13 +349,15 @@ INSTANCES."
(resolve-dependencies instances))
(define (instance->derivation instance)
- (mcached (if (eq? instance core-instance)
- (build-channel-instance instance)
- (mlet %store-monad ((core (instance->derivation core-instance))
- (deps (mapm %store-monad instance->derivation
- (edges instance))))
- (build-channel-instance instance core deps)))
- instance))
+ (mlet %store-monad ((system (current-system)))
+ (mcached (if (eq? instance core-instance)
+ (build-channel-instance instance)
+ (mlet %store-monad ((core (instance->derivation core-instance))
+ (deps (mapm %store-monad instance->derivation
+ (edges instance))))
+ (build-channel-instance instance core deps)))
+ instance
+ system)))
(unless core-instance
(let ((loc (and=> (any (compose channel-location channel-instance-channel)
@@ -429,32 +431,27 @@ derivation."
(define (channel-instances->manifest instances)
"Return a profile manifest with entries for all of INSTANCES, a list of
channel instances."
- (define instance->entry
- (match-lambda
- ((instance drv)
- (let ((commit (channel-instance-commit instance))
- (channel (channel-instance-channel instance)))
- (with-monad %store-monad
- (return (manifest-entry
- (name (symbol->string (channel-name channel)))
- (version (string-take commit 7))
- (item (if (guix-channel? channel)
- (if (old-style-guix? drv)
- (whole-package-for-legacy
- (string-append name "-" version)
- drv)
- drv)
- drv))
- (properties
- `((source (repository
- (version 0)
- (url ,(channel-url channel))
- (branch ,(channel-branch channel))
- (commit ,commit))))))))))))
+ (define (instance->entry instance drv)
+ (let ((commit (channel-instance-commit instance))
+ (channel (channel-instance-channel instance)))
+ (manifest-entry
+ (name (symbol->string (channel-name channel)))
+ (version (string-take commit 7))
+ (item (if (guix-channel? channel)
+ (if (old-style-guix? drv)
+ (whole-package-for-legacy (string-append name "-" version)
+ drv)
+ drv)
+ drv))
+ (properties
+ `((source (repository
+ (version 0)
+ (url ,(channel-url channel))
+ (branch ,(channel-branch channel))
+ (commit ,commit))))))))
(mlet* %store-monad ((derivations (channel-instance-derivations instances))
- (entries (mapm %store-monad instance->entry
- (zip instances derivations))))
+ (entries -> (map instance->entry instances derivations)))
(return (manifest entries))))
(define (package-cache-file manifest)
diff --git a/guix/derivations.scm b/guix/derivations.scm
index 186d7a3f8f..731f1f698f 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -293,74 +293,78 @@ result is the set of prerequisites of DRV not already in valid."
(derivation-output-path (assoc-ref outputs sub-drv)))
sub-drvs))))
-(define* (substitution-oracle store drv
+(define* (substitution-oracle store inputs-or-drv
#:key (mode (build-mode normal)))
"Return a one-argument procedure that, when passed a store file name,
returns a 'substitutable?' if it's substitutable and #f otherwise.
-The returned procedure
-knows about all substitutes for all the derivations listed in DRV, *except*
-those that are already valid (that is, it won't bother checking whether an
-item is substitutable if it's already on disk); it also knows about their
-prerequisites, unless they are themselves substitutable.
+
+The returned procedure knows about all substitutes for all the derivation
+inputs or derivations listed in INPUTS-OR-DRV, *except* those that are already
+valid (that is, it won't bother checking whether an item is substitutable if
+it's already on disk); it also knows about their prerequisites, unless they
+are themselves substitutable.
Creating a single oracle (thus making a single 'substitutable-path-info' call) and
reusing it is much more efficient than calling 'has-substitutes?' or similar
repeatedly, because it avoids the costs associated with launching the
substituter many times."
- (define valid?
- (cut valid-path? store <>))
-
(define valid-input?
(cut valid-derivation-input? store <>))
- (define (dependencies drv)
- ;; Skip prerequisite sub-trees of DRV whose root is valid. This allows us
- ;; to ask the substituter for just as much as needed, instead of asking it
- ;; for the whole world, which can be significantly faster when substitute
- ;; info is not already in cache.
- ;; Also, skip derivations marked as non-substitutable.
- (append-map (lambda (input)
+ (define (closure inputs)
+ (let loop ((inputs inputs)
+ (closure '())
+ (visited (set)))
+ (match inputs
+ (()
+ (reverse closure))
+ ((input rest ...)
+ (let ((key (derivation-input-key input)))
+ (cond ((set-contains? visited key)
+ (loop rest closure visited))
+ ((valid-input? input)
+ (loop rest closure (set-insert key visited)))
+ (else
(let ((drv (derivation-input-derivation input)))
- (if (substitutable-derivation? drv)
- (derivation-input-output-paths input)
- '())))
- (derivation-prerequisites drv valid-input?)))
-
- (let* ((paths (delete-duplicates
- (concatenate
- (fold (lambda (drv result)
- (let ((self (match (derivation->output-paths drv)
- (((names . paths) ...)
- paths))))
- (cond ((eqv? mode (build-mode check))
- (cons (dependencies drv) result))
- ((not (substitutable-derivation? drv))
- (cons (dependencies drv) result))
- ((every valid? self)
- result)
- (else
- (cons* self (dependencies drv) result)))))
- '()
- drv))))
- (subst (fold (lambda (subst vhash)
- (vhash-cons (substitutable-path subst) subst
- vhash))
- vlist-null
- (substitutable-path-info store paths))))
+ (loop (append (derivation-inputs drv) rest)
+ (if (substitutable-derivation? drv)
+ (cons input closure)
+ closure)
+ (set-insert key visited))))))))))
+
+ (let* ((inputs (closure (map (match-lambda
+ ((? derivation-input? input)
+ input)
+ ((? derivation? drv)
+ (derivation-input drv)))
+ inputs-or-drv)))
+ (items (append-map derivation-input-output-paths inputs))
+ (subst (fold (lambda (subst vhash)
+ (vhash-cons (substitutable-path subst) subst
+ vhash))
+ vlist-null
+ (substitutable-path-info store items))))
(lambda (item)
(match (vhash-assoc item subst)
(#f #f)
((key . value) value)))))
+(define (dependencies-of-substitutables substitutables inputs)
+ "Return the subset of INPUTS whose output file names is among the references
+of SUBSTITUTABLES."
+ (let ((items (fold set-insert (set)
+ (append-map substitutable-references substitutables))))
+ (filter (lambda (input)
+ (any (cut set-contains? items <>)
+ (derivation-input-output-paths input)))
+ inputs)))
+
(define* (derivation-build-plan store inputs
#:key
(mode (build-mode normal))
(substitutable-info
(substitution-oracle
- store
- (map derivation-input-derivation
- inputs)
- #:mode mode)))
+ store inputs #:mode mode)))
"Given INPUTS, a list of derivation-inputs, return two values: the list of
derivation to build, and the list of substitutable items that, together,
allows INPUTS to be realized.
@@ -391,7 +395,9 @@ by 'substitution-oracle'."
(()
(values build substitute))
((input rest ...)
- (let ((key (derivation-input-key input)))
+ (let ((key (derivation-input-key input))
+ (deps (derivation-inputs
+ (derivation-input-derivation input))))
(cond ((set-contains? visited key)
(loop rest build substitute visited))
((input-built? input)
@@ -400,16 +406,17 @@ by 'substitution-oracle'."
((input-substitutable-info input)
=>
(lambda (substitutables)
- (loop rest build
+ (loop (append (dependencies-of-substitutables substitutables
+ deps)
+ rest)
+ build
(append substitutables substitute)
(set-insert key visited))))
(else
- (let ((deps (derivation-inputs
- (derivation-input-derivation input))))
- (loop (append deps rest)
- (cons (derivation-input-derivation input) build)
- substitute
- (set-insert key visited))))))))))
+ (loop (append deps rest)
+ (cons (derivation-input-derivation input) build)
+ substitute
+ (set-insert key visited)))))))))
(define-deprecated (derivation-prerequisites-to-build store drv #:rest rest)
derivation-build-plan
diff --git a/guix/discovery.scm b/guix/discovery.scm
index 5bb494941b..86f20ec344 100644
--- a/guix/discovery.scm
+++ b/guix/discovery.scm
@@ -78,7 +78,9 @@ DIRECTORY is not accessible."
((= stat:type 'directory)
(append (scheme-files absolute)
result))
- (_ result)))))
+ (_ result)))
+ (else
+ result)))
(else
result))))))
'()
diff --git a/guix/docker.scm b/guix/docker.scm
index 7fe83d9797..b1bd226fa1 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -73,7 +73,7 @@
`((,(generate-tag path) . ((latest . ,id)))))
;; See https://github.com/opencontainers/image-spec/blob/master/config.md
-(define* (config layer time arch #:key entry-point)
+(define* (config layer time arch #:key entry-point (environment '()))
"Generate a minimal image configuration for the given LAYER file."
;; "architecture" must be values matching "platform.arch" in the
;; runtime-spec at
@@ -81,9 +81,13 @@
`((architecture . ,arch)
(comment . "Generated by GNU Guix")
(created . ,time)
- (config . ,(if entry-point
- `((entrypoint . ,entry-point))
- #nil))
+ (config . ,`((env . ,(map (match-lambda
+ ((name . value)
+ (string-append name "=" value)))
+ environment))
+ ,@(if entry-point
+ `((entrypoint . ,entry-point))
+ '())))
(container_config . #nil)
(os . "linux")
(rootfs . ((type . "layers")
@@ -113,6 +117,7 @@ return \"a\"."
(system (utsname:machine (uname)))
database
entry-point
+ (environment '())
compressor
(creation-time (current-time time-utc)))
"Write to IMAGE a Docker image archive containing the given PATHS. PREFIX
@@ -124,6 +129,9 @@ When DATABASE is true, copy it to /var/guix/db in the image and create
When ENTRY-POINT is true, it must be a list of strings; it is stored as the
entry point in the Docker image JSON structure.
+ENVIRONMENT must be a list of name/value pairs. It specifies the environment
+variables that must be defined in the resulting image.
+
SYMLINKS must be a list of (SOURCE -> TARGET) tuples describing symlinks to be
created in the image, where each TARGET is relative to PREFIX.
TRANSFORMATIONS must be a list of (OLD -> NEW) tuples describing how to
@@ -234,6 +242,7 @@ SRFI-19 time-utc object, as the creation time in metadata."
(lambda ()
(scm->json (config (string-append id "/layer.tar")
time arch
+ #:environment environment
#:entry-point entry-point))))
(with-output-to-file "manifest.json"
(lambda ()
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 9bf68a91f4..186bce19a8 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -39,6 +39,9 @@
gexp-input
gexp-input?
+ gexp-input-thing
+ gexp-input-output
+ gexp-input-native?
local-file
local-file?
@@ -78,6 +81,14 @@
load-path-expression
gexp-modules
+ lower-gexp
+ lowered-gexp?
+ lowered-gexp-sexp
+ lowered-gexp-inputs
+ lowered-gexp-guile
+ lowered-gexp-load-path
+ lowered-gexp-load-compiled-path
+
gexp->derivation
gexp->file
gexp->script
@@ -566,15 +577,20 @@ list."
"Turn any package from INPUTS into a derivation for SYSTEM; return the
corresponding input list as a monadic value. When TARGET is true, use it as
the cross-compilation target triplet."
+ (define (store-item? obj)
+ (and (string? obj) (store-path? obj)))
+
(with-monad %store-monad
(mapm %store-monad
(match-lambda
(((? struct? thing) sub-drv ...)
(mlet %store-monad ((drv (lower-object
thing system #:target target)))
- (return `(,drv ,@sub-drv))))
+ (return (apply gexp-input drv sub-drv))))
+ (((? store-item? item))
+ (return (gexp-input item)))
(input
- (return input)))
+ (return (gexp-input input))))
inputs)))
(define* (lower-reference-graphs graphs #:key system target)
@@ -586,7 +602,9 @@ corresponding derivation."
(mlet %store-monad ((inputs (lower-inputs inputs
#:system system
#:target target)))
- (return (map cons file-names inputs))))))
+ (return (map (lambda (file input)
+ (cons file (gexp-input->tuple input)))
+ file-names inputs))))))
(define* (lower-references lst #:key system target)
"Based on LST, a list of output names and packages, return a list of output
@@ -618,6 +636,127 @@ names and file names suitable for the #:allowed-references argument to
(lambda (system)
((force proc) system))))
+;; Representation of a gexp instantiated for a given target and system.
+(define-record-type <lowered-gexp>
+ (lowered-gexp sexp inputs guile load-path load-compiled-path)
+ lowered-gexp?
+ (sexp lowered-gexp-sexp) ;sexp
+ (inputs lowered-gexp-inputs) ;list of <gexp-input>
+ (guile lowered-gexp-guile) ;<derivation> | #f
+ (load-path lowered-gexp-load-path) ;list of store items
+ (load-compiled-path lowered-gexp-load-compiled-path)) ;list of store items
+
+(define* (lower-gexp exp
+ #:key
+ (module-path %load-path)
+ (system (%current-system))
+ (target 'current)
+ (graft? (%graft?))
+ (guile-for-build (%guile-for-build))
+ (effective-version "2.2")
+
+ deprecation-warnings)
+ "*Note: This API is subject to change; use at your own risk!*
+
+Lower EXP, a gexp, instantiating it for SYSTEM and TARGET. Return a
+<lowered-gexp> ready to be used.
+
+Lowered gexps are an intermediate representation that's useful for
+applications that deal with gexps outside in a way that is disconnected from
+derivations--e.g., code evaluated for its side effects."
+ (define %modules
+ (delete-duplicates (gexp-modules exp)))
+
+ (define (search-path modules extensions suffix)
+ (append (match modules
+ ((? derivation? drv)
+ (list (derivation->output-path drv)))
+ (#f
+ '())
+ ((? store-path? item)
+ (list item)))
+ (map (lambda (extension)
+ (string-append (match extension
+ ((? derivation? drv)
+ (derivation->output-path drv))
+ ((? store-path? item)
+ item))
+ suffix))
+ extensions)))
+
+ (mlet* %store-monad ( ;; The following binding forces '%current-system' and
+ ;; '%current-target-system' to be looked up at >>=
+ ;; time.
+ (graft? (set-grafting graft?))
+
+ (system -> (or system (%current-system)))
+ (target -> (if (eq? target 'current)
+ (%current-target-system)
+ target))
+ (guile (if guile-for-build
+ (return guile-for-build)
+ (default-guile-derivation system)))
+ (normals (lower-inputs (gexp-inputs exp)
+ #:system system
+ #:target target))
+ (natives (lower-inputs (gexp-native-inputs exp)
+ #:system system
+ #:target #f))
+ (inputs -> (append normals natives))
+ (sexp (gexp->sexp exp
+ #:system system
+ #:target target))
+ (extensions -> (gexp-extensions exp))
+ (exts (mapm %store-monad
+ (lambda (obj)
+ (lower-object obj system))
+ extensions))
+ (modules (if (pair? %modules)
+ (imported-modules %modules
+ #:system system
+ #:module-path module-path)
+ (return #f)))
+ (compiled (if (pair? %modules)
+ (compiled-modules %modules
+ #:system system
+ #:module-path module-path
+ #:extensions extensions
+ #:guile guile
+ #:deprecation-warnings
+ deprecation-warnings)
+ (return #f))))
+ (define load-path
+ (search-path modules exts
+ (string-append "/share/guile/site/" effective-version)))
+
+ (define load-compiled-path
+ (search-path compiled exts
+ (string-append "/lib/guile/" effective-version
+ "/site-ccache")))
+
+ (mbegin %store-monad
+ (set-grafting graft?) ;restore the initial setting
+ (return (lowered-gexp sexp
+ `(,@(if modules
+ (list (gexp-input modules))
+ '())
+ ,@(if compiled
+ (list (gexp-input compiled))
+ '())
+ ,@(map gexp-input exts)
+ ,@inputs)
+ guile
+ load-path
+ load-compiled-path)))))
+
+(define (gexp-input->tuple input)
+ "Given INPUT, a <gexp-input> record, return the corresponding input tuple
+suitable for the 'derivation' procedure."
+ (match (gexp-input-output input)
+ ("out" `(,(gexp-input-thing input)))
+ (output `(,(gexp-input-thing input)
+ ,(gexp-input-output input)))))
+
(define* (gexp->derivation name exp
#:key
system (target 'current)
@@ -676,10 +815,8 @@ DEPRECATION-WARNINGS determines whether to show deprecation warnings while
compiling modules. It can be #f, #t, or 'detailed.
The other arguments are as for 'derivation'."
- (define %modules
- (delete-duplicates
- (append modules (gexp-modules exp))))
(define outputs (gexp-outputs exp))
+ (define requested-graft? graft?)
(define (graphs-file-names graphs)
;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS.
@@ -693,11 +830,13 @@ The other arguments are as for 'derivation'."
(cons file-name thing)))
graphs))
- (define (extension-flags extension)
- `("-L" ,(string-append (derivation->output-path extension)
- "/share/guile/site/" effective-version)
- "-C" ,(string-append (derivation->output-path extension)
- "/lib/guile/" effective-version "/site-ccache")))
+ (define (add-modules exp modules)
+ (if (null? modules)
+ exp
+ (make-gexp (gexp-references exp)
+ (append modules (gexp-self-modules exp))
+ (gexp-self-extensions exp)
+ (gexp-proc exp))))
(mlet* %store-monad ( ;; The following binding forces '%current-system' and
;; '%current-target-system' to be looked up at >>=
@@ -708,38 +847,19 @@ The other arguments are as for 'derivation'."
(target -> (if (eq? target 'current)
(%current-target-system)
target))
- (normals (lower-inputs (gexp-inputs exp)
- #:system system
- #:target target))
- (natives (lower-inputs (gexp-native-inputs exp)
- #:system system
- #:target #f))
- (inputs -> (append normals natives))
- (sexp (gexp->sexp exp
- #:system system
- #:target target))
- (builder (text-file script-name
- (object->string sexp)))
- (extensions -> (gexp-extensions exp))
- (exts (mapm %store-monad
- (lambda (obj)
- (lower-object obj system))
- extensions))
- (modules (if (pair? %modules)
- (imported-modules %modules
- #:system system
- #:module-path module-path
- #:guile guile-for-build)
- (return #f)))
- (compiled (if (pair? %modules)
- (compiled-modules %modules
- #:system system
- #:module-path module-path
- #:extensions extensions
- #:guile guile-for-build
- #:deprecation-warnings
- deprecation-warnings)
- (return #f)))
+ (exp -> (add-modules exp modules))
+ (lowered (lower-gexp exp
+ #:module-path module-path
+ #:system system
+ #:target target
+ #:graft? requested-graft?
+ #:guile-for-build
+ guile-for-build
+ #:effective-version
+ effective-version
+ #:deprecation-warnings
+ deprecation-warnings))
+
(graphs (if references-graphs
(lower-reference-graphs references-graphs
#:system system
@@ -755,32 +875,30 @@ The other arguments are as for 'derivation'."
#:system system
#:target target)
(return #f)))
- (guile (if guile-for-build
- (return guile-for-build)
- (default-guile-derivation system))))
+ (guile -> (lowered-gexp-guile lowered))
+ (builder (text-file script-name
+ (object->string
+ (lowered-gexp-sexp lowered)))))
(mbegin %store-monad
(set-grafting graft?) ;restore the initial setting
(raw-derivation name
(string-append (derivation->output-path guile)
"/bin/guile")
`("--no-auto-compile"
- ,@(if (pair? %modules)
- `("-L" ,(if (derivation? modules)
- (derivation->output-path modules)
- modules)
- "-C" ,(derivation->output-path compiled))
- '())
- ,@(append-map extension-flags exts)
+ ,@(append-map (lambda (directory)
+ `("-L" ,directory))
+ (lowered-gexp-load-path lowered))
+ ,@(append-map (lambda (directory)
+ `("-C" ,directory))
+ (lowered-gexp-load-compiled-path lowered))
,builder)
#:outputs outputs
#:env-vars env-vars
#:system system
#:inputs `((,guile)
(,builder)
- ,@(if modules
- `((,modules) (,compiled) ,@inputs)
- inputs)
- ,@(map list exts)
+ ,@(map gexp-input->tuple
+ (lowered-gexp-inputs lowered))
,@(match graphs
(((_ . inputs) ...) inputs)
(_ '())))
@@ -796,6 +914,7 @@ The other arguments are as for 'derivation'."
(define* (gexp-inputs exp #:key native?)
"Return the input list for EXP. When NATIVE? is true, return only native
references; otherwise, return only non-native references."
+ ;; TODO: Return <gexp-input> records instead of tuples.
(define (add-reference-inputs ref result)
(match ref
(($ <gexp-input> (? gexp? exp) _ #t)
diff --git a/guix/inferior.scm b/guix/inferior.scm
index 63c95141d7..fee97750b6 100644
--- a/guix/inferior.scm
+++ b/guix/inferior.scm
@@ -59,6 +59,7 @@
inferior-eval
inferior-eval-with-store
inferior-object?
+ read-repl-response
inferior-packages
inferior-available-packages
@@ -183,7 +184,8 @@ equivalent. Return #f if the inferior could not be launched."
(set-record-type-printer! <inferior-object> write-inferior-object)
-(define (read-inferior-response inferior)
+(define (read-repl-response port)
+ "Read a (guix repl) response from PORT and return it as a Scheme object."
(define sexp->object
(match-lambda
(('value value)
@@ -191,12 +193,15 @@ equivalent. Return #f if the inferior could not be launched."
(('non-self-quoting address string)
(inferior-object address string))))
- (match (read (inferior-socket inferior))
+ (match (read port)
(('values objects ...)
(apply values (map sexp->object objects)))
(('exception key objects ...)
(apply throw key (map sexp->object objects)))))
+(define (read-inferior-response inferior)
+ (read-repl-response (inferior-socket inferior)))
+
(define (send-inferior-request exp inferior)
(write exp (inferior-socket inferior))
(newline (inferior-socket inferior)))
diff --git a/guix/remote.scm b/guix/remote.scm
new file mode 100644
index 0000000000..e503c76167
--- /dev/null
+++ b/guix/remote.scm
@@ -0,0 +1,134 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.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 remote)
+ #:use-module (guix ssh)
+ #:use-module (guix gexp)
+ #:use-module (guix inferior)
+ #:use-module (guix store)
+ #:use-module (guix monads)
+ #:use-module (guix modules)
+ #:use-module (guix derivations)
+ #:use-module (ssh popen)
+ #:use-module (srfi srfi-1)
+ #:use-module (ice-9 match)
+ #:export (remote-eval))
+
+;;; Commentary:
+;;;
+;;; Note: This API is experimental and subject to change!
+;;;
+;;; Evaluate a gexp on a remote machine, over SSH, ensuring that all the
+;;; elements the gexp refers to are deployed beforehand. This is useful for
+;;; expressions that have side effects; for pure expressions, you would rather
+;;; build a derivation remotely or offload it.
+;;;
+;;; Code:
+
+(define (remote-pipe-for-gexp lowered session)
+ "Return a remote pipe for the given SESSION to evaluate LOWERED."
+ (define shell-quote
+ (compose object->string object->string))
+
+ (apply open-remote-pipe* session OPEN_READ
+ (string-append (derivation->output-path
+ (lowered-gexp-guile lowered))
+ "/bin/guile")
+ "--no-auto-compile"
+ (append (append-map (lambda (directory)
+ `("-L" ,directory))
+ (lowered-gexp-load-path lowered))
+ (append-map (lambda (directory)
+ `("-C" ,directory))
+ (lowered-gexp-load-path lowered))
+ `("-c"
+ ,(shell-quote (lowered-gexp-sexp lowered))))))
+
+(define (%remote-eval lowered session)
+ "Evaluate LOWERED, a lowered gexp, in SESSION. This assumes that all the
+prerequisites of EXP are already available on the host at SESSION."
+ (let* ((pipe (remote-pipe-for-gexp lowered session))
+ (result (read-repl-response pipe)))
+ (close-port pipe)
+ result))
+
+(define (trampoline exp)
+ "Return a \"trampoline\" gexp that evaluates EXP and writes the evaluation
+result to the current output port using the (guix repl) protocol."
+ (define program
+ (scheme-file "remote-exp.scm" exp))
+
+ (with-imported-modules (source-module-closure '((guix repl)))
+ #~(begin
+ (use-modules (guix repl))
+ (send-repl-response '(primitive-load #$program)
+ (current-output-port))
+ (force-output))))
+
+(define* (remote-eval exp session
+ #:key
+ (build-locally? #t)
+ (module-path %load-path)
+ (socket-name "/var/guix/daemon-socket/socket"))
+ "Evaluate EXP, a gexp, on the host at SESSION, an SSH session. Ensure that
+all the elements EXP refers to are built and deployed to SESSION beforehand.
+When BUILD-LOCALLY? is true, said dependencies are built locally and sent to
+the remote store afterwards; otherwise, dependencies are built directly on the
+remote store."
+ (mlet %store-monad ((lowered (lower-gexp (trampoline exp)
+ #:module-path %load-path))
+ (remote -> (connect-to-remote-daemon session
+ socket-name)))
+ (define inputs
+ (cons (gexp-input (lowered-gexp-guile lowered))
+ (lowered-gexp-inputs lowered)))
+
+ (define to-build
+ (map (lambda (input)
+ (if (derivation? (gexp-input-thing input))
+ (cons (gexp-input-thing input)
+ (gexp-input-output input))
+ (gexp-input-thing input)))
+ inputs))
+
+ (if build-locally?
+ (let ((to-send (map (lambda (input)
+ (match (gexp-input-thing input)
+ ((? derivation? drv)
+ (derivation->output-path
+ drv (gexp-input-output input)))
+ ((? store-path? item)
+ item)))
+ inputs)))
+ (mbegin %store-monad
+ (built-derivations to-build)
+ ((store-lift send-files) to-send remote #:recursive? #t)
+ (return (close-connection remote))
+ (return (%remote-eval lowered session))))
+ (let ((to-send (map (lambda (input)
+ (match (gexp-input-thing input)
+ ((? derivation? drv)
+ (derivation-file-name drv))
+ ((? store-path? item)
+ item)))
+ inputs)))
+ (mbegin %store-monad
+ ((store-lift send-files) to-send remote #:recursive? #t)
+ (return (build-derivations remote to-build))
+ (return (close-connection remote))
+ (return (%remote-eval lowered session)))))))
diff --git a/guix/repl.scm b/guix/repl.scm
new file mode 100644
index 0000000000..5cff5c71e9
--- /dev/null
+++ b/guix/repl.scm
@@ -0,0 +1,86 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.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 repl)
+ #:use-module (rnrs bytevectors)
+ #:use-module (ice-9 match)
+ #:export (send-repl-response
+ machine-repl))
+
+;;; Commentary:
+;;;
+;;; This module implements the "machine-readable" REPL provided by
+;;; 'guix repl -t machine'. It's a lightweight module meant to be
+;;; embedded in any Guile process providing REPL functionality.
+;;;
+;;; Code:
+
+(define (self-quoting? x)
+ "Return #t if X is self-quoting."
+ (letrec-syntax ((one-of (syntax-rules ()
+ ((_) #f)
+ ((_ pred rest ...)
+ (or (pred x)
+ (one-of rest ...))))))
+ (one-of symbol? string? pair? null? vector?
+ bytevector? number? boolean?)))
+
+
+(define (send-repl-response exp output)
+ "Write the response corresponding to the evaluation of EXP to PORT, an
+output port."
+ (define (value->sexp value)
+ (if (self-quoting? value)
+ `(value ,value)
+ `(non-self-quoting ,(object-address value)
+ ,(object->string value))))
+
+ (catch #t
+ (lambda ()
+ (let ((results (call-with-values
+ (lambda ()
+ (primitive-eval exp))
+ list)))
+ (write `(values ,@(map value->sexp results))
+ output)
+ (newline output)
+ (force-output output)))
+ (lambda (key . args)
+ (write `(exception ,key ,@(map value->sexp args)))
+ (newline output)
+ (force-output output))))
+
+(define* (machine-repl #:optional
+ (input (current-input-port))
+ (output (current-output-port)))
+ "Run a machine-usable REPL over ports INPUT and OUTPUT.
+
+The protocol of this REPL is meant to be machine-readable and provides proper
+support to represent multiple-value returns, exceptions, objects that lack a
+read syntax, and so on. As such it is more convenient and robust than parsing
+Guile's REPL prompt."
+ (write `(repl-version 0 0) output)
+ (newline output)
+ (force-output output)
+
+ (let loop ()
+ (match (read input)
+ ((? eof-object?) #t)
+ (exp
+ (send-repl-response exp output)
+ (loop)))))
diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
new file mode 100644
index 0000000000..978cfb2a81
--- /dev/null
+++ b/guix/scripts/deploy.scm
@@ -0,0 +1,84 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 David Thompson <davet@gnu.org>
+;;; 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 deploy)
+ #:use-module (gnu machine)
+ #:use-module (guix scripts)
+ #:use-module (guix scripts build)
+ #:use-module (guix store)
+ #:use-module (guix ui)
+ #:use-module (ice-9 format)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-37)
+ #:export (guix-deploy))
+
+;;; Commentary:
+;;;
+;;; This program provides a command-line interface to (gnu machine), allowing
+;;; users to perform remote deployments through specification files.
+;;;
+;;; Code:
+
+
+
+(define (show-help)
+ (display (G_ "Usage: guix deploy [OPTION] FILE...
+Perform the deployment specified by FILE.\n"))
+ (show-build-options-help)
+ (newline)
+ (display (G_ "
+ -h, --help display this help and exit"))
+ (display (G_ "
+ -V, --version display version information and exit"))
+ (newline)
+ (show-bug-report-information))
+
+(define %options
+ (cons* (option '(#\h "help") #f #f
+ (lambda args
+ (show-help)
+ (exit 0)))
+ %standard-build-options))
+
+(define %default-options
+ '((system . ,(%current-system))
+ (substitutes? . #t)
+ (build-hook? . #t)
+ (graft? . #t)
+ (debug . 0)
+ (verbosity . 1)))
+
+(define (load-source-file file)
+ "Load FILE as a user module."
+ (let ((module (make-user-module '((gnu) (gnu machine) (gnu machine ssh)))))
+ (load* file module)))
+
+(define (guix-deploy . args)
+ (define (handle-argument arg result)
+ (alist-cons 'file arg result))
+ (let* ((opts (parse-command-line args %options (list %default-options)
+ #:argument-handler handle-argument))
+ (file (assq-ref opts 'file))
+ (machines (or (and file (load-source-file file)) '())))
+ (with-store store
+ (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)))
+ machines))))
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index ac269083c8..f7f7edda48 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -163,6 +163,10 @@ COMMAND or an interactive shell in that environment.\n"))
user into an isolated container, use the name USER
with home directory /home/USER"))
(display (G_ "
+ --no-cwd do not share current working directory with an
+ isolated container"))
+
+ (display (G_ "
--share=SPEC for containers, share writable host file system
according to SPEC"))
(display (G_ "
@@ -270,6 +274,9 @@ use '--preserve' instead~%"))
(lambda (opt name arg result)
(alist-cons 'user arg
(alist-delete 'user result eq?))))
+ (option '("no-cwd") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'no-cwd? #t result)))
(option '("share") #t #f
(lambda (opt name arg result)
(alist-cons 'file-system-mapping
@@ -445,7 +452,8 @@ regexps in WHITE-LIST."
((_ . status) status)))))
(define* (launch-environment/container #:key command bash user user-mappings
- profile manifest link-profile? network?)
+ profile manifest link-profile? network?
+ map-cwd?)
"Run COMMAND within a container that features the software in PROFILE.
Environment variables are set according to the search paths of MANIFEST.
The global shell is BASH, a file name for a GNU Bash binary in the
@@ -480,26 +488,29 @@ will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from
;; /bin/sh, the current working directory, and possibly networking
;; configuration files within the container.
(mappings
- (override-user-mappings
- user home
- (append user-mappings
- ;; Current working directory.
- (list (file-system-mapping
- (source cwd)
- (target cwd)
- (writable? #t)))
- ;; When in Rome, do as Nix build.cc does: Automagically
- ;; map common network configuration files.
- (if network?
- %network-file-mappings
- '())
- ;; Mappings for the union closure of all inputs.
- (map (lambda (dir)
- (file-system-mapping
- (source dir)
- (target dir)
- (writable? #f)))
- reqs))))
+ (append
+ (override-user-mappings
+ user home
+ (append user-mappings
+ ;; Share current working directory, unless asked not to.
+ (if map-cwd?
+ (list (file-system-mapping
+ (source cwd)
+ (target cwd)
+ (writable? #t)))
+ '())))
+ ;; When in Rome, do as Nix build.cc does: Automagically
+ ;; map common network configuration files.
+ (if network?
+ %network-file-mappings
+ '())
+ ;; Mappings for the union closure of all inputs.
+ (map (lambda (dir)
+ (file-system-mapping
+ (source dir)
+ (target dir)
+ (writable? #f)))
+ reqs)))
(file-systems (append %container-file-systems
(map file-system-mapping->bind-mount
mappings))))
@@ -537,8 +548,10 @@ will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from
(write-group groups)
;; For convenience, start in the user's current working
- ;; directory rather than the root directory.
- (chdir (override-user-dir user home cwd))
+ ;; directory or, if unmapped, the home directory.
+ (chdir (if map-cwd?
+ (override-user-dir user home cwd)
+ home-dir))
(primitive-exit/status
;; A container's environment is already purified, so no need to
@@ -664,6 +677,7 @@ message if any test fails."
(container? (assoc-ref opts 'container?))
(link-prof? (assoc-ref opts 'link-profile?))
(network? (assoc-ref opts 'network?))
+ (no-cwd? (assoc-ref opts 'no-cwd?))
(user (assoc-ref opts 'user))
(bootstrap? (assoc-ref opts 'bootstrap?))
(system (assoc-ref opts 'system))
@@ -684,6 +698,9 @@ message if any test fails."
(leave (G_ "'--link-profile' cannot be used without '--container'~%")))
(when (and (not container?) user)
(leave (G_ "'--user' cannot be used without '--container'~%")))
+ (when (and (not container?) no-cwd?)
+ (leave (G_ "--no-cwd cannot be used without --container~%")))
+
(with-store store
(with-status-verbosity (assoc-ref opts 'verbosity)
@@ -740,7 +757,9 @@ message if any test fails."
#:profile profile
#:manifest manifest
#:link-profile? link-prof?
- #:network? network?)))
+ #:network? network?
+ #:map-cwd? (not no-cwd?))))
+
(else
(return
(exit/status
diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm
index 9a57e5fd1e..31657326b6 100644
--- a/guix/scripts/gc.scm
+++ b/guix/scripts/gc.scm
@@ -104,11 +104,14 @@ Invoke the garbage collector.\n"))
'()))))
(define (delete-old-generations store profile pattern)
- "Remove the generations of PROFILE that match PATTERN, a duration pattern.
-Do nothing if none matches."
+ "Remove the generations of PROFILE that match PATTERN, a duration pattern;
+do nothing if none matches. If PATTERN is #f, delete all generations but the
+current one."
(let* ((current (generation-number profile))
- (numbers (matching-generations pattern profile
- #:duration-relation >)))
+ (numbers (if (not pattern)
+ (profile-generations profile)
+ (matching-generations pattern profile
+ #:duration-relation >))))
;; Make sure we don't inadvertently remove the current generation.
(delete-generations store profile (delv current numbers))))
@@ -155,8 +158,7 @@ is deprecated; use '-D'~%"))
(when (and arg (not (string->duration arg)))
(leave (G_ "~s does not denote a duration~%")
arg))
- (alist-cons 'delete-generations (or arg "")
- result)))))
+ (alist-cons 'delete-generations arg result)))))
(option '("optimize") #f #f
(lambda (opt name arg result)
(alist-cons 'action 'optimize
@@ -287,9 +289,9 @@ is deprecated; use '-D'~%"))
(assert-no-extra-arguments)
(let ((min-freed (assoc-ref opts 'min-freed))
(free-space (assoc-ref opts 'free-space)))
- (match (assoc-ref opts 'delete-generations)
+ (match (assq 'delete-generations opts)
(#f #t)
- ((? string? pattern)
+ ((_ . pattern)
(delete-generations store pattern)))
(cond
(free-space
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index c8cb7b959d..1524607623 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -27,6 +27,7 @@
#:use-module (guix utils)
#:use-module (guix store)
#:use-module ((guix status) #:select (with-status-verbosity))
+ #:use-module ((guix self) #:select (make-config.scm))
#:use-module (guix grafts)
#:autoload (guix inferior) (inferior-package?)
#:use-module (guix monads)
@@ -285,6 +286,32 @@ added to the pack."
build
#:references-graphs `(("profile" ,profile))))
+(define (singularity-environment-file profile)
+ "Return a shell script that defines the environment variables corresponding
+to the search paths of PROFILE."
+ (define build
+ (with-extensions (list guile-gcrypt)
+ (with-imported-modules `(((guix config) => ,(make-config.scm))
+ ,@(source-module-closure
+ `((guix profiles)
+ (guix search-paths))
+ #:select? not-config?))
+ #~(begin
+ (use-modules (guix profiles) (guix search-paths)
+ (ice-9 match))
+
+ (call-with-output-file #$output
+ (lambda (port)
+ (for-each (match-lambda
+ ((spec . value)
+ (format port "~a=~a~%export ~a~%"
+ (search-path-specification-variable spec)
+ value
+ (search-path-specification-variable spec))))
+ (profile-search-paths #$profile))))))))
+
+ (computed-file "singularity-environment.sh" build))
+
(define* (squashfs-image name profile
#:key target
(profile-name "guix-profile")
@@ -304,6 +331,9 @@ added to the pack."
(file-append (store-database (list profile))
"/db/db.sqlite")))
+ (define environment
+ (singularity-environment-file profile))
+
(define build
(with-imported-modules (source-module-closure
'((guix build utils)
@@ -338,6 +368,7 @@ added to the pack."
`(,@(map store-info-item
(call-with-input-file "profile"
read-reference-graph))
+ #$environment
,#$output
;; Do not perform duplicate checking because we
@@ -378,10 +409,19 @@ added to the pack."
target)))))))
'#$symlinks)
+ "-p" "/.singularity.d d 555 0 0"
+
+ ;; Create the environment file.
+ "-p" "/.singularity.d/env d 555 0 0"
+ "-p" ,(string-append
+ "/.singularity.d/env/90-environment.sh s 777 0 0 "
+ (relative-file-name "/.singularity.d/env"
+ #$environment))
+
;; Create /.singularity.d/actions, and optionally the 'run'
;; script, used by 'singularity run'.
- "-p" "/.singularity.d d 555 0 0"
"-p" "/.singularity.d/actions d 555 0 0"
+
,@(if entry-point
`(;; This one if for Singularity 2.x.
"-p"
@@ -440,11 +480,24 @@ the image."
(define build
;; Guile-JSON and Guile-Gcrypt are required by (guix docker).
(with-extensions (list guile-json guile-gcrypt)
- (with-imported-modules (source-module-closure '((guix docker)
- (guix build store-copy))
- #:select? not-config?)
+ (with-imported-modules `(((guix config) => ,(make-config.scm))
+ ,@(source-module-closure
+ `((guix docker)
+ (guix build store-copy)
+ (guix profiles)
+ (guix search-paths))
+ #:select? not-config?))
#~(begin
- (use-modules (guix docker) (srfi srfi-19) (guix build store-copy))
+ (use-modules (guix docker) (guix build store-copy)
+ (guix profiles) (guix search-paths)
+ (srfi srfi-19) (ice-9 match))
+
+ (define environment
+ (map (match-lambda
+ ((spec . value)
+ (cons (search-path-specification-variable spec)
+ value)))
+ (profile-search-paths #$profile)))
(setenv "PATH" (string-append #$archiver "/bin"))
@@ -455,6 +508,7 @@ the image."
#$profile
#:database #+database
#:system (or #$target (utsname:machine (uname)))
+ #:environment environment
#:entry-point #$(and entry-point
#~(string-append #$profile "/"
#$entry-point))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 7b277b63f1..a43c96516f 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -98,7 +98,7 @@ denote ranges as interpreted by 'matching-generations'."
(cond ((not (file-exists? profile)) ; XXX: race condition
(raise (condition (&profile-not-found-error
(profile profile)))))
- ((string-null? pattern)
+ ((not pattern)
(delete-generations store profile
(delv current (profile-generations profile))))
;; Do not delete the zeroth generation.
@@ -120,9 +120,7 @@ denote ranges as interpreted by 'matching-generations'."
(let ((numbers (delv current numbers)))
(when (null-list? numbers)
(leave (G_ "no matching generation~%")))
- (delete-generations store profile numbers))))
- (else
- (leave (G_ "invalid syntax: ~a~%") pattern)))))
+ (delete-generations store profile numbers)))))))
(define* (build-and-use-profile store profile manifest
#:key
@@ -457,12 +455,12 @@ command-line option~%")
arg-handler)))
(option '(#\l "list-generations") #f #t
(lambda (opt name arg result arg-handler)
- (values (cons `(query list-generations ,(or arg ""))
+ (values (cons `(query list-generations ,arg)
result)
#f)))
(option '(#\d "delete-generations") #f #t
(lambda (opt name arg result arg-handler)
- (values (alist-cons 'delete-generations (or arg "")
+ (values (alist-cons 'delete-generations arg
result)
#f)))
(option '(#\S "switch-generation") #t #f
@@ -683,7 +681,7 @@ processed, #f otherwise."
(cond ((not (file-exists? profile)) ; XXX: race condition
(raise (condition (&profile-not-found-error
(profile profile)))))
- ((string-null? pattern)
+ ((not pattern)
(match (profile-generations profile)
(()
#t)
@@ -697,10 +695,7 @@ processed, #f otherwise."
(exit 1)
(begin
(list-generation display-profile-content (car numbers))
- (diff-profiles profile numbers)))))
- (else
- (leave (G_ "invalid syntax: ~a~%")
- pattern))))
+ (diff-profiles profile numbers)))))))
#t)
(('list-installed regexp)
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 2d428546c9..7895c19914 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -117,7 +117,7 @@ Download and deploy the latest version of Guix.\n"))
(alist-cons 'channel-file arg result)))
(option '(#\l "list-generations") #f #t
(lambda (opt name arg result)
- (cons `(query list-generations ,(or arg ""))
+ (cons `(query list-generations ,arg)
result)))
(option '(#\N "news") #f #f
(lambda (opt name arg result)
@@ -486,7 +486,7 @@ list of package changes.")))))
(cond ((not (file-exists? profile)) ; XXX: race condition
(raise (condition (&profile-not-found-error
(profile profile)))))
- ((string-null? pattern)
+ ((not pattern)
(list-generations profile (profile-generations profile)))
((matching-generations pattern profile)
=>
diff --git a/guix/scripts/repl.scm b/guix/scripts/repl.scm
index 02169e8004..e1cc759fc8 100644
--- a/guix/scripts/repl.scm
+++ b/guix/scripts/repl.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -19,6 +19,7 @@
(define-module (guix scripts repl)
#:use-module (guix ui)
#:use-module (guix scripts)
+ #:use-module (guix repl)
#:use-module (guix utils)
#:use-module (guix packages)
#:use-module (gnu packages)
@@ -29,8 +30,7 @@
#:autoload (system repl repl) (start-repl)
#:autoload (system repl server)
(make-tcp-server-socket make-unix-domain-server-socket)
- #:export (machine-repl
- guix-repl))
+ #:export (guix-repl))
;;; Commentary:
;;;
@@ -68,62 +68,12 @@ Start a Guile REPL in the Guix execution environment.\n"))
(newline)
(show-bug-report-information))
-(define (self-quoting? x)
- "Return #t if X is self-quoting."
- (letrec-syntax ((one-of (syntax-rules ()
- ((_) #f)
- ((_ pred rest ...)
- (or (pred x)
- (one-of rest ...))))))
- (one-of symbol? string? pair? null? vector?
- bytevector? number? boolean?)))
-
(define user-module
;; Module where we execute user code.
(let ((module (resolve-module '(guix-user) #f #f #:ensure #t)))
(beautify-user-module! module)
module))
-(define* (machine-repl #:optional
- (input (current-input-port))
- (output (current-output-port)))
- "Run a machine-usable REPL over ports INPUT and OUTPUT.
-
-The protocol of this REPL is meant to be machine-readable and provides proper
-support to represent multiple-value returns, exceptions, objects that lack a
-read syntax, and so on. As such it is more convenient and robust than parsing
-Guile's REPL prompt."
- (define (value->sexp value)
- (if (self-quoting? value)
- `(value ,value)
- `(non-self-quoting ,(object-address value)
- ,(object->string value))))
-
- (write `(repl-version 0 0) output)
- (newline output)
- (force-output output)
-
- (let loop ()
- (match (read input)
- ((? eof-object?) #t)
- (exp
- (catch #t
- (lambda ()
- (let ((results (call-with-values
- (lambda ()
-
- (primitive-eval exp))
- list)))
- (write `(values ,@(map value->sexp results))
- output)
- (newline output)
- (force-output output)))
- (lambda (key . args)
- (write `(exception ,key ,@(map value->sexp args)))
- (newline output)
- (force-output output)))
- (loop)))))
-
(define (call-with-connection spec thunk)
"Dynamically-bind the current input and output ports according to SPEC and
call THUNK."
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 60c1ca5c9a..67a4071684 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -614,7 +614,7 @@ PATTERN, a string. When PATTERN is #f, display all the system generations."
(cond ((not (file-exists? profile)) ; XXX: race condition
(raise (condition (&profile-not-found-error
(profile profile)))))
- ((string-null? pattern)
+ ((not pattern)
(for-each display-system-generation (profile-generations profile)))
((matching-generations pattern profile)
=>
@@ -622,9 +622,7 @@ PATTERN, a string. When PATTERN is #f, display all the system generations."
(if (null-list? numbers)
(exit 1)
(leave-on-EPIPE
- (for-each display-system-generation numbers)))))
- (else
- (leave (G_ "invalid syntax: ~a~%") pattern))))
+ (for-each display-system-generation numbers)))))))
;;;
@@ -1232,7 +1230,7 @@ argument list and OPTS is the option alist."
;; an operating system configuration file.
((list-generations)
(let ((pattern (match args
- (() "")
+ (() #f)
((pattern) pattern)
(x (leave (G_ "wrong number of arguments~%"))))))
(list-generations pattern)))
@@ -1242,7 +1240,7 @@ argument list and OPTS is the option alist."
;; operating system configuration file.
((delete-generations)
(let ((pattern (match args
- (() "")
+ (() #f)
((pattern) pattern)
(x (leave (G_ "wrong number of arguments~%"))))))
(with-store store
diff --git a/guix/self.scm b/guix/self.scm
index 6a876bd822..249705fcee 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -770,7 +770,8 @@ Info manual."
(gnu services)
,@(scheme-modules* source "gnu/bootloader")
,@(scheme-modules* source "gnu/system")
- ,@(scheme-modules* source "gnu/services"))
+ ,@(scheme-modules* source "gnu/services")
+ ,@(scheme-modules* source "gnu/machine"))
(list *core-package-modules* *package-modules*
*extra-modules* *core-modules*)
#:extensions dependencies
diff --git a/guix/ssh.scm b/guix/ssh.scm
index 9b9baf54ea..ede00133c8 100644
--- a/guix/ssh.scm
+++ b/guix/ssh.scm
@@ -57,12 +57,14 @@
(define %compression
"zlib@openssh.com,zlib")
-(define* (open-ssh-session host #:key user port
+(define* (open-ssh-session host #:key user port identity
(compression %compression))
- "Open an SSH session for HOST and return it. When USER and PORT are #f, use
-default values or whatever '~/.ssh/config' specifies; otherwise use them.
-Throw an error on failure."
+ "Open an SSH session for HOST and return it. IDENTITY specifies the file
+name of a private key to use for authenticating with the host. When USER,
+PORT, or IDENTITY are #f, use default values or whatever '~/.ssh/config'
+specifies; otherwise use them. Throw an error on failure."
(let ((session (make-session #:user user
+ #:identity identity
#:host host
#:port port
#:timeout 10 ;seconds
diff --git a/guix/store.scm b/guix/store.scm
index 52940ff751..d7c603898c 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -1802,11 +1802,12 @@ connection, and return the result."
(call-with-values (lambda ()
(run-with-state mval store))
(lambda (result new-store)
- ;; Copy the object cache from NEW-STORE so we don't fully discard the
- ;; state.
- (let ((cache (store-connection-object-cache new-store)))
- (set-store-connection-object-cache! store cache)
- result)))))
+ (when (and store new-store)
+ ;; Copy the object cache from NEW-STORE so we don't fully discard
+ ;; the state.
+ (let ((cache (store-connection-object-cache new-store)))
+ (set-store-connection-object-cache! store cache)))
+ result))))
;;;
diff --git a/guix/ui.scm b/guix/ui.scm
index 6d243ef041..76f6fc8eed 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -835,8 +835,7 @@ check and report what is prerequisites are available for download."
;; substituter many times. This makes a big difference, especially when
;; DRV is a long list as is the case with 'guix environment'.
(if use-substitutes?
- (substitution-oracle store (map derivation-input-derivation inputs)
- #:mode mode)
+ (substitution-oracle store inputs #:mode mode)
(const #f)))
(let*-values (((build download)
@@ -844,18 +843,6 @@ check and report what is prerequisites are available for download."
#:mode mode
#:substitutable-info
substitutable-info))
- ((download) ; add the references of DOWNLOAD
- (if use-substitutes?
- (delete-duplicates
- (append download
- (filter-map (lambda (item)
- (if (valid-path? store item)
- #f
- (substitutable-info item)))
- (append-map
- substitutable-references
- download))))
- download))
((graft hook build)
(match (fold (lambda (drv acc)
(let ((file (derivation-file-name drv)))
@@ -1497,7 +1484,11 @@ DURATION-RELATION with the current time."
((string->duration str)
=>
filter-by-duration)
- (else #f)))
+ (else
+ (raise
+ (condition (&message
+ (message (format #f (G_ "invalid syntax: ~a~%")
+ str))))))))
(define (display-generation profile number)
"Display a one-line summary of generation NUMBER of PROFILE."