amaharaneko/guix-mirrors
1
1
Fork 0
mirror of https://codeberg.org/guix/guix.git synced 2025-10-02 02:15:12 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

Merge branch 'master' into staging

Browse source
This commit is contained in:
Marius Bakke 2019-07-07 01:18:18 +02:00
commit 36175a3a9e
No known key found for this signature in database
GPG key ID: A2A06DF2A33A54FA
39 changed files with 2147 additions and 277 deletions
Download patch file Download diff file Expand all files Collapse all files

3
Makefile.am
View file

@ -90,6 +90,7 @@ MODULES = \
guix/nar.scm \ guix/nar.scm \
guix/derivations.scm \ guix/derivations.scm \
guix/grafts.scm \ guix/grafts.scm \
guix/repl.scm \
guix/inferior.scm \ guix/inferior.scm \
guix/describe.scm \ guix/describe.scm \
guix/channels.scm \ guix/channels.scm \
@ -266,6 +267,7 @@ MODULES = \
guix/scripts/weather.scm \ guix/scripts/weather.scm \
guix/scripts/container.scm \ guix/scripts/container.scm \
guix/scripts/container/exec.scm \ guix/scripts/container/exec.scm \
guix/scripts/deploy.scm \
guix.scm \ guix.scm \
$(GNU_SYSTEM_MODULES) $(GNU_SYSTEM_MODULES)
@ -273,6 +275,7 @@ if HAVE_GUILE_SSH
MODULES += \ MODULES += \
guix/ssh.scm \ guix/ssh.scm \
guix/remote.scm \
guix/scripts/copy.scm \ guix/scripts/copy.scm \
guix/store/ssh.scm guix/store/ssh.scm

114
doc/guix.texi
View file

@ -65,6 +65,7 @@ Copyright @copyright{} 2018 Alex Vong@*
Copyright @copyright{} 2019 Josh Holland@* Copyright @copyright{} 2019 Josh Holland@*
Copyright @copyright{} 2019 Diego Nicola Barbato@* Copyright @copyright{} 2019 Diego Nicola Barbato@*
Copyright @copyright{} 2019 Ivan Petkov@* Copyright @copyright{} 2019 Ivan Petkov@*
Copyright @copyright{} 2019 Jakob L. Kreuze@*
Permission is granted to copy, distribute and/or modify this document Permission is granted to copy, distribute and/or modify this document
under the terms of the GNU Free Documentation License, Version 1.3 or under the terms of the GNU Free Documentation License, Version 1.3 or
@ -81,6 +82,7 @@ Documentation License''.
* guix gc: (guix)Invoking guix gc. Reclaiming unused disk space. * guix gc: (guix)Invoking guix gc. Reclaiming unused disk space.
* guix pull: (guix)Invoking guix pull. Update the list of available packages. * guix pull: (guix)Invoking guix pull. Update the list of available packages.
* guix system: (guix)Invoking guix system. Manage the operating system configuration. * guix system: (guix)Invoking guix system. Manage the operating system configuration.
* guix deploy: (guix)Invoking guix deploy. Manage operating system configurations for remote hosts.
@end direntry @end direntry
@dircategory Software development @dircategory Software development
@ -269,6 +271,7 @@ System Configuration
* Initial RAM Disk:: Linux-Libre bootstrapping. * Initial RAM Disk:: Linux-Libre bootstrapping.
* Bootloader Configuration:: Configuring the boot loader. * Bootloader Configuration:: Configuring the boot loader.
* Invoking guix system:: Instantiating a system configuration. * Invoking guix system:: Instantiating a system configuration.
* Invoking guix deploy:: Deploying a system configuration to a remote host.
* Running Guix in a VM:: How to run Guix System in a virtual machine. * Running Guix in a VM:: How to run Guix System in a virtual machine.
* Defining Services:: Adding new service definitions. * Defining Services:: Adding new service definitions.
@ -10296,6 +10299,7 @@ instance to support new system services.
* Initial RAM Disk:: Linux-Libre bootstrapping. * Initial RAM Disk:: Linux-Libre bootstrapping.
* Bootloader Configuration:: Configuring the boot loader. * Bootloader Configuration:: Configuring the boot loader.
* Invoking guix system:: Instantiating a system configuration. * Invoking guix system:: Instantiating a system configuration.
* Invoking guix deploy:: Deploying a system configuration to a remote host.
* Running Guix in a VM:: How to run Guix System in a virtual machine. * Running Guix in a VM:: How to run Guix System in a virtual machine.
* Defining Services:: Adding new service definitions. * Defining Services:: Adding new service definitions.
@end menu @end menu
@ -25392,6 +25396,116 @@ example graph.
@end table @end table
@node Invoking guix deploy
@section Invoking @code{guix deploy}
We've already seen @code{operating-system} declarations used to manage a
machine's configuration locally. Suppose you need to configure multiple
machines, though---perhaps you're managing a service on the web that's
comprised of several servers. @command{guix deploy} enables you to use those
same @code{operating-system} declarations to manage multiple remote hosts at
once as a logical ``deployment''.
@quotation Note
The functionality described in this section is still under development
and is subject to change. Get in touch with us on
@email{guix-devel@@gnu.org}!
@end quotation
@example
guix deploy @var{file}
@end example
Such an invocation will deploy the machines that the code within @var{file}
evaluates to. As an example, @var{file} might contain a definition like this:
@example
;; This is a Guix deployment of a "bare bones" setup, with
;; no X11 display server, to a machine with an SSH daemon
;; listening on localhost:2222. A configuration such as this
;; may be appropriate for virtual machine with ports
;; forwarded to the host's loopback interface.
(use-service-modules networking ssh)
(use-package-modules bootloaders)
(define %system
(operating-system
(host-name "gnu-deployed")
(timezone "Etc/UTC")
(bootloader (bootloader-configuration
(bootloader grub-bootloader)
(target "/dev/vda")
(terminal-outputs '(console))))
(file-systems (cons (file-system
(mount-point "/")
(device "/dev/vda1")
(type "ext4"))
%base-file-systems))
(services
(append (list (service dhcp-client-service-type)
(service openssh-service-type
(openssh-configuration
(permit-root-login #t)
(allow-empty-passwords? #t))))
%base-services))))
(list (machine
(system %system)
(environment managed-host-environment-type)
(configuration (machine-ssh-configuration
(host-name "localhost")
(identity "./id_rsa")
(port 2222)))))
@end example
The file should evaluate to a list of @var{machine} objects. This example,
upon being deployed, will create a new generation on the remote system
realizing the @code{operating-system} declaration @var{%system}.
@var{environment} and @var{configuration} specify how the machine should be
provisioned---that is, how the computing resources should be created and
managed. The above example does not create any resources, as a
@code{'managed-host} is a machine that is already running the Guix system and
available over the network. This is a particularly simple case; a more
complex deployment may involve, for example, starting virtual machines through
a Virtual Private Server (VPS) provider. In such a case, a different
@var{environment} type would be used.
@deftp {Data Type} machine
This is the data type representing a single machine in a heterogeneous Guix
deployment.
@table @asis
@item @code{system}
The object of the operating system configuration to deploy.
@item @code{environment}
An @code{environment-type} describing how the machine should be provisioned.
At the moment, the only supported value is
@code{managed-host-environment-type}.
@item @code{configuration} (default: @code{#f})
An object describing the configuration for the machine's @code{environment}.
If the @code{environment} has a default configuration, @code{#f} maybe used.
If @code{#f} is used for an environment with no default configuration,
however, an error will be thrown.
@end table
@end deftp
@deftp {Data Type} machine-ssh-configuration
This is the data type representing the SSH client parameters for a machine
with an @code{environment} of @code{managed-host-environment-type}.
@table @asis
@item @code{host-name}
@item @code{port} (default: @code{22})
@item @code{user} (default: @code{"root"})
@item @code{identity} (default: @code{#f})
If specified, the path to the SSH private key to use to authenticate with the
remote host.
@end table
@end deftp
@node Running Guix in a VM @node Running Guix in a VM
@section Running Guix in a Virtual Machine @section Running Guix in a Virtual Machine

7
gnu/build/linux-container.scm
View file

@ -130,9 +130,14 @@ for the process."
"/dev/random" "/dev/random"
"/dev/urandom" "/dev/urandom"
"/dev/tty" "/dev/tty"
"/dev/ptmx"
"/dev/fuse")) "/dev/fuse"))
;; Mount a new devpts instance on /dev/pts.
(when (file-exists? "/dev/ptmx")
(mount* "none" (scope "/dev/pts") "devpts" 0
"newinstance,mode=0620")
(symlink "/dev/pts/ptmx" (scope "/dev/ptmx")))
;; Setup the container's /dev/console by bind mounting the pseudo-terminal ;; Setup the container's /dev/console by bind mounting the pseudo-terminal
;; associated with standard input when there is one. ;; associated with standard input when there is one.
(let* ((in (current-input-port)) (let* ((in (current-input-port))

6
gnu/ci.scm
View file

@ -193,9 +193,11 @@ system.")
(define channel-build-system (define channel-build-system
;; Build system used to "convert" a channel instance to a package. ;; Build system used to "convert" a channel instance to a package.
(let* ((build (lambda* (store name inputs (let* ((build (lambda* (store name inputs
#:key instance #:allow-other-keys) #:key instance system
#:allow-other-keys)
(run-with-store store (run-with-store store
(channel-instances->derivation (list instance))))) (channel-instances->derivation (list instance))
#:system system)))
(lower (lambda* (name #:key system instance #:allow-other-keys) (lower (lambda* (name #:key system instance #:allow-other-keys)
(bag (bag
(name name) (name name)

4
gnu/local.mk
View file

@ -299,6 +299,7 @@ GNU_SYSTEM_MODULES = \
%D%/packages/llvm.scm \ %D%/packages/llvm.scm \
%D%/packages/lout.scm \ %D%/packages/lout.scm \
%D%/packages/logging.scm \ %D%/packages/logging.scm \
%D%/packages/logo.scm \
%D%/packages/lolcode.scm \ %D%/packages/lolcode.scm \
%D%/packages/lsof.scm \ %D%/packages/lsof.scm \
%D%/packages/lua.scm \ %D%/packages/lua.scm \
@ -564,6 +565,9 @@ GNU_SYSTEM_MODULES = \
%D%/system/uuid.scm \ %D%/system/uuid.scm \
%D%/system/vm.scm \ %D%/system/vm.scm \
\ \
%D%/machine.scm \
%D%/machine/ssh.scm \
\
%D%/build/accounts.scm \ %D%/build/accounts.scm \
%D%/build/activation.scm \ %D%/build/activation.scm \
%D%/build/bootloader.scm \ %D%/build/bootloader.scm \

107
gnu/machine.scm Normal file
View file

@ -0,0 +1,107 @@
;;; 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 (gnu machine)
#:use-module (gnu system)
#:use-module (guix derivations)
#:use-module (guix monads)
#:use-module (guix records)
#:use-module (guix store)
#:use-module ((guix utils) #:select (source-properties->location))
#:export (environment-type
environment-type?
environment-type-name
environment-type-description
environment-type-location
machine
machine?
this-machine
machine-system
machine-environment
machine-configuration
machine-display-name
deploy-machine
machine-remote-eval))
;;; Commentary:
;;;
;;; This module provides the types used to declare individual machines in a
;;; heterogeneous Guix deployment. The interface allows users of specify system
;;; configurations and the means by which resources should be provisioned on a
;;; per-host basis.
;;;
;;; Code:
;;;
;;; Declarations for resources that can be provisioned.
;;;
(define-record-type* <environment-type> environment-type
make-environment-type
environment-type?
;; Interface to the environment type's deployment code. Each procedure
;; should take the same arguments as the top-level procedure of this file
;; that shares the same name. For example, 'machine-remote-eval' should be
;; of the form '(machine-remote-eval machine exp)'.
(machine-remote-eval environment-type-machine-remote-eval) ; procedure
(deploy-machine environment-type-deploy-machine) ; procedure
;; Metadata.
(name environment-type-name) ; symbol
(description environment-type-description ; string
(default #f))
(location environment-type-location ; <location>
(default (and=> (current-source-location)
source-properties->location))
(innate)))
;;;
;;; Declarations for machines in a deployment.
;;;
(define-record-type* <machine> machine
make-machine
machine?
this-machine
(system machine-system) ; <operating-system>
(environment machine-environment) ; symbol
(configuration machine-configuration ; configuration object
(default #f))) ; specific to environment
(define (machine-display-name machine)
"Return the host-name identifying MACHINE."
(operating-system-host-name (machine-system machine)))
(define (machine-remote-eval machine exp)
"Evaluate EXP, a gexp, on MACHINE. Ensure that all the elements EXP refers to
are built and deployed to MACHINE beforehand."
(let ((environment (machine-environment machine)))
((environment-type-machine-remote-eval environment) machine exp)))
(define (deploy-machine machine)
"Monadic procedure transferring the new system's OS closure to the remote
MACHINE, activating it on MACHINE and switching MACHINE to the new generation."
(let ((environment (machine-environment machine)))
((environment-type-deploy-machine environment) machine)))

369
gnu/machine/ssh.scm Normal file
View file

@ -0,0 +1,369 @@
;;; GNU Guix --- Functional package management for GNU
;;; 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 (gnu machine ssh)
#:use-module (gnu bootloader)
#:use-module (gnu machine)
#:autoload (gnu packages gnupg) (guile-gcrypt)
#:use-module (gnu services)
#:use-module (gnu services shepherd)
#:use-module (gnu system)
#:use-module (guix derivations)
#:use-module (guix gexp)
#:use-module (guix i18n)
#:use-module (guix modules)
#:use-module (guix monads)
#:use-module (guix records)
#:use-module (guix remote)
#:use-module (guix ssh)
#:use-module (guix store)
#:use-module (ice-9 match)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-35)
#:export (managed-host-environment-type
machine-ssh-configuration
machine-ssh-configuration?
machine-ssh-configuration
machine-ssh-configuration-host-name
machine-ssh-configuration-port
machine-ssh-configuration-user
machine-ssh-configuration-session))
;;; Commentary:
;;;
;;; This module implements remote evaluation and system deployment for
;;; machines that are accessable over SSH and have a known host-name. In the
;;; sense of the broader "machine" interface, we describe the environment for
;;; such machines as 'managed-host.
;;;
;;; Code:
;;;
;;; Parameters for the SSH client.
;;;
(define-record-type* <machine-ssh-configuration> machine-ssh-configuration
make-machine-ssh-configuration
machine-ssh-configuration?
this-machine-ssh-configuration
(host-name machine-ssh-configuration-host-name) ; string
(port machine-ssh-configuration-port ; integer
(default 22))
(user machine-ssh-configuration-user ; string
(default "root"))
(identity machine-ssh-configuration-identity ; path to a private key
(default #f))
(session machine-ssh-configuration-session ; session
(default #f)))
(define (machine-ssh-session machine)
"Return the SSH session that was given in MACHINE's configuration, or create
one from the configuration's parameters if one was not provided."
(maybe-raise-unsupported-configuration-error machine)
(let ((config (machine-configuration machine)))
(or (machine-ssh-configuration-session config)
(let ((host-name (machine-ssh-configuration-host-name config))
(user (machine-ssh-configuration-user config))
(port (machine-ssh-configuration-port config))
(identity (machine-ssh-configuration-identity config)))
(open-ssh-session host-name
#:user user
#:port port
#:identity identity)))))
;;;
;;; Remote evaluation.
;;;
(define (managed-host-remote-eval machine exp)
"Internal implementation of 'machine-remote-eval' for MACHINE instances with
an environment type of 'managed-host."
(maybe-raise-unsupported-configuration-error machine)
(remote-eval exp (machine-ssh-session machine)))
;;;
;;; System deployment.
;;;
(define (switch-to-system machine)
"Monadic procedure creating a new generation on MACHINE and execute the
activation script for the new system configuration."
(define (remote-exp drv script)
(with-extensions (list guile-gcrypt)
(with-imported-modules (source-module-closure '((guix config)
(guix profiles)
(guix utils)))
#~(begin
(use-modules (guix config)
(guix profiles)
(guix utils))
(define %system-profile
(string-append %state-directory "/profiles/system"))
(let* ((system #$drv)
(number (1+ (generation-number %system-profile)))
(generation (generation-file-name %system-profile number)))
(switch-symlinks generation system)
(switch-symlinks %system-profile generation)
;; The implementation of 'guix system reconfigure' saves the
;; load path and environment here. This is unnecessary here
;; because each invocation of 'remote-eval' runs in a distinct
;; Guile REPL.
(setenv "GUIX_NEW_SYSTEM" system)
;; The activation script may write to stdout, which confuses
;; 'remote-eval' when it attempts to read a result from the
;; remote REPL. We work around this by forcing the output to a
;; string.
(with-output-to-string
(lambda ()
(primitive-load #$script))))))))
(let* ((os (machine-system machine))
(script (operating-system-activation-script os)))
(mlet* %store-monad ((drv (operating-system-derivation os)))
(machine-remote-eval machine (remote-exp drv script)))))
;; XXX: Currently, this does NOT attempt to restart running services. This is
;; also the case with 'guix system reconfigure'.
;;
;; See <https://issues.guix.info/issue/33508>.
(define (upgrade-shepherd-services machine)
"Monadic procedure unloading and starting services on the remote as needed
to realize the MACHINE's system configuration."
(define target-services
;; Monadic expression evaluating to a list of (name output-path) pairs for
;; all of MACHINE's services.
(mapm %store-monad
(lambda (service)
(mlet %store-monad ((file ((compose lower-object
shepherd-service-file)
service)))
(return (list (shepherd-service-canonical-name service)
(derivation->output-path file)))))
(service-value
(fold-services (operating-system-services (machine-system machine))
#:target-type shepherd-root-service-type))))
(define (remote-exp target-services)
(with-imported-modules '((gnu services herd))
#~(begin
(use-modules (gnu services herd)
(srfi srfi-1))
(define running
(filter live-service-running (current-services)))
(define (essential? service)
;; Return #t if SERVICE is essential and should not be unloaded
;; under any circumstance.
(memq (first (live-service-provision service))
'(root shepherd)))
(define (obsolete? service)
;; Return #t if SERVICE can be safely unloaded.
(and (not (essential? service))
(every (lambda (requirements)
(not (memq (first (live-service-provision service))
requirements)))
(map live-service-requirement running))))
(define to-unload
(filter obsolete?
(remove (lambda (service)
(memq (first (live-service-provision service))
(map first '#$target-services)))
running)))
(define to-start
(remove (lambda (service-pair)
(memq (first service-pair)
(map (compose first live-service-provision)
running)))
'#$target-services))
;; Unload obsolete services.
(for-each (lambda (service)
(false-if-exception
(unload-service service)))
to-unload)
;; Load the service files for any new services and start them.
(load-services/safe (map second to-start))
(for-each start-service (map first to-start))
#t)))
(mlet %store-monad ((target-services target-services))
(machine-remote-eval machine (remote-exp target-services))))
(define (machine-boot-parameters machine)
"Monadic procedure returning a list of 'boot-parameters' for the generations
of MACHINE's system profile, ordered from most recent to oldest."
(define bootable-kernel-arguments
(@@ (gnu system) bootable-kernel-arguments))
(define remote-exp
(with-extensions (list guile-gcrypt)
(with-imported-modules (source-module-closure '((guix config)
(guix profiles)))
#~(begin
(use-modules (guix config)
(guix profiles)
(ice-9 textual-ports))
(define %system-profile
(string-append %state-directory "/profiles/system"))
(define (read-file path)
(call-with-input-file path
(lambda (port)
(get-string-all port))))
(map (lambda (generation)
(let* ((system-path (generation-file-name %system-profile
generation))
(boot-parameters-path (string-append system-path
"/parameters"))
(time (stat:mtime (lstat system-path))))
(list generation
system-path
time
(read-file boot-parameters-path))))
(reverse (generation-numbers %system-profile)))))))
(mlet* %store-monad ((generations (machine-remote-eval machine remote-exp)))
(return
(map (lambda (generation)
(match generation
((generation system-path time serialized-params)
(let* ((params (call-with-input-string serialized-params
read-boot-parameters))
(root (boot-parameters-root-device params))
(label (boot-parameters-label params)))
(boot-parameters
(inherit params)
(label
(string-append label " (#"
(number->string generation) ", "
(let ((time (make-time time-utc 0 time)))
(date->string (time-utc->date time)
"~Y-~m-~d ~H:~M"))
")"))
(kernel-arguments
(append (bootable-kernel-arguments system-path root)
(boot-parameters-kernel-arguments params))))))))
generations))))
(define (install-bootloader machine)
"Create a bootloader entry for the new system generation on MACHINE, and
configure the bootloader to boot that generation by default."
(define bootloader-installer-script
(@@ (guix scripts system) bootloader-installer-script))
(define (remote-exp installer bootcfg bootcfg-file)
(with-extensions (list guile-gcrypt)
(with-imported-modules (source-module-closure '((gnu build install)
(guix store)
(guix utils)))
#~(begin
(use-modules (gnu build install)
(guix store)
(guix utils))
(let* ((gc-root (string-append "/" %gc-roots-directory "/bootcfg"))
(temp-gc-root (string-append gc-root ".new")))
(switch-symlinks temp-gc-root gc-root)
(unless (false-if-exception
(begin
;; The implementation of 'guix system reconfigure'
;; saves the load path here. This is unnecessary here
;; because each invocation of 'remote-eval' runs in a
;; distinct Guile REPL.
(install-boot-config #$bootcfg #$bootcfg-file "/")
;; The installation script may write to stdout, which
;; confuses 'remote-eval' when it attempts to read a
;; result from the remote REPL. We work around this
;; by forcing the output to a string.
(with-output-to-string
(lambda ()
(primitive-load #$installer)))))
(delete-file temp-gc-root)
(error "failed to install bootloader"))
(rename-file temp-gc-root gc-root)
#t)))))
(mlet* %store-monad ((boot-parameters (machine-boot-parameters machine)))
(let* ((os (machine-system machine))
(bootloader ((compose bootloader-configuration-bootloader
operating-system-bootloader)
os))
(bootloader-target (bootloader-configuration-target
(operating-system-bootloader os)))
(installer (bootloader-installer-script
(bootloader-installer bootloader)
(bootloader-package bootloader)
bootloader-target
"/"))
(menu-entries (map boot-parameters->menu-entry boot-parameters))
(bootcfg (operating-system-bootcfg os menu-entries))
(bootcfg-file (bootloader-configuration-file bootloader)))
(machine-remote-eval machine (remote-exp installer bootcfg bootcfg-file)))))
(define (deploy-managed-host machine)
"Internal implementation of 'deploy-machine' for MACHINE instances with an
environment type of 'managed-host."
(maybe-raise-unsupported-configuration-error machine)
(mbegin %store-monad
(switch-to-system machine)
(upgrade-shepherd-services machine)
(install-bootloader machine)))
;;;
;;; Environment type.
;;;
(define managed-host-environment-type
(environment-type
(machine-remote-eval managed-host-remote-eval)
(deploy-machine deploy-managed-host)
(name 'managed-host-environment-type)
(description "Provisioning for machines that are accessable over SSH
and have a known host-name. This entails little more than maintaining an SSH
connection to the host.")))
(define (maybe-raise-unsupported-configuration-error machine)
"Raise an error if MACHINE's configuration is not an instance of
<machine-ssh-configuration>."
(let ((config (machine-configuration machine))
(environment (environment-type-name (machine-environment machine))))
(unless (and config (machine-ssh-configuration? config))
(raise (condition
(&message
(message (format #f (G_ "unsupported machine configuration '~a'
for environment of type '~a'")
config
environment))))))))

6
gnu/packages/bioinformatics.scm
View file

@ -14069,11 +14069,11 @@ choosing which reads pass the filter.")
;; <https://github.com/jts/nanopolish#installing-a-particular-release>. ;; <https://github.com/jts/nanopolish#installing-a-particular-release>.
;; Also, the differences between release and current version seem to be ;; Also, the differences between release and current version seem to be
;; significant. ;; significant.
(let ((commit "50e8b5cc62f9b46f5445f5c5e8c5ab7263ea6d9d") (let ((commit "6331dc4f15b9dfabb954ba3fae9d76b6c3ca6377")
(revision "1")) (revision "1"))
(package (package
(name "nanopolish") (name "nanopolish")
(version (git-version "0.10.2" revision commit)) (version (git-version "0.11.1" revision commit))
(source (source
(origin (origin
(method git-fetch) (method git-fetch)
@ -14083,7 +14083,7 @@ choosing which reads pass the filter.")
(recursive? #t))) (recursive? #t)))
(file-name (git-file-name name version)) (file-name (git-file-name name version))
(sha256 (sha256
(base32 "09j5gz57yr9i34a27vbl72i4g8syv2zzgmsfyjq02yshmnrvkjs6")) (base32 "15ikl3d37y49pwd7vx36xksgsqajhf24q7qqsnpl15dqqyy5qgbc"))
(modules '((guix build utils))) (modules '((guix build utils)))
(snippet (snippet
'(begin '(begin

4
gnu/packages/dictionaries.scm
View file

@ -218,7 +218,7 @@ It comes with a German-English dictionary with approximately 270,000 entries.")
(define-public grammalecte (define-public grammalecte
(package (package
(name "grammalecte") (name "grammalecte")
(version "1.1.1") (version "1.2")
(source (source
(origin (origin
(method url-fetch/zipbomb) (method url-fetch/zipbomb)
@ -226,7 +226,7 @@ It comes with a German-English dictionary with approximately 270,000 entries.")
"Grammalecte-fr-v" version ".zip")) "Grammalecte-fr-v" version ".zip"))
(sha256 (sha256
(base32 (base32
"1al4c3976wgxijxghxqb1banarj82hwad51kln87xj2r5kwcfm05")))) "0dwizai6w9yn617y7cnqdiwv77vn22p18s9sypypbl1bl695cnma"))))
(build-system python-build-system) (build-system python-build-system)
(home-page "https://grammalecte.net") (home-page "https://grammalecte.net")
(synopsis "French spelling and grammar checker") (synopsis "French spelling and grammar checker")

2
gnu/packages/gnome.scm
View file

@ -7232,7 +7232,7 @@ is suitable as a default application in a Desktop environment.")
("intltool" ,intltool) ("intltool" ,intltool)
("pkg-config" ,pkg-config))) ("pkg-config" ,pkg-config)))
(inputs (inputs
`(("gtksourceview" ,gtksourceview) `(("gtksourceview" ,gtksourceview-3)
("libsm" ,libsm))) ("libsm" ,libsm)))
(home-page "https://wiki.gnome.org/Apps/Xpad") (home-page "https://wiki.gnome.org/Apps/Xpad")
(synopsis "Virtual sticky note") (synopsis "Virtual sticky note")

2
gnu/packages/guile-xyz.scm
View file

@ -2348,7 +2348,7 @@ more expressive and flexible than the traditional @code{format} procedure.")
("perl" ,perl) ("perl" ,perl)
("pkg-config" ,pkg-config) ("pkg-config" ,pkg-config)
("texinfo" ,texinfo) ("texinfo" ,texinfo)
("texlive" ,texlive))) ("texlive" ,(texlive-union (list texlive-generic-epsf)))))
(propagated-inputs (propagated-inputs
`(("dbus-glib" ,dbus-glib) `(("dbus-glib" ,dbus-glib)
("guile" ,guile-2.2) ("guile" ,guile-2.2)

30
gnu/packages/image.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013, 2015, 2016 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2013, 2015, 2016 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2014, 2015, 2016 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2014, 2015, 2016 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2014, 2015 Alex Kost <alezost@gmail.com> ;;; Copyright © 2014, 2015 Alex Kost <alezost@gmail.com>
@ -1066,6 +1066,34 @@ and XMP metadata of images in various formats.")
;; <https://launchpad.net/ubuntu/precise/+source/exiv2/+copyright>. ;; <https://launchpad.net/ubuntu/precise/+source/exiv2/+copyright>.
(license license:gpl2+))) (license license:gpl2+)))
(define-public exiv2-0.26
(package
(inherit exiv2)
(version "0.26")
(source (origin
(method url-fetch)
(uri (list (string-append "https://www.exiv2.org/builds/exiv2-"
version "-trunk.tar.gz")
(string-append "https://www.exiv2.org/exiv2-"
version ".tar.gz")
(string-append "https://fossies.org/linux/misc/exiv2-"
version ".tar.gz")))
(patches (search-patches "exiv2-CVE-2017-14860.patch"
"exiv2-CVE-2017-14859-14862-14864.patch"))
(sha256
(base32
"1yza317qxd8yshvqnay164imm0ks7cvij8y8j86p1gqi1153qpn7"))))
(build-system gnu-build-system)
(arguments '(#:tests? #f)) ; no `check' target
(propagated-inputs
`(("expat" ,expat)
("zlib" ,zlib)))
(native-inputs
`(("intltool" ,intltool)))
;; People should rely on the newer version, so don't expose it.
(properties `((hidden? . #t)))))
(define-public devil (define-public devil
(package (package
(name "devil") (name "devil")

501
gnu/packages/lisp.scm
View file

@ -5863,11 +5863,12 @@ and @code{kqueue(2)}), a pathname library and file-system utilities.")
`(("iolib.asdf" ,sbcl-iolib.asdf) `(("iolib.asdf" ,sbcl-iolib.asdf)
("iolib.conf" ,sbcl-iolib.conf) ("iolib.conf" ,sbcl-iolib.conf)
("iolib.grovel" ,sbcl-iolib.grovel) ("iolib.grovel" ,sbcl-iolib.grovel)
("iolib.base", sbcl-iolib.base) ("iolib.base" ,sbcl-iolib.base)
("bordeaux-threads", sbcl-bordeaux-threads) ("bordeaux-threads" ,sbcl-bordeaux-threads)
("idna", sbcl-idna) ("idna" ,sbcl-idna)
("swap-bytes", sbcl-swap-bytes) ("swap-bytes" ,sbcl-swap-bytes)
("libfixposix", libfixposix))) ("libfixposix" ,libfixposix)
("cffi" ,sbcl-cffi)))
(native-inputs (native-inputs
`(("fiveam" ,sbcl-fiveam))) `(("fiveam" ,sbcl-fiveam)))
(arguments (arguments
@ -5953,12 +5954,12 @@ floating point values to IEEE 754 binary representation.")
(name "sbcl-closure-common") (name "sbcl-closure-common")
(build-system asdf-build-system/sbcl) (build-system asdf-build-system/sbcl)
(version (git-version "20101006" revision commit)) (version (git-version "20101006" revision commit))
(home-page "https://github.com/sharplispers/closure-common") (home-page "https://common-lisp.net/project/cxml/")
(source (source
(origin (origin
(method git-fetch) (method git-fetch)
(uri (git-reference (uri (git-reference
(url home-page) (url "https://github.com/sharplispers/closure-common")
(commit commit))) (commit commit)))
(file-name (git-file-name name version)) (file-name (git-file-name name version))
(sha256 (sha256
@ -5973,6 +5974,111 @@ Closure is a reference to the web browser it was originally written for.")
;; TODO: License? ;; TODO: License?
(license #f)))) (license #f))))
(define-public sbcl-cxml+xml
(let ((commit "00b22bf4c4cf11c993d5866fae284f95ab18e6bf")
(revision "1"))
(package
(name "sbcl-cxml+xml")
(build-system asdf-build-system/sbcl)
(version (git-version "0.0.0" revision commit))
(home-page "https://common-lisp.net/project/cxml/")
(source
(origin
(method git-fetch)
(uri (git-reference
(url "https://github.com/sharplispers/cxml")
(commit commit)))
(file-name (git-file-name name version))
(sha256
(base32
"13kif7rf3gqdycsk9zq0d7y0g9y81krkl0z87k0p2fkbjfgrph37"))))
(inputs
`(("closure-common" ,sbcl-closure-common)
("puri" ,sbcl-puri)
("trivial-gray-streams" ,sbcl-trivial-gray-streams)))
(arguments
`(#:asd-file "cxml.asd"
#:asd-system-name "cxml/xml"))
(synopsis "Common Lisp XML parser")
(description "CXML implements a namespace-aware, validating XML 1.0
parser as well as the DOM Level 2 Core interfaces. Two parser interfaces are
offered, one SAX-like, the other similar to StAX.")
(license license:llgpl))))
(define sbcl-cxml+dom
(package
(inherit sbcl-cxml+xml)
(name "sbcl-cxml+dom")
(inputs
`(("closure-common" ,sbcl-closure-common)
("puri" ,sbcl-puri)
("cxml+xml" ,sbcl-cxml+xml)))
(arguments
`(#:asd-file "cxml.asd"
#:asd-system-name "cxml/dom"))))
(define sbcl-cxml+klacks
(package
(inherit sbcl-cxml+xml)
(name "sbcl-cxml+klacks")
(inputs
`(("closure-common" ,sbcl-closure-common)
("puri" ,sbcl-puri)
("cxml+xml" ,sbcl-cxml+xml)))
(arguments
`(#:asd-file "cxml.asd"
#:asd-system-name "cxml/klacks"))))
(define sbcl-cxml+test
(package
(inherit sbcl-cxml+xml)
(name "sbcl-cxml+test")
(inputs
`(("closure-common" ,sbcl-closure-common)
("puri" ,sbcl-puri)
("cxml+xml" ,sbcl-cxml+xml)))
(arguments
`(#:asd-file "cxml.asd"
#:asd-system-name "cxml/test"))))
(define-public sbcl-cxml
(package
(inherit sbcl-cxml+xml)
(name "sbcl-cxml")
(inputs
`(("closure-common" ,sbcl-closure-common)
("puri" ,sbcl-puri)
("trivial-gray-streams" ,sbcl-trivial-gray-streams)
("cxml+dom" ,sbcl-cxml+dom)
("cxml+klacks" ,sbcl-cxml+klacks)
("cxml+test" ,sbcl-cxml+test)))
(arguments
`(#:asd-file "cxml.asd"
#:asd-system-name "cxml"
#:phases
(modify-phases %standard-phases
(add-after 'build 'install-dtd
(lambda* (#:key outputs #:allow-other-keys)
(install-file "catalog.dtd"
(string-append
(assoc-ref outputs "out")
"/lib/" (%lisp-type)))))
(add-after 'create-asd 'remove-component
;; XXX: The original .asd has no components, but our build system
;; creates an entry nonetheless. We need to remove it for the
;; generated .asd to load properly. See trivia.trivial for a
;; similar problem.
(lambda* (#:key outputs #:allow-other-keys)
(let* ((out (assoc-ref outputs "out"))
(asd (string-append out "/lib/sbcl/cxml.asd")))
(substitute* asd
((" :components
")
""))
(substitute* asd
((" *\\(\\(:compiled-file \"cxml--system\"\\)\\)")
""))))))))))
(define-public sbcl-cl-reexport (define-public sbcl-cl-reexport
(let ((commit "312f3661bbe187b5f28536cd7ec2956e91366c3b") (let ((commit "312f3661bbe187b5f28536cd7ec2956e91366c3b")
(revision "1")) (revision "1"))
@ -6092,3 +6198,384 @@ cookie headers, cookie creation, cookie jar creation and more.")
(description "Dexador is yet another HTTP client for Common Lisp with (description "Dexador is yet another HTTP client for Common Lisp with
neat APIs and connection-pooling. It is meant to supersede Drakma.") neat APIs and connection-pooling. It is meant to supersede Drakma.")
(license license:expat)))) (license license:expat))))
(define-public sbcl-lisp-namespace
(let ((commit "28107cafe34e4c1c67490fde60c7f92dc610b2e0")
(revision "1"))
(package
(name "sbcl-lisp-namespace")
(build-system asdf-build-system/sbcl)
(version (git-version "0.1" revision commit))
(home-page "https://github.com/guicho271828/lisp-namespace")
(source
(origin
(method git-fetch)
(uri (git-reference
(url home-page)
(commit commit)))
(file-name (git-file-name name version))
(sha256
(base32
"1jw2wykp06z2afb9nm1lgfzll5cjlj36pnknjx614057zkkxq4iy"))))
(inputs
`(("alexandria" ,sbcl-alexandria)))
(native-inputs
`(("fiveam" ,sbcl-fiveam)))
(arguments
`(#:test-asd-file "lisp-namespace.test.asd"
;; XXX: Component LISP-NAMESPACE-ASD::LISP-NAMESPACE.TEST not found
#:tests? #f))
(synopsis "LISP-N, or extensible namespaces in Common Lisp")
(description "Common Lisp already has major 2 namespaces, function
namespace and value namespace (or variable namespace), but there are actually
more — e.g., class namespace.
This library offers macros to deal with symbols from any namespace.")
(license license:llgpl))))
(define-public sbcl-trivial-cltl2
(let ((commit "8eec8407df833e8f27df8a388bc10913f16d9e83")
(revision "1"))
(package
(name "sbcl-trivial-cltl2")
(build-system asdf-build-system/sbcl)
(version (git-version "0.1.1" revision commit))
(home-page "https://github.com/Zulu-Inuoe/trivial-cltl2")
(source
(origin
(method git-fetch)
(uri (git-reference
(url home-page)
(commit commit)))
(file-name (git-file-name name version))
(sha256
(base32
"1dyyxz17vqv8hlfwq287gl8xxbvcnq798ajb7p5jdjz91wqf4bgk"))))
(synopsis "Simple CLtL2 compatibility layer for Common Lisp")
(description "This library is a portable compatibility layer around
\"Common Lisp the Language, 2nd
Edition\" (@url{https://www.cs.cmu.edu/Groups/AI/html/cltl/clm/node102.html})
and it exports symbols from implementation-specific packages.")
(license license:llgpl))))
(define-public sbcl-introspect-environment
(let ((commit "fff42f8f8fd0d99db5ad6c5812e53de7d660020b")
(revision "1"))
(package
(name "sbcl-introspect-environment")
(build-system asdf-build-system/sbcl)
(version (git-version "0.1" revision commit))
(home-page "https://github.com/Bike/introspect-environment")
(source
(origin
(method git-fetch)
(uri (git-reference
(url home-page)
(commit commit)))
(file-name (git-file-name name version))
(sha256
(base32
"1i305n0wfmpac63ni4i3vixnnkl8daw5ncxy0k3dv92krgx6qzhp"))))
(native-inputs
`(("fiveam" ,sbcl-fiveam)))
(synopsis "Common Lisp environment introspection portability layer")
(description "This library is a small interface to portable but
nonstandard introspection of Common Lisp environments. It is intended to
allow a bit more compile-time introspection of environments in Common Lisp.
Quite a bit of information is available at the time a macro or compiler-macro
runs; inlining info, type declarations, that sort of thing. This information
is all standard - any Common Lisp program can @code{(declare (integer x))} and
such.
This info ought to be accessible through the standard @code{&environment}
parameters, but it is not. Several implementations keep the information for
their own purposes but do not make it available to user programs, because
there is no standard mechanism to do so.
This library uses implementation-specific hooks to make information available
to users. This is currently supported on SBCL, CCL, and CMUCL. Other
implementations have implementations of the functions that do as much as they
can and/or provide reasonable defaults.")
(license license:wtfpl2))))
(define-public sbcl-type-i
(let ((commit "dea233f45f94064105ec09f0767de338f67dcbe2")
(revision "1"))
(package
(name "sbcl-type-i")
(build-system asdf-build-system/sbcl)
(version (git-version "0.1" revision commit))
(home-page "https://github.com/guicho271828/type-i")
(source
(origin
(method git-fetch)
(uri (git-reference
(url home-page)
(commit commit)))
(file-name (git-file-name name version))
(sha256
(base32
"039g5pbrhh65s0bhr9314gmd2nwc2y5lp2377c5qrc2lxky89qs3"))))
(inputs
`(("alexandria" ,sbcl-alexandria)
("introspect-environment" ,sbcl-introspect-environment)
("trivia.trivial" ,sbcl-trivia.trivial)))
(native-inputs
`(("fiveam" ,sbcl-fiveam)))
(arguments
`(#:test-asd-file "type-i.test.asd"))
(synopsis "Type inference utility on unary predicates for Common Lisp")
(description "This library tries to provide a way to detect what kind of
type the given predicate is trying to check. This is different from inferring
the return type of a function.")
(license license:llgpl))))
(define-public sbcl-optima
(let ((commit "373b245b928c1a5cce91a6cb5bfe5dd77eb36195")
(revision "1"))
(package
(name "sbcl-optima")
(build-system asdf-build-system/sbcl)
(version (git-version "0.1" revision commit))
(home-page "https://github.com/m2ym/optima")
(source
(origin
(method git-fetch)
(uri (git-reference
(url home-page)
(commit commit)))
(file-name (git-file-name name version))
(sha256
(base32
"1yw4ymq7ms89342kkvb3aqxgv0w38m9kd8ikdqxxzyybnkjhndal"))))
(inputs
`(("alexandria" ,sbcl-alexandria)
("closer-mop" ,sbcl-closer-mop)))
(native-inputs
`(("eos" ,sbcl-eos)))
(arguments
;; XXX: Circular dependencies: tests depend on optima.ppcre which depends on optima.
`(#:tests? #f
#:test-asd-file "optima.test.asd"))
(synopsis "Optimized pattern matching library for Common Lisp")
(description "Optima is a fast pattern matching library which uses
optimizing techniques widely used in the functional programming world.")
(license license:expat))))
(define-public sbcl-fare-quasiquote
(package
(name "sbcl-fare-quasiquote")
(build-system asdf-build-system/sbcl)
(version "20171130")
(home-page "http://common-lisp.net/project/fare-quasiquote")
(source
(origin
(method url-fetch)
(uri (string-append "http://beta.quicklisp.org/archive/fare-quasiquote/"
(date->string (string->date version "~Y~m~d") "~Y-~m-~d")
"/fare-quasiquote-"
version
"-git.tgz"))
(sha256
(base32
"00brmh7ndsi0c97nibi8cy10j3l4gmkyrfrr5jr5lzkfb7ngyfqa"))))
(inputs
`(("fare-utils" ,sbcl-fare-utils)))
(arguments
;; XXX: Circular dependencies: Tests depend on subsystems, which depend on the main systems.
`(#:tests? #f
#:phases
(modify-phases %standard-phases
;; XXX: Require 1.0.0 version of fare-utils, and we package some
;; commits after 1.0.0.5, but ASDF fails to read the
;; "-REVISION-COMMIT" part generated by Guix.
(add-after 'unpack 'patch-requirement
(lambda _
(substitute* "fare-quasiquote.asd"
(("\\(:version \"fare-utils\" \"1.0.0\"\\)") "\"fare-utils\"")))))))
(synopsis "Pattern-matching friendly implementation of quasiquote for Common Lisp")
(description "The main purpose of this n+2nd reimplementation of
quasiquote is enable matching of quasiquoted patterns, using Optima or
Trivia.")
(license license:expat)))
(define-public sbcl-fare-quasiquote-readtable
(package
(inherit sbcl-fare-quasiquote)
(name "sbcl-fare-quasiquote-readtable")
(inputs
`(("fare-quasiquote" ,sbcl-fare-quasiquote)
("named-readtables" ,sbcl-named-readtables)))
(description "The main purpose of this n+2nd reimplementation of
quasiquote is enable matching of quasiquoted patterns, using Optima or
Trivia.
This packages uses fare-quasiquote with named-readtable.")))
(define-public sbcl-trivia.level0
(let ((commit "902e0c65602bbfe96ae82e679330b3771ddc7603")
(revision "1"))
(package
(name "sbcl-trivia.level0")
(build-system asdf-build-system/sbcl)
(version (git-version "0.0.0" revision commit))
(home-page "https://github.com/guicho271828/trivia")
(source
(origin
(method git-fetch)
(uri (git-reference
(url home-page)
(commit commit)))
(file-name (git-file-name name version))
(sha256
(base32
"11qbab30qqnfy9mx3x9fvgcw1jbvh1qn2cqv3p8xdn2m8981jvhr"))))
(inputs
`(("alexandria" ,sbcl-alexandria)))
(synopsis "Pattern matching in Common Lisp")
(description "Trivia is a pattern matching compiler that is compatible
with Optima, another pattern matching library for Common Lisp. It is meant to
be faster and more extensible than Optima.")
(license license:llgpl))))
(define-public sbcl-trivia.level1
(package
(inherit sbcl-trivia.level0)
(name "sbcl-trivia.level1")
(inputs
`(("trivia.level0" ,sbcl-trivia.level0)))
(description "Trivia is a pattern matching compiler that is compatible
with Optima, another pattern matching library for Common Lisp. It is meant to
be faster and more extensible than Optima.
This system contains the core patterns of Trivia.")))
(define-public sbcl-trivia.level2
(package
(inherit sbcl-trivia.level0)
(name "sbcl-trivia.level2")
(inputs
`(("trivia.level1" ,sbcl-trivia.level1)
("lisp-namespace" ,sbcl-lisp-namespace)
("trivial-cltl2" ,sbcl-trivial-cltl2)
("closer-mop" ,sbcl-closer-mop)))
(description "Trivia is a pattern matching compiler that is compatible
with Optima, another pattern matching library for Common Lisp. It is meant to
be faster and more extensible than Optima.
This system contains a non-optimized pattern matcher compatible with Optima,
with extensible optimizer interface.")))
(define-public sbcl-trivia.trivial
(package
(inherit sbcl-trivia.level0)
(name "sbcl-trivia.trivial")
(inputs
`(("trivia.level2" ,sbcl-trivia.level2)))
(arguments
`(#:phases
(modify-phases %standard-phases
(replace 'create-asd-file
(lambda* (#:key outputs inputs #:allow-other-keys)
(let* ((out (assoc-ref outputs "out"))
(lib (string-append out "/lib/" (%lisp-type)))
(level2 (assoc-ref inputs "trivia.level2")))
(mkdir-p lib)
(install-file "trivia.trivial.asd" lib)
;; XXX: This .asd does not have any component and the build
;; system fails to work in this case. We should update the
;; build system to handle component-less .asd.
;; TODO: How do we append to file in Guile? It seems that
;; (open-file ... "a") gets a "Permission denied".
(substitute* (string-append lib "/trivia.trivial.asd")
(("\"\\)")
(string-append "\")
(progn (asdf/source-registry:ensure-source-registry)
(setf (gethash
\"trivia.level2\"
asdf/source-registry:*source-registry*)
#p\""
level2
"/share/common-lisp/sbcl-bundle-systems/trivia.level2.asd\"))")))))))))
(description "Trivia is a pattern matching compiler that is compatible
with Optima, another pattern matching library for Common Lisp. It is meant to
be faster and more extensible than Optima.
This system contains the base level system of Trivia with a trivial optimizer.")))
(define-public sbcl-trivia.balland2006
(package
(inherit sbcl-trivia.level0)
(name "sbcl-trivia.balland2006")
(inputs
`(("trivia.trivial" ,sbcl-trivia.trivial)
("iterate" ,sbcl-iterate)
("type-i" ,sbcl-type-i)
("alexandria" ,sbcl-alexandria)))
(arguments
;; Tests are done in trivia itself.
`(#:tests? #f))
(description "Trivia is a pattern matching compiler that is compatible
with Optima, another pattern matching library for Common Lisp. It is meant to
be faster and more extensible than Optima.
This system contains the base level system of Trivia with a trivial optimizer.")))
(define-public sbcl-trivia.ppcre
(package
(inherit sbcl-trivia.level0)
(name "sbcl-trivia.ppcre")
(inputs
`(("trivia.trivial" ,sbcl-trivia.trivial)
("cl-ppcre" ,sbcl-cl-ppcre)))
(description "Trivia is a pattern matching compiler that is compatible
with Optima, another pattern matching library for Common Lisp. It is meant to
be faster and more extensible than Optima.
This system contains the PPCRE extention.")))
(define-public sbcl-trivia.quasiquote
(package
(inherit sbcl-trivia.level0)
(name "sbcl-trivia.quasiquote")
(inputs
`(("trivia.trivial" ,sbcl-trivia.trivial)
("fare-quasiquote" ,sbcl-fare-quasiquote)
("fare-quasiquote-readtable" ,sbcl-fare-quasiquote-readtable)))
(description "Trivia is a pattern matching compiler that is compatible
with Optima, another pattern matching library for Common Lisp. It is meant to
be faster and more extensible than Optima.
This system contains the fare-quasiquote extension.")))
(define-public sbcl-trivia.cffi
(package
(inherit sbcl-trivia.level0)
(name "sbcl-trivia.cffi")
(inputs
`(("cffi" ,sbcl-cffi)
("trivia.trivial" ,sbcl-trivia.trivial)))
(description "Trivia is a pattern matching compiler that is compatible
with Optima, another pattern matching library for Common Lisp. It is meant to
be faster and more extensible than Optima.
This system contains the CFFI foreign slot access extension.")))
(define-public sbcl-trivia
(package
(inherit sbcl-trivia.level0)
(name "sbcl-trivia")
(inputs
`(("trivia.balland2006" ,sbcl-trivia.balland2006)))
(native-inputs
`(("fiveam" ,sbcl-fiveam)
("trivia.ppcre" ,sbcl-trivia.ppcre)
("trivia.quasiquote" ,sbcl-trivia.quasiquote)
("trivia.cffi" ,sbcl-trivia.cffi)
("optima" ,sbcl-optima)))
(arguments
`(#:test-asd-file "trivia.test.asd"))
(description "Trivia is a pattern matching compiler that is compatible
with Optima, another pattern matching library for Common Lisp. It is meant to
be faster and more extensible than Optima.")))

71
gnu/packages/logo.scm Normal file
View file

@ -0,0 +1,71 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; 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 (gnu packages logo)
#:use-module (gnu packages qt)
#:use-module ((guix licenses) #:prefix license:)
#:use-module (guix download)
#:use-module (guix packages)
#:use-module (guix build-system gnu))
(define-public qlogo
(package
(name "qlogo")
(version "0.92")
(source
(origin
(method url-fetch)
(uri (string-append "https://qlogo.org/assets/sources/QLogo-"
version ".tgz"))
(sha256
(base32
"0cpyj1ji6hjy7zzz05672f0j6fr0mwpc1y3sq36hhkv2fkpidw22"))))
(build-system gnu-build-system)
(inputs
`(("qtbase" ,qtbase)))
(arguments
`(#:phases
(modify-phases %standard-phases
(replace 'configure
(lambda* (#:key outputs #:allow-other-keys)
(substitute* "QLogo.pro"
(("target\\.path = /usr/bin")
(string-append "target.path = "
(assoc-ref outputs "out") "/bin")))
(invoke "qmake" "QLogo.pro")))
;; The check phase rebuilds the source for tests. So, it needs to be
;; run after the install phase has installed the outputs of the build
;; phase.
(delete 'check)
(add-after 'install 'check
(lambda _
;; Clean files created by the build phase.
(invoke "make" "clean")
;; QLogo tries to create its "dribble file" in the home
;; directory. So, set HOME.
(setenv "HOME" "/tmp")
;; Build and run tests.
(invoke "qmake" "TestQLogo.pro")
(invoke "make" "-j" (number->string (parallel-job-count)))
(invoke "./testqlogo"))))))
(home-page "https://qlogo.org")
(synopsis "Logo interpreter using Qt and OpenGL")
(description "QLogo is an interpreter for the Logo language written in C++
using Qt and OpenGL. Specifically, it mimics, as reasonably as possible, the
UCBLogo interpreter.")
(license license:gpl2+)))

4
gnu/packages/patchutils.scm
View file

@ -307,7 +307,7 @@ you to figure out what is going on in that merge you keep avoiding.")
(define-public patchwork (define-public patchwork
(package (package
(name "patchwork") (name "patchwork")
(version "2.1.2") (version "2.1.4")
(source (origin (source (origin
(method git-fetch) (method git-fetch)
(uri (git-reference (uri (git-reference
@ -316,7 +316,7 @@ you to figure out what is going on in that merge you keep avoiding.")
(file-name (git-file-name name version)) (file-name (git-file-name name version))
(sha256 (sha256
(base32 (base32
"06ng5pv6744w98zkyfm0ldkmpdgnsql3gbbbh6awq61sr2ndr3qw")))) "0zi1hcqb0pi2diyznbv0c1631qk4rx02zl8ghyrr59g3ljlyr18y"))))
(build-system python-build-system) (build-system python-build-system)
(arguments (arguments
`(;; TODO: Tests require a running database `(;; TODO: Tests require a running database

8
gnu/packages/photo.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014, 2015, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2015 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2015, 2017 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2015, 2017 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2016, 2017, 2018 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2016, 2017, 2018 Efraim Flashner <efraim@flashner.co.il>
@ -70,14 +70,14 @@
(define-public libraw (define-public libraw
(package (package
(name "libraw") (name "libraw")
(version "0.19.2") (version "0.19.3")
(source (origin (source (origin
(method url-fetch) (method url-fetch)
(uri (string-append "https://www.libraw.org/data/LibRaw-" (uri (string-append "https://www.libraw.org/data/LibRaw-"
version ".tar.gz")) version ".tar.gz"))
(sha256 (sha256
(base32 (base32
"0i4nhjm5556xgn966x0i503ygk2wafq6z83kg0lisacjjab4f3a0")))) "0xs1qb6pcvc4c43fy5xi3nkqxcif77gakkw99irf0fc5iccdd5px"))))
(build-system gnu-build-system) (build-system gnu-build-system)
(native-inputs (native-inputs
`(("pkg-config" ,pkg-config))) `(("pkg-config" ,pkg-config)))
@ -445,7 +445,7 @@ and enhance them.")
(inputs (inputs
`(("boost" ,boost) `(("boost" ,boost)
("enblend-enfuse" ,enblend-enfuse) ("enblend-enfuse" ,enblend-enfuse)
("exiv2" ,exiv2) ("exiv2" ,exiv2-0.26)
("fftw" ,fftw) ("fftw" ,fftw)
("flann" ,flann) ("flann" ,flann)
("freeglut" ,freeglut) ("freeglut" ,freeglut)

58
gnu/packages/pulseaudio.scm
View file

@ -8,6 +8,7 @@
;;; Copyright © 2017 Stefan Reichör <stefan@xsteve.at> ;;; Copyright © 2017 Stefan Reichör <stefan@xsteve.at>
;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr> ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2018 Pierre Langlois <pierre.langlois@gmx.com> ;;; Copyright © 2018 Pierre Langlois <pierre.langlois@gmx.com>
;;; Copyright © 2019 Alex Griffin <a@ajgrf.com>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -27,6 +28,7 @@
(define-module (gnu packages pulseaudio) (define-module (gnu packages pulseaudio)
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix download) #:use-module (guix download)
#:use-module (guix git-download)
#:use-module ((guix licenses) #:prefix l:) #:use-module ((guix licenses) #:prefix l:)
#:use-module (guix build-system gnu) #:use-module (guix build-system gnu)
#:use-module (guix build-system python) #:use-module (guix build-system python)
@ -43,6 +45,10 @@
#:use-module (gnu packages web) #:use-module (gnu packages web)
#:use-module (gnu packages linux) #:use-module (gnu packages linux)
#:use-module (gnu packages m4) #:use-module (gnu packages m4)
#:use-module (gnu packages protobuf)
#:use-module (gnu packages python)
#:use-module (gnu packages python-xyz)
#:use-module (gnu packages python-web)
#:use-module (gnu packages pkg-config) #:use-module (gnu packages pkg-config)
#:use-module (gnu packages xiph)) #:use-module (gnu packages xiph))
@ -303,3 +309,55 @@ sinks.")
(description "Pulsemixer is a PulseAudio mixer with command-line and (description "Pulsemixer is a PulseAudio mixer with command-line and
curses-style interfaces.") curses-style interfaces.")
(license l:expat))) (license l:expat)))
(define-public pulseaudio-dlna
;; The last release was in 2016; use a more recent commit.
(let ((commit "4472928dd23f274193f14289f59daec411023ab0")
(revision "1"))
(package
(name "pulseaudio-dlna")
(version (git-version "0.5.2" revision commit))
(source
(origin
(method git-fetch)
(uri (git-reference
(url "https://github.com/masmu/pulseaudio-dlna.git")
(commit commit)))
(file-name (git-file-name name version))
(sha256
(base32
"1dfn7036vrq49kxv4an7rayypnm5dlawsf02pfsldw877hzdamqk"))))
(build-system python-build-system)
(arguments `(#:python ,python-2))
(inputs
`(("python2-chardet" ,python2-chardet)
("python2-dbus" ,python2-dbus)
("python2-docopt" ,python2-docopt)
("python2-futures" ,python2-futures)
("python2-pygobject" ,python2-pygobject)
("python2-lxml" ,python2-lxml)
("python2-netifaces" ,python2-netifaces)
("python2-notify2" ,python2-notify2)
("python2-protobuf" ,python2-protobuf)
("python2-psutil" ,python2-psutil)
("python2-requests" ,python2-requests)
("python2-pyroute2" ,python2-pyroute2)
("python2-setproctitle" ,python2-setproctitle)
("python2-zeroconf" ,python2-zeroconf)))
(home-page "https://github.com/masmu/pulseaudio-dlna")
(synopsis "Stream audio to DLNA/UPnP and Chromecast devices")
(description "This lightweight streaming server brings DLNA/UPnP and
Chromecast support to PulseAudio. It can stream your current PulseAudio
playback to different UPnP devices (UPnP Media Renderers, including Sonos
devices and some Smart TVs) or Chromecasts in your network. You should also
install one or more of the following packages alongside pulseaudio-dlna:
@itemize
@item ffmpeg - transcoding support for multiple codecs
@item flac - FLAC transcoding support
@item lame - MP3 transcoding support
@item opus-tools - Opus transcoding support
@item sox - WAV transcoding support
@item vorbis-tools - Vorbis transcoding support
@end itemize")
(license l:gpl3+))))

118
gnu/packages/python-xyz.scm
View file

@ -61,6 +61,7 @@
;;; Copyright © 2019 Sam <smbaines8@gmail.com> ;;; Copyright © 2019 Sam <smbaines8@gmail.com>
;;; Copyright © 2019 Jack Hill <jackhill@jackhill.us> ;;; Copyright © 2019 Jack Hill <jackhill@jackhill.us>
;;; Copyright © 2019 Guillaume Le Vaillant <glv@posteo.net> ;;; Copyright © 2019 Guillaume Le Vaillant <glv@posteo.net>
;;; Copyright © 2019 Alex Griffin <a@ajgrf.com>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -660,14 +661,14 @@ other machines, such as over the network.")
(define-public python-setuptools (define-public python-setuptools
(package (package
(name "python-setuptools") (name "python-setuptools")
(version "40.0.0") (version "41.0.1")
(source (source
(origin (origin
(method url-fetch) (method url-fetch)
(uri (pypi-uri "setuptools" version ".zip")) (uri (pypi-uri "setuptools" version ".zip"))
(sha256 (sha256
(base32 (base32
"0pq116lr14gnc62v76nk0npkm6krb2mpp7p9ab369zgv4n7dnah1")) "04sns22y2hhsrwfy1mha2lgslvpjsjsz8xws7h2rh5a7ylkd28m2"))
(modules '((guix build utils))) (modules '((guix build utils)))
(snippet (snippet
'(begin '(begin
@ -4331,19 +4332,18 @@ services for your Python modules and applications.")
(define-public python-olefile (define-public python-olefile
(package (package
(name "python-olefile") (name "python-olefile")
(version "0.45.1") (version "0.46")
(source (source
(origin (origin
(method url-fetch) (method url-fetch)
(uri (string-append "https://github.com/decalage2/olefile/archive/v" (uri (string-append "https://github.com/decalage2/olefile/releases/"
version ".tar.gz")) "download/v" version "/olefile-" version ".tar.gz"))
(file-name (string-append name "-" version ".tar.gz")) (file-name (string-append name "-" version ".tar.gz"))
(sha256 (sha256
(base32 (base32
"18ai19zwagm6nli14k8bii31ipbab2rp7plrvsm6gmfql551a8ai")))) "1kjxh4gr651hpqkjfv89cfzr40hyvf3vjlda7mifiail83j7j07m"))))
(build-system python-build-system) (build-system python-build-system)
(home-page (home-page "https://www.decalage.info/python/olefileio")
"https://www.decalage.info/python/olefileio")
(synopsis "Read and write Microsoft OLE2 files.") (synopsis "Read and write Microsoft OLE2 files.")
(description (description
"@code{olefile} can parse, read and write Microsoft OLE2 files (Structured "@code{olefile} can parse, read and write Microsoft OLE2 files (Structured
@ -5632,6 +5632,33 @@ implementation of D-Bus.")
;; "ValueError: unichr() arg not in range(0x10000) (narrow Python build)" ;; "ValueError: unichr() arg not in range(0x10000) (narrow Python build)"
(arguments `(#:tests? #f)))) (arguments `(#:tests? #f))))
(define-public python-notify2
(package
(name "python-notify2")
(version "0.3.1")
(source
(origin
(method url-fetch)
(uri (pypi-uri "notify2" version))
(sha256
(base32
"0z8rrv9rsg1r2qgh2dxj3dfj5xnki98kgi3w839kqby4a26i1yik"))))
(build-system python-build-system)
(arguments `(#:tests? #f)) ; tests depend on system state
(native-inputs
`(("python-dbus" ,python-dbus)))
(home-page "https://bitbucket.org/takluyver/pynotify2")
(synopsis "Python interface to D-Bus notifications")
(description
"Pynotify2 provides a Python interface for sending D-Bus notifications.
It is a reimplementation of pynotify in pure Python, and an alternative to
the GObject Introspection bindings to libnotify for non-GTK applications.")
(license (list license:bsd-2
license:lgpl2.1+))))
(define-public python2-notify2
(package-with-python2 python-notify2))
(define-public python-lxml (define-public python-lxml
(package (package
(name "python-lxml") (name "python-lxml")
@ -5706,14 +5733,14 @@ converts incoming documents to Unicode and outgoing documents to UTF-8.")
(define-public python-soupsieve (define-public python-soupsieve
(package (package
(name "python-soupsieve") (name "python-soupsieve")
(version "1.9.1") (version "1.9.2")
(source (source
(origin (origin
(method url-fetch) (method url-fetch)
(uri (pypi-uri "soupsieve" version)) (uri (pypi-uri "soupsieve" version))
(sha256 (sha256
(base32 (base32
"1jnzkiwmjl6yvqckc9mf689g87b6yz07sv868hap2aa5arggy3mj")))) "0in9rc9q3h8w5b4qf7kvl3qxcvw6vrz35ckblchgf70hm6pg3dbj"))))
(build-system python-build-system) (build-system python-build-system)
(arguments `(#:tests? #f)) (arguments `(#:tests? #f))
;;XXX: 2 tests fail currently despite claming they were to be ;;XXX: 2 tests fail currently despite claming they were to be
@ -6904,6 +6931,41 @@ and MAC network addresses.")
(define-public python2-netaddr (define-public python2-netaddr
(package-with-python2 python-netaddr)) (package-with-python2 python-netaddr))
(define-public python2-pyroute2
(package
(name "python2-pyroute2")
(version "0.5.6")
(source
(origin
(method url-fetch)
(uri (pypi-uri "pyroute2" version))
(sha256
(base32
"1gmz4r1w0yzj6fjjypnalmfyy0lnfznydyn62gi3wk50j5hhxbny"))))
(build-system python-build-system)
(arguments
`(#:python ,python-2)) ;Python 3.x is not supported
(home-page "https://github.com/svinota/pyroute2")
(synopsis "Python netlink library")
(description
"Pyroute2 is a pure Python netlink library with minimal dependencies.
Supported netlink families and protocols include:
@itemize
@item rtnl, network settings - addresses, routes, traffic controls
@item nfnetlink - netfilter API: ipset, nftables, ...
@item ipq - simplest userspace packet filtering, iptables QUEUE target
@item devlink - manage and monitor devlink-enabled hardware
@item generic - generic netlink families
@itemize
@item nl80211 - wireless functions API (basic support)
@item taskstats - extended process statistics
@item acpi_events - ACPI events monitoring
@item thermal_events - thermal events monitoring
@item VFS_DQUOT - disk quota events monitoring
@end itemize
@end itemize")
(license license:gpl2+)))
(define-public python-wrapt (define-public python-wrapt
(package (package
(name "python-wrapt") (name "python-wrapt")
@ -15798,6 +15860,42 @@ by Igor Pavlov.")
(define-public python2-pylzma (define-public python2-pylzma
(package-with-python2 python-pylzma)) (package-with-python2 python-pylzma))
(define-public python2-zeroconf
(package
(name "python2-zeroconf")
;; This is the last version that supports Python 2.x.
(version "0.19.1")
(source
(origin
(method url-fetch)
(uri (pypi-uri "zeroconf" version))
(sha256
(base32
"0ykzg730n915qbrq9bn5pn06bv6rb5zawal4sqjyfnjjm66snkj3"))))
(build-system python-build-system)
(arguments
`(#:python ,python-2
#:phases
(modify-phases %standard-phases
(add-after 'unpack 'patch-requires
(lambda* (#:key inputs #:allow-other-keys)
(substitute* "setup.py"
(("enum-compat")
"enum34"))
#t)))))
(native-inputs
`(("python2-six" ,python2-six)
("python2-enum32" ,python2-enum34)
("python2-netifaces" ,python2-netifaces)
("python2-typing" ,python2-typing)))
(home-page "https://github.com/jstasiak/python-zeroconf")
(synopsis "Pure Python mDNS service discovery")
(description
"Pure Python multicast DNS (mDNS) service discovery library (Bonjour/Avahi
compatible).")
(license license:lgpl2.1+)))
(define-public python-bsddb3 (define-public python-bsddb3
(package (package
(name "python-bsddb3") (name "python-bsddb3")

14
gnu/packages/serialization.scm
View file

@ -297,18 +297,16 @@ that implements both the msgpack and msgpack-rpc specifications.")
(define-public jsoncpp (define-public jsoncpp
(package (package
(name "jsoncpp") (name "jsoncpp")
(version "1.8.4") (version "1.9.0")
(home-page "https://github.com/open-source-parsers/jsoncpp")
(source (origin (source (origin
(method url-fetch) (method git-fetch)
(uri (string-append (uri (git-reference (url home-page) (commit version)))
"https://github.com/open-source-parsers/jsoncpp/archive/" (file-name (git-file-name name version))
version ".tar.gz"))
(file-name (string-append name "-" version ".tar.gz"))
(sha256 (sha256
(base32 (base32
"1dpxk8hkni5dq4mdw8qbaj40jmid3a31d1gh8iqcnfwkw34ym7f4")))) "10wnwlq92gp32f5p55kjcc12jfsl0yq6f2y4abb0si6wym12krw9"))))
(build-system cmake-build-system) (build-system cmake-build-system)
(home-page "https://github.com/open-source-parsers/jsoncpp")
(arguments (arguments
`(#:configure-flags '("-DBUILD_SHARED_LIBS:BOOL=YES"))) `(#:configure-flags '("-DBUILD_SHARED_LIBS:BOOL=YES")))
(synopsis "C++ library for interacting with JSON") (synopsis "C++ library for interacting with JSON")

6
gnu/packages/wine.scm
View file

@ -310,7 +310,7 @@ integrate Windows applications into your desktop.")
(define-public wine-staging-patchset-data (define-public wine-staging-patchset-data
(package (package
(name "wine-staging-patchset-data") (name "wine-staging-patchset-data")
(version "4.11") (version "4.12")
(source (source
(origin (origin
(method git-fetch) (method git-fetch)
@ -320,7 +320,7 @@ integrate Windows applications into your desktop.")
(file-name (git-file-name name version)) (file-name (git-file-name name version))
(sha256 (sha256
(base32 (base32
"0h8qldqr9w1kwn48qgg5m1cs2xqkv8xxg2c66cvfka91hy886jcf")))) "1drsrps6bd5gcafzcfrr9pzajhh5s6qg5la7q4qpwzlng9969f3r"))))
(build-system trivial-build-system) (build-system trivial-build-system)
(native-inputs (native-inputs
`(("bash" ,bash) `(("bash" ,bash)
@ -366,7 +366,7 @@ integrate Windows applications into your desktop.")
(file-name (string-append name "-" version ".tar.xz")) (file-name (string-append name "-" version ".tar.xz"))
(sha256 (sha256
(base32 (base32
"1rmyfwlynzs2niz7l2lwjs2axm6in6gb43ldbzyzsflxsmk5fl9f")))) "1az5pcczq2zl1cvfdggzf89n0sf77m3fjkc8rnna8qr3n585q4h0"))))
(inputs `(("autoconf" ,autoconf) ; for autoreconf (inputs `(("autoconf" ,autoconf) ; for autoreconf
("faudio" ,faudio) ("faudio" ,faudio)
("ffmpeg" ,ffmpeg) ("ffmpeg" ,ffmpeg)

18
gnu/tests/docker.scm
View file

@ -27,7 +27,6 @@
#:use-module (gnu services networking) #:use-module (gnu services networking)
#:use-module (gnu services docker) #:use-module (gnu services docker)
#:use-module (gnu services desktop) #:use-module (gnu services desktop)
#:use-module (gnu packages bootstrap) ; %bootstrap-guile
#:use-module (gnu packages docker) #:use-module (gnu packages docker)
#:use-module (gnu packages guile) #:use-module (gnu packages guile)
#:use-module (guix gexp) #:use-module (guix gexp)
@ -101,7 +100,7 @@ inside %DOCKER-OS."
marionette)) marionette))
(test-equal "Load docker image and run it" (test-equal "Load docker image and run it"
'("hello world" "hi!") '("hello world" "hi!" "JSON!")
(marionette-eval (marionette-eval
`(begin `(begin
(define slurp (define slurp
@ -125,8 +124,15 @@ inside %DOCKER-OS."
(response2 (slurp ;default entry point (response2 (slurp ;default entry point
,(string-append #$docker-cli "/bin/docker") ,(string-append #$docker-cli "/bin/docker")
"run" repository&tag "run" repository&tag
"-c" "(display \"hi!\")"))) "-c" "(display \"hi!\")"))
(list response1 response2)))
;; Check whether (json) is in $GUILE_LOAD_PATH.
(response3 (slurp ;default entry point + environment
,(string-append #$docker-cli "/bin/docker")
"run" repository&tag
"-c" "(use-modules (json))
(display (json-string->scm (scm->json-string \"JSON!\")))")))
(list response1 response2 response3)))
marionette)) marionette))
(test-end) (test-end)
@ -144,7 +150,7 @@ inside %DOCKER-OS."
(version "0") (version "0")
(source #f) (source #f)
(build-system trivial-build-system) (build-system trivial-build-system)
(arguments `(#:guile ,%bootstrap-guile (arguments `(#:guile ,guile-2.2
#:builder #:builder
(let ((out (assoc-ref %outputs "out"))) (let ((out (assoc-ref %outputs "out")))
(mkdir out) (mkdir out)
@ -158,7 +164,7 @@ standard output device and then enters a new line.")
(home-page #f) (home-page #f)
(license license:public-domain))) (license license:public-domain)))
(profile (profile-derivation (packages->manifest (profile (profile-derivation (packages->manifest
(list %bootstrap-guile (list guile-2.2 guile-json
guest-script-package)) guest-script-package))
#:hooks '() #:hooks '()
#:locales? #f)) #:locales? #f))

2
gnu/tests/install.scm
View file

@ -661,7 +661,7 @@ export GUIX_BUILD_OPTIONS=--no-grafts
ls -l /run/current-system/gc-roots ls -l /run/current-system/gc-roots
parted --script /dev/vdb mklabel gpt \\ parted --script /dev/vdb mklabel gpt \\
mkpart primary ext2 1M 3M \\ mkpart primary ext2 1M 3M \\
mkpart primary ext2 3M 1.2G \\ mkpart primary ext2 3M 1.4G \\
set 1 boot on \\ set 1 boot on \\
set 1 bios_grub on set 1 bios_grub on
echo -n thepassphrase | \\ echo -n thepassphrase | \\

18
gnu/tests/singularity.scm
View file

@ -111,6 +111,21 @@
"run" #$image "-c" "(exit 42)")) "run" #$image "-c" "(exit 42)"))
marionette)) marionette))
;; FIXME: Singularity 2.x doesn't directly honor
;; /.singularity.d/env/*.sh. Instead, you have to load those files
;; manually, which we don't do. Remove 'test-skip' call once we've
;; switch to Singularity 3.x.
(test-skip 1)
(test-equal "singularity run, with environment"
0
(marionette-eval
;; Check whether GUILE_LOAD_PATH is properly set, allowing us to
;; find the (json) module.
`(status:exit-val
(system* #$(file-append singularity "/bin/singularity")
"--debug" "run" #$image "-c" "(use-modules (json))"))
marionette))
(test-end) (test-end)
(exit (= (test-runner-fail-count (test-runner-current)) 0))))) (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
@ -122,7 +137,8 @@
(guile (set-guile-for-build (default-guile))) (guile (set-guile-for-build (default-guile)))
;; 'singularity exec' insists on having /bin/sh in the image. ;; 'singularity exec' insists on having /bin/sh in the image.
(profile (profile-derivation (packages->manifest (profile (profile-derivation (packages->manifest
(list bash-minimal guile-2.2)) (list bash-minimal
guile-2.2 guile-json))
#:hooks '() #:hooks '()
#:locales? #f)) #:locales? #f))
(tarball (squashfs-image "singularity-pack" profile (tarball (squashfs-image "singularity-pack" profile

15
guix/channels.scm
View file

@ -429,19 +429,15 @@ derivation."
(define (channel-instances->manifest instances) (define (channel-instances->manifest instances)
"Return a profile manifest with entries for all of INSTANCES, a list of "Return a profile manifest with entries for all of INSTANCES, a list of
channel instances." channel instances."
(define instance->entry (define (instance->entry instance drv)
(match-lambda
((instance drv)
(let ((commit (channel-instance-commit instance)) (let ((commit (channel-instance-commit instance))
(channel (channel-instance-channel instance))) (channel (channel-instance-channel instance)))
(with-monad %store-monad (manifest-entry
(return (manifest-entry
(name (symbol->string (channel-name channel))) (name (symbol->string (channel-name channel)))
(version (string-take commit 7)) (version (string-take commit 7))
(item (if (guix-channel? channel) (item (if (guix-channel? channel)
(if (old-style-guix? drv) (if (old-style-guix? drv)
(whole-package-for-legacy (whole-package-for-legacy (string-append name "-" version)
(string-append name "-" version)
drv) drv)
drv) drv)
drv)) drv))
@ -450,11 +446,10 @@ channel instances."
(version 0) (version 0)
(url ,(channel-url channel)) (url ,(channel-url channel))
(branch ,(channel-branch channel)) (branch ,(channel-branch channel))
(commit ,commit)))))))))))) (commit ,commit))))))))
(mlet* %store-monad ((derivations (channel-instance-derivations instances)) (mlet* %store-monad ((derivations (channel-instance-derivations instances))
(entries (mapm %store-monad instance->entry (entries -> (map instance->entry instances derivations)))
(zip instances derivations))))
(return (manifest entries)))) (return (manifest entries))))
(define (package-cache-file manifest) (define (package-cache-file manifest)

101
guix/derivations.scm
View file

@ -293,74 +293,78 @@ result is the set of prerequisites of DRV not already in valid."
(derivation-output-path (assoc-ref outputs sub-drv))) (derivation-output-path (assoc-ref outputs sub-drv)))
sub-drvs)))) sub-drvs))))
(define* (substitution-oracle store drv (define* (substitution-oracle store inputs-or-drv
#:key (mode (build-mode normal))) #:key (mode (build-mode normal)))
"Return a one-argument procedure that, when passed a store file name, "Return a one-argument procedure that, when passed a store file name,
returns a 'substitutable?' if it's substitutable and #f otherwise. 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* The returned procedure knows about all substitutes for all the derivation
those that are already valid (that is, it won't bother checking whether an inputs or derivations listed in INPUTS-OR-DRV, *except* those that are already
item is substitutable if it's already on disk); it also knows about their valid (that is, it won't bother checking whether an item is substitutable if
prerequisites, unless they are themselves substitutable. 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 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 reusing it is much more efficient than calling 'has-substitutes?' or similar
repeatedly, because it avoids the costs associated with launching the repeatedly, because it avoids the costs associated with launching the
substituter many times." substituter many times."
(define valid?
(cut valid-path? store <>))
(define valid-input? (define valid-input?
(cut valid-derivation-input? store <>)) (cut valid-derivation-input? store <>))
(define (dependencies drv) (define (closure inputs)
;; Skip prerequisite sub-trees of DRV whose root is valid. This allows us (let loop ((inputs inputs)
;; to ask the substituter for just as much as needed, instead of asking it (closure '())
;; for the whole world, which can be significantly faster when substitute (visited (set)))
;; info is not already in cache. (match inputs
;; Also, skip derivations marked as non-substitutable. (()
(append-map (lambda (input) (reverse closure))
(let ((drv (derivation-input-derivation input))) ((input rest ...)
(if (substitutable-derivation? drv) (let ((key (derivation-input-key input)))
(derivation-input-output-paths input) (cond ((set-contains? visited key)
'()))) (loop rest closure visited))
(derivation-prerequisites drv valid-input?))) ((valid-input? input)
(loop rest closure (set-insert key visited)))
(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 (else
(cons* self (dependencies drv) result))))) (let ((drv (derivation-input-derivation input)))
'() (loop (append (derivation-inputs drv) rest)
drv)))) (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) (subst (fold (lambda (subst vhash)
(vhash-cons (substitutable-path subst) subst (vhash-cons (substitutable-path subst) subst
vhash)) vhash))
vlist-null vlist-null
(substitutable-path-info store paths)))) (substitutable-path-info store items))))
(lambda (item) (lambda (item)
(match (vhash-assoc item subst) (match (vhash-assoc item subst)
(#f #f) (#f #f)
((key . value) value))))) ((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 (define* (derivation-build-plan store inputs
#:key #:key
(mode (build-mode normal)) (mode (build-mode normal))
(substitutable-info (substitutable-info
(substitution-oracle (substitution-oracle
store store inputs #:mode mode)))
(map derivation-input-derivation
inputs)
#:mode mode)))
"Given INPUTS, a list of derivation-inputs, return two values: the list of "Given INPUTS, a list of derivation-inputs, return two values: the list of
derivation to build, and the list of substitutable items that, together, derivation to build, and the list of substitutable items that, together,
allows INPUTS to be realized. allows INPUTS to be realized.
@ -391,7 +395,9 @@ by 'substitution-oracle'."
(() (()
(values build substitute)) (values build substitute))
((input rest ...) ((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) (cond ((set-contains? visited key)
(loop rest build substitute visited)) (loop rest build substitute visited))
((input-built? input) ((input-built? input)
@ -400,16 +406,17 @@ by 'substitution-oracle'."
((input-substitutable-info input) ((input-substitutable-info input)
=> =>
(lambda (substitutables) (lambda (substitutables)
(loop rest build (loop (append (dependencies-of-substitutables substitutables
deps)
rest)
build
(append substitutables substitute) (append substitutables substitute)
(set-insert key visited)))) (set-insert key visited))))
(else (else
(let ((deps (derivation-inputs
(derivation-input-derivation input))))
(loop (append deps rest) (loop (append deps rest)
(cons (derivation-input-derivation input) build) (cons (derivation-input-derivation input) build)
substitute substitute
(set-insert key visited)))))))))) (set-insert key visited)))))))))
(define-deprecated (derivation-prerequisites-to-build store drv #:rest rest) (define-deprecated (derivation-prerequisites-to-build store drv #:rest rest)
derivation-build-plan derivation-build-plan

15
guix/docker.scm
View file

@ -73,7 +73,7 @@
`((,(generate-tag path) . ((latest . ,id))))) `((,(generate-tag path) . ((latest . ,id)))))
;; See https://github.com/opencontainers/image-spec/blob/master/config.md ;; 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." "Generate a minimal image configuration for the given LAYER file."
;; "architecture" must be values matching "platform.arch" in the ;; "architecture" must be values matching "platform.arch" in the
;; runtime-spec at ;; runtime-spec at
@ -81,9 +81,13 @@
`((architecture . ,arch) `((architecture . ,arch)
(comment . "Generated by GNU Guix") (comment . "Generated by GNU Guix")
(created . ,time) (created . ,time)
(config . ,(if entry-point (config . ,`((env . ,(map (match-lambda
((name . value)
(string-append name "=" value)))
environment))
,@(if entry-point
`((entrypoint . ,entry-point)) `((entrypoint . ,entry-point))
#nil)) '())))
(container_config . #nil) (container_config . #nil)
(os . "linux") (os . "linux")
(rootfs . ((type . "layers") (rootfs . ((type . "layers")
@ -113,6 +117,7 @@ return \"a\"."
(system (utsname:machine (uname))) (system (utsname:machine (uname)))
database database
entry-point entry-point
(environment '())
compressor compressor
(creation-time (current-time time-utc))) (creation-time (current-time time-utc)))
"Write to IMAGE a Docker image archive containing the given PATHS. PREFIX "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 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. 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 SYMLINKS must be a list of (SOURCE -> TARGET) tuples describing symlinks to be
created in the image, where each TARGET is relative to PREFIX. created in the image, where each TARGET is relative to PREFIX.
TRANSFORMATIONS must be a list of (OLD -> NEW) tuples describing how to 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 () (lambda ()
(scm->json (config (string-append id "/layer.tar") (scm->json (config (string-append id "/layer.tar")
time arch time arch
#:environment environment
#:entry-point entry-point)))) #:entry-point entry-point))))
(with-output-to-file "manifest.json" (with-output-to-file "manifest.json"
(lambda () (lambda ()

234
guix/gexp.scm
View file

@ -39,6 +39,9 @@
gexp-input gexp-input
gexp-input? gexp-input?
gexp-input-thing
gexp-input-output
gexp-input-native?
local-file local-file
local-file? local-file?
@ -78,6 +81,14 @@
load-path-expression load-path-expression
gexp-modules 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->derivation
gexp->file gexp->file
gexp->script gexp->script
@ -566,15 +577,20 @@ list."
"Turn any package from INPUTS into a derivation for SYSTEM; return the "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 corresponding input list as a monadic value. When TARGET is true, use it as
the cross-compilation target triplet." the cross-compilation target triplet."
(define (store-item? obj)
(and (string? obj) (store-path? obj)))
(with-monad %store-monad (with-monad %store-monad
(mapm %store-monad (mapm %store-monad
(match-lambda (match-lambda
(((? struct? thing) sub-drv ...) (((? struct? thing) sub-drv ...)
(mlet %store-monad ((drv (lower-object (mlet %store-monad ((drv (lower-object
thing system #:target target))) thing system #:target target)))
(return `(,drv ,@sub-drv)))) (return (apply gexp-input drv sub-drv))))
(((? store-item? item))
(return (gexp-input item)))
(input (input
(return input))) (return (gexp-input input))))
inputs))) inputs)))
(define* (lower-reference-graphs graphs #:key system target) (define* (lower-reference-graphs graphs #:key system target)
@ -586,7 +602,9 @@ corresponding derivation."
(mlet %store-monad ((inputs (lower-inputs inputs (mlet %store-monad ((inputs (lower-inputs inputs
#:system system #:system system
#:target target))) #: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) (define* (lower-references lst #:key system target)
"Based on LST, a list of output names and packages, return a list of output "Based on LST, a list of output names and packages, return a list of output
@ -618,6 +636,130 @@ names and file names suitable for the #:allowed-references argument to
(lambda (system) (lambda (system)
((force proc) 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
(pre-load-modules? #t)) ;transitional
"*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
#:pre-load-modules?
pre-load-modules?
#: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 (define* (gexp->derivation name exp
#:key #:key
system (target 'current) system (target 'current)
@ -682,10 +824,8 @@ DEPRECATION-WARNINGS determines whether to show deprecation warnings while
compiling modules. It can be #f, #t, or 'detailed. compiling modules. It can be #f, #t, or 'detailed.
The other arguments are as for 'derivation'." The other arguments are as for 'derivation'."
(define %modules
(delete-duplicates
(append modules (gexp-modules exp))))
(define outputs (gexp-outputs exp)) (define outputs (gexp-outputs exp))
(define requested-graft? graft?)
(define (graphs-file-names graphs) (define (graphs-file-names graphs)
;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS. ;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS.
@ -699,11 +839,13 @@ The other arguments are as for 'derivation'."
(cons file-name thing))) (cons file-name thing)))
graphs)) graphs))
(define (extension-flags extension) (define (add-modules exp modules)
`("-L" ,(string-append (derivation->output-path extension) (if (null? modules)
"/share/guile/site/" effective-version) exp
"-C" ,(string-append (derivation->output-path extension) (make-gexp (gexp-references exp)
"/lib/guile/" effective-version "/site-ccache"))) (append modules (gexp-self-modules exp))
(gexp-self-extensions exp)
(gexp-proc exp))))
(mlet* %store-monad ( ;; The following binding forces '%current-system' and (mlet* %store-monad ( ;; The following binding forces '%current-system' and
;; '%current-target-system' to be looked up at >>= ;; '%current-target-system' to be looked up at >>=
@ -714,40 +856,21 @@ The other arguments are as for 'derivation'."
(target -> (if (eq? target 'current) (target -> (if (eq? target 'current)
(%current-target-system) (%current-target-system)
target)) target))
(normals (lower-inputs (gexp-inputs exp) (exp -> (add-modules exp modules))
#:system system (lowered (lower-gexp exp
#: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 #:module-path module-path
#:guile guile-for-build)
(return #f)))
(compiled (if (pair? %modules)
(compiled-modules %modules
#:system system #:system system
#:module-path module-path #:target target
#:extensions extensions #:graft? requested-graft?
#:guile guile-for-build #:guile-for-build
#:pre-load-modules? guile-for-build
pre-load-modules? #:effective-version
effective-version
#:deprecation-warnings #:deprecation-warnings
deprecation-warnings) deprecation-warnings
(return #f))) #:pre-load-modules?
pre-load-modules?))
(graphs (if references-graphs (graphs (if references-graphs
(lower-reference-graphs references-graphs (lower-reference-graphs references-graphs
#:system system #:system system
@ -763,32 +886,30 @@ The other arguments are as for 'derivation'."
#:system system #:system system
#:target target) #:target target)
(return #f))) (return #f)))
(guile (if guile-for-build (guile -> (lowered-gexp-guile lowered))
(return guile-for-build) (builder (text-file script-name
(default-guile-derivation system)))) (object->string
(lowered-gexp-sexp lowered)))))
(mbegin %store-monad (mbegin %store-monad
(set-grafting graft?) ;restore the initial setting (set-grafting graft?) ;restore the initial setting
(raw-derivation name (raw-derivation name
(string-append (derivation->output-path guile) (string-append (derivation->output-path guile)
"/bin/guile") "/bin/guile")
`("--no-auto-compile" `("--no-auto-compile"
,@(if (pair? %modules) ,@(append-map (lambda (directory)
`("-L" ,(if (derivation? modules) `("-L" ,directory))
(derivation->output-path modules) (lowered-gexp-load-path lowered))
modules) ,@(append-map (lambda (directory)
"-C" ,(derivation->output-path compiled)) `("-C" ,directory))
'()) (lowered-gexp-load-compiled-path lowered))
,@(append-map extension-flags exts)
,builder) ,builder)
#:outputs outputs #:outputs outputs
#:env-vars env-vars #:env-vars env-vars
#:system system #:system system
#:inputs `((,guile) #:inputs `((,guile)
(,builder) (,builder)
,@(if modules ,@(map gexp-input->tuple
`((,modules) (,compiled) ,@inputs) (lowered-gexp-inputs lowered))
inputs)
,@(map list exts)
,@(match graphs ,@(match graphs
(((_ . inputs) ...) inputs) (((_ . inputs) ...) inputs)
(_ '()))) (_ '())))
@ -804,6 +925,7 @@ The other arguments are as for 'derivation'."
(define* (gexp-inputs exp #:key native?) (define* (gexp-inputs exp #:key native?)
"Return the input list for EXP. When NATIVE? is true, return only native "Return the input list for EXP. When NATIVE? is true, return only native
references; otherwise, return only non-native references." references; otherwise, return only non-native references."
;; TODO: Return <gexp-input> records instead of tuples.
(define (add-reference-inputs ref result) (define (add-reference-inputs ref result)
(match ref (match ref
(($ <gexp-input> (? gexp? exp) _ #t) (($ <gexp-input> (? gexp? exp) _ #t)

9
guix/inferior.scm
View file

@ -59,6 +59,7 @@
inferior-eval inferior-eval
inferior-eval-with-store inferior-eval-with-store
inferior-object? inferior-object?
read-repl-response
inferior-packages inferior-packages
inferior-available-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) (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 (define sexp->object
(match-lambda (match-lambda
(('value value) (('value value)
@ -191,12 +193,15 @@ equivalent. Return #f if the inferior could not be launched."
(('non-self-quoting address string) (('non-self-quoting address string)
(inferior-object address string)))) (inferior-object address string))))
(match (read (inferior-socket inferior)) (match (read port)
(('values objects ...) (('values objects ...)
(apply values (map sexp->object objects))) (apply values (map sexp->object objects)))
(('exception key objects ...) (('exception key objects ...)
(apply throw key (map sexp->object 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) (define (send-inferior-request exp inferior)
(write exp (inferior-socket inferior)) (write exp (inferior-socket inferior))
(newline (inferior-socket inferior))) (newline (inferior-socket inferior)))

134
guix/remote.scm Normal file
View file

@ -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)))))))

86
guix/repl.scm Normal file
View file

@ -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)))))

84
guix/scripts/deploy.scm Normal file
View file

@ -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))))

64
guix/scripts/pack.scm
View file

@ -27,6 +27,7 @@
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix store) #:use-module (guix store)
#:use-module ((guix status) #:select (with-status-verbosity)) #:use-module ((guix status) #:select (with-status-verbosity))
#:use-module ((guix self) #:select (make-config.scm))
#:use-module (guix grafts) #:use-module (guix grafts)
#:autoload (guix inferior) (inferior-package?) #:autoload (guix inferior) (inferior-package?)
#:use-module (guix monads) #:use-module (guix monads)
@ -285,6 +286,32 @@ added to the pack."
build build
#:references-graphs `(("profile" ,profile)))) #: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 (define* (squashfs-image name profile
#:key target #:key target
(profile-name "guix-profile") (profile-name "guix-profile")
@ -304,6 +331,9 @@ added to the pack."
(file-append (store-database (list profile)) (file-append (store-database (list profile))
"/db/db.sqlite"))) "/db/db.sqlite")))
(define environment
(singularity-environment-file profile))
(define build (define build
(with-imported-modules (source-module-closure (with-imported-modules (source-module-closure
'((guix build utils) '((guix build utils)
@ -338,6 +368,7 @@ added to the pack."
`(,@(map store-info-item `(,@(map store-info-item
(call-with-input-file "profile" (call-with-input-file "profile"
read-reference-graph)) read-reference-graph))
#$environment
,#$output ,#$output
;; Do not perform duplicate checking because we ;; Do not perform duplicate checking because we
@ -378,10 +409,19 @@ added to the pack."
target))))))) target)))))))
'#$symlinks) '#$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' ;; Create /.singularity.d/actions, and optionally the 'run'
;; script, used by 'singularity run'. ;; script, used by 'singularity run'.
"-p" "/.singularity.d d 555 0 0"
"-p" "/.singularity.d/actions d 555 0 0" "-p" "/.singularity.d/actions d 555 0 0"
,@(if entry-point ,@(if entry-point
`(;; This one if for Singularity 2.x. `(;; This one if for Singularity 2.x.
"-p" "-p"
@ -440,11 +480,24 @@ the image."
(define build (define build
;; Guile-JSON and Guile-Gcrypt are required by (guix docker). ;; Guile-JSON and Guile-Gcrypt are required by (guix docker).
(with-extensions (list guile-json guile-gcrypt) (with-extensions (list guile-json guile-gcrypt)
(with-imported-modules (source-module-closure '((guix docker) (with-imported-modules `(((guix config) => ,(make-config.scm))
(guix build store-copy)) ,@(source-module-closure
#:select? not-config?) `((guix docker)
(guix build store-copy)
(guix profiles)
(guix search-paths))
#:select? not-config?))
#~(begin #~(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")) (setenv "PATH" (string-append #$archiver "/bin"))
@ -455,6 +508,7 @@ the image."
#$profile #$profile
#:database #+database #:database #+database
#:system (or #$target (utsname:machine (uname))) #:system (or #$target (utsname:machine (uname)))
#:environment environment
#:entry-point #$(and entry-point #:entry-point #$(and entry-point
#~(string-append #$profile "/" #~(string-append #$profile "/"
#$entry-point)) #$entry-point))

56
guix/scripts/repl.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -19,6 +19,7 @@
(define-module (guix scripts repl) (define-module (guix scripts repl)
#:use-module (guix ui) #:use-module (guix ui)
#:use-module (guix scripts) #:use-module (guix scripts)
#:use-module (guix repl)
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (gnu packages) #:use-module (gnu packages)
@ -29,8 +30,7 @@
#:autoload (system repl repl) (start-repl) #:autoload (system repl repl) (start-repl)
#:autoload (system repl server) #:autoload (system repl server)
(make-tcp-server-socket make-unix-domain-server-socket) (make-tcp-server-socket make-unix-domain-server-socket)
#:export (machine-repl #:export (guix-repl))
guix-repl))
;;; Commentary: ;;; Commentary:
;;; ;;;
@ -68,62 +68,12 @@ Start a Guile REPL in the Guix execution environment.\n"))
(newline) (newline)
(show-bug-report-information)) (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 (define user-module
;; Module where we execute user code. ;; Module where we execute user code.
(let ((module (resolve-module '(guix-user) #f #f #:ensure #t))) (let ((module (resolve-module '(guix-user) #f #f #:ensure #t)))
(beautify-user-module! module) (beautify-user-module! 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) (define (call-with-connection spec thunk)
"Dynamically-bind the current input and output ports according to SPEC and "Dynamically-bind the current input and output ports according to SPEC and
call THUNK." call THUNK."

10
guix/ssh.scm
View file

@ -57,12 +57,14 @@
(define %compression (define %compression
"zlib@openssh.com,zlib") "zlib@openssh.com,zlib")
(define* (open-ssh-session host #:key user port (define* (open-ssh-session host #:key user port identity
(compression %compression)) (compression %compression))
"Open an SSH session for HOST and return it. When USER and PORT are #f, use "Open an SSH session for HOST and return it. IDENTITY specifies the file
default values or whatever '~/.ssh/config' specifies; otherwise use them. name of a private key to use for authenticating with the host. When USER,
Throw an error on failure." 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 (let ((session (make-session #:user user
#:identity identity
#:host host #:host host
#:port port #:port port
#:timeout 10 ;seconds #:timeout 10 ;seconds

9
guix/store.scm
View file

@ -1802,11 +1802,12 @@ connection, and return the result."
(call-with-values (lambda () (call-with-values (lambda ()
(run-with-state mval store)) (run-with-state mval store))
(lambda (result new-store) (lambda (result new-store)
;; Copy the object cache from NEW-STORE so we don't fully discard the (when (and store new-store)
;; state. ;; Copy the object cache from NEW-STORE so we don't fully discard
;; the state.
(let ((cache (store-connection-object-cache new-store))) (let ((cache (store-connection-object-cache new-store)))
(set-store-connection-object-cache! store cache) (set-store-connection-object-cache! store cache)))
result))))) result))))
;;; ;;;

15
guix/ui.scm
View file

@ -835,8 +835,7 @@ check and report what is prerequisites are available for download."
;; substituter many times. This makes a big difference, especially when ;; substituter many times. This makes a big difference, especially when
;; DRV is a long list as is the case with 'guix environment'. ;; DRV is a long list as is the case with 'guix environment'.
(if use-substitutes? (if use-substitutes?
(substitution-oracle store (map derivation-input-derivation inputs) (substitution-oracle store inputs #:mode mode)
#:mode mode)
(const #f))) (const #f)))
(let*-values (((build download) (let*-values (((build download)
@ -844,18 +843,6 @@ check and report what is prerequisites are available for download."
#:mode mode #:mode mode
#:substitutable-info #:substitutable-info
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) ((graft hook build)
(match (fold (lambda (drv acc) (match (fold (lambda (drv acc)
(let ((file (derivation-file-name drv))) (let ((file (derivation-file-name drv)))

2
po/guix/POTFILES.in
View file

@ -36,6 +36,7 @@ gnu/installer/steps.scm
gnu/installer/timezone.scm gnu/installer/timezone.scm
gnu/installer/user.scm gnu/installer/user.scm
gnu/installer/utils.scm gnu/installer/utils.scm
gnu/machine/ssh.scm
guix/scripts.scm guix/scripts.scm
guix/scripts/build.scm guix/scripts/build.scm
guix/discovery.scm guix/discovery.scm
@ -66,6 +67,7 @@ guix/scripts/pack.scm
guix/scripts/weather.scm guix/scripts/weather.scm
guix/scripts/describe.scm guix/scripts/describe.scm
guix/scripts/processes.scm guix/scripts/processes.scm
guix/scripts/deploy.scm
guix/gnu-maintenance.scm guix/gnu-maintenance.scm
guix/scripts/container.scm guix/scripts/container.scm
guix/scripts/container/exec.scm guix/scripts/container/exec.scm

29
tests/derivations.scm
View file

@ -896,6 +896,35 @@
(((= derivation-file-name build)) (((= derivation-file-name build))
(string=? build (derivation-file-name drv))))))))) (string=? build (derivation-file-name drv)))))))))
(test-assert "derivation-build-plan and substitutes, non-substitutable dep"
(with-store store
(let* ((drv1 (build-expression->derivation store "prereq-no-subst"
(random 1000)
#:substitutable? #f))
(drv2 (build-expression->derivation store "substitutable"
(random 1000)
#:inputs `(("dep" ,drv1)))))
;; Make sure substitutes are usable.
(set-build-options store #:use-substitutes? #t
#:substitute-urls (%test-substitute-urls))
(with-derivation-narinfo drv2
(sha256 => (make-bytevector 32 0))
(references => (list (derivation->output-path drv1)))
(let-values (((build download)
(derivation-build-plan store
(list (derivation-input drv2)))))
;; Although DRV2 is available as a substitute, we must build its
;; dependency, DRV1, due to #:substitutable? #f.
(and (match download
(((= substitutable-path item))
(string=? item (derivation->output-path drv2))))
(match build
(((= derivation-file-name build))
(string=? build (derivation-file-name drv1))))))))))
(test-assert "derivation-build-plan and substitutes, local build" (test-assert "derivation-build-plan and substitutes, local build"
(with-store store (with-store store
(let* ((drv (build-expression->derivation store "prereq-subst-local" (let* ((drv (build-expression->derivation store "prereq-subst-local"

37
tests/gexp.scm
View file

@ -832,6 +832,43 @@
(built-derivations (list drv)) (built-derivations (list drv))
(return (equal? '(42 84) (call-with-input-file out read)))))) (return (equal? '(42 84) (call-with-input-file out read))))))
(test-assertm "lower-gexp"
(mlet* %store-monad
((extension -> %extension-package)
(extension-drv (package->derivation %extension-package))
(coreutils-drv (package->derivation coreutils))
(exp -> (with-extensions (list extension)
(with-imported-modules `((guix build utils))
#~(begin
(use-modules (guix build utils)
(hg2g))
#$coreutils:debug
mkdir-p
the-answer))))
(lexp (lower-gexp exp
#:effective-version "2.0")))
(define (matching-input drv output)
(lambda (input)
(and (eq? (gexp-input-thing input) drv)
(string=? (gexp-input-output input) output))))
(mbegin %store-monad
(return (and (find (matching-input extension-drv "out")
(lowered-gexp-inputs (pk 'lexp lexp)))
(find (matching-input coreutils-drv "debug")
(lowered-gexp-inputs lexp))
(member (string-append
(derivation->output-path extension-drv)
"/share/guile/site/2.0")
(lowered-gexp-load-path lexp))
(= 2 (length (lowered-gexp-load-path lexp)))
(member (string-append
(derivation->output-path extension-drv)
"/lib/guile/2.0/site-ccache")
(lowered-gexp-load-compiled-path lexp))
(= 2 (length (lowered-gexp-load-compiled-path lexp)))
(eq? (lowered-gexp-guile lexp) (%guile-for-build)))))))
(test-assertm "gexp->derivation #:references-graphs" (test-assertm "gexp->derivation #:references-graphs"
(mlet* %store-monad (mlet* %store-monad
((one (text-file "one" (random-text))) ((one (text-file "one" (random-text)))