me
/
guix
Archived
1
0
Fork 0
Code

Merge branch 'master' into staging

master
Marius Bakke 2019-07-07 01:18:18 +02:00
parent 42dcfca4cc c72647fbae
commit 36175a3a9e
No known key found for this signature in database
GPG Key ID: A2A06DF2A33A54FA
39 changed files with 2147 additions and 277 deletions
Show Stats 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/derivations.scm \
guix/grafts.scm \
guix/repl.scm \
guix/inferior.scm \
guix/describe.scm \
guix/channels.scm \
@ -266,6 +267,7 @@ MODULES = \
guix/scripts/weather.scm \
guix/scripts/container.scm \
guix/scripts/container/exec.scm \
guix/scripts/deploy.scm \
guix.scm \
$(GNU_SYSTEM_MODULES)
@ -273,6 +275,7 @@ if HAVE_GUILE_SSH
MODULES += \
guix/ssh.scm \
guix/remote.scm \
guix/scripts/copy.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 Diego Nicola Barbato@*
Copyright @copyright{} 2019 Ivan Petkov@*
Copyright @copyright{} 2019 Jakob L. Kreuze@*
Permission is granted to copy, distribute and/or modify this document
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 pull: (guix)Invoking guix pull. Update the list of available packages.
* 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
@dircategory Software development
@ -269,6 +271,7 @@ System Configuration
* Initial RAM Disk:: Linux-Libre bootstrapping.
* Bootloader Configuration:: Configuring the boot loader.
* 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.
* Defining Services:: Adding new service definitions.
@ -10296,6 +10299,7 @@ instance to support new system services.
* Initial RAM Disk:: Linux-Libre bootstrapping.
* Bootloader Configuration:: Configuring the boot loader.
* 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.
* Defining Services:: Adding new service definitions.
@end menu
@ -25392,6 +25396,116 @@ example graph.
@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
@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/urandom"
"/dev/tty"
"/dev/ptmx"
"/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
;; associated with standard input when there is one.
(let* ((in (current-input-port))

6
gnu/ci.scm
View File

@ -193,9 +193,11 @@ system.")
(define channel-build-system
;; Build system used to "convert" a channel instance to a package.
(let* ((build (lambda* (store name inputs
#:key instance #:allow-other-keys)
#:key instance system
#:allow-other-keys)
(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)
(bag
(name name)

6
gnu/local.mk
View File

@ -299,6 +299,7 @@ GNU_SYSTEM_MODULES = \
%D%/packages/llvm.scm \
%D%/packages/lout.scm \
%D%/packages/logging.scm \
%D%/packages/logo.scm \
%D%/packages/lolcode.scm \
%D%/packages/lsof.scm \
%D%/packages/lua.scm \
@ -564,6 +565,9 @@ GNU_SYSTEM_MODULES = \
%D%/system/uuid.scm \
%D%/system/vm.scm \
\
%D%/machine.scm \
%D%/machine/ssh.scm \
\
%D%/build/accounts.scm \
%D%/build/activation.scm \
%D%/build/bootloader.scm \
@ -629,7 +633,7 @@ INSTALLER_MODULES = \
%D%/installer/newt/user.scm \
%D%/installer/newt/utils.scm \
%D%/installer/newt/welcome.scm \
%D%/installer/newt/wifi.scm
%D%/installer/newt/wifi.scm
# Always ship the installer modules but compile them only when
# ENABLE_INSTALLER is true.

107
gnu/machine.scm 100644
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 100644
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>.
;; Also, the differences between release and current version seem to be
;; significant.
(let ((commit "50e8b5cc62f9b46f5445f5c5e8c5ab7263ea6d9d")
(let ((commit "6331dc4f15b9dfabb954ba3fae9d76b6c3ca6377")
(revision "1"))
(package
(name "nanopolish")
(version (git-version "0.10.2" revision commit))
(version (git-version "0.11.1" revision commit))
(source
(origin
(method git-fetch)
@ -14083,7 +14083,7 @@ choosing which reads pass the filter.")
(recursive? #t)))
(file-name (git-file-name name version))
(sha256
(base32 "09j5gz57yr9i34a27vbl72i4g8syv2zzgmsfyjq02yshmnrvkjs6"))
(base32 "15ikl3d37y49pwd7vx36xksgsqajhf24q7qqsnpl15dqqyy5qgbc"))
(modules '((guix build utils)))
(snippet
'(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
(package
(name "grammalecte")
(version "1.1.1")
(version "1.2")
(source
(origin
(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"))
(sha256
(base32
"1al4c3976wgxijxghxqb1banarj82hwad51kln87xj2r5kwcfm05"))))
"0dwizai6w9yn617y7cnqdiwv77vn22p18s9sypypbl1bl695cnma"))))
(build-system python-build-system)
(home-page "https://grammalecte.net")
(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)
("pkg-config" ,pkg-config)))
(inputs
`(("gtksourceview" ,gtksourceview)
`(("gtksourceview" ,gtksourceview-3)
("libsm" ,libsm)))
(home-page "https://wiki.gnome.org/Apps/Xpad")
(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)
("pkg-config" ,pkg-config)
("texinfo" ,texinfo)
("texlive" ,texlive)))
("texlive" ,(texlive-union (list texlive-generic-epsf)))))
(propagated-inputs
`(("dbus-glib" ,dbus-glib)
("guile" ,guile-2.2)

30
gnu/packages/image.scm
View File

@ -1,5 +1,5 @@
;;; 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 © 2014, 2015, 2016 Mark H Weaver <mhw@netris.org>
;;; 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>.
(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
(package
(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.conf" ,sbcl-iolib.conf)
("iolib.grovel" ,sbcl-iolib.grovel)
("iolib.base", sbcl-iolib.base)
("bordeaux-threads", sbcl-bordeaux-threads)
("idna", sbcl-idna)
("swap-bytes", sbcl-swap-bytes)
("libfixposix", libfixposix)))
("iolib.base" ,sbcl-iolib.base)
("bordeaux-threads" ,sbcl-bordeaux-threads)
("idna" ,sbcl-idna)
("swap-bytes" ,sbcl-swap-bytes)
("libfixposix" ,libfixposix)
("cffi" ,sbcl-cffi)))
(native-inputs
`(("fiveam" ,sbcl-fiveam)))
(arguments
@ -5953,12 +5954,12 @@ floating point values to IEEE 754 binary representation.")
(name "sbcl-closure-common")
(build-system asdf-build-system/sbcl)
(version (git-version "20101006" revision commit))
(home-page "https://github.com/sharplispers/closure-common")
(home-page "https://common-lisp.net/project/cxml/")
(source
(origin
(method git-fetch)
(uri (git-reference
(url home-page)
(url "https://github.com/sharplispers/closure-common")
(commit commit)))
(file-name (git-file-name name version))
(sha256
@ -5973,6 +5974,111 @@ Closure is a reference to the web browser it was originally written for.")
;; TODO: License?
(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
(let ((commit "312f3661bbe187b5f28536cd7ec2956e91366c3b")
(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
neat APIs and connection-pooling. It is meant to supersede Drakma.")
(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 100644
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
(package
(name "patchwork")
(version "2.1.2")
(version "2.1.4")
(source (origin
(method git-fetch)
(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))
(sha256
(base32
"06ng5pv6744w98zkyfm0ldkmpdgnsql3gbbbh6awq61sr2ndr3qw"))))
"0zi1hcqb0pi2diyznbv0c1631qk4rx02zl8ghyrr59g3ljlyr18y"))))
(build-system python-build-system)
(arguments
`(;; TODO: Tests require a running database

8
gnu/packages/photo.scm
View File

@ -1,5 +1,5 @@
;;; 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, 2017 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2016, 2017, 2018 Efraim Flashner <efraim@flashner.co.il>
@ -70,14 +70,14 @@
(define-public libraw
(package
(name "libraw")
(version "0.19.2")
(version "0.19.3")
(source (origin
(method url-fetch)
(uri (string-append "https://www.libraw.org/data/LibRaw-"
version ".tar.gz"))
(sha256
(base32
"0i4nhjm5556xgn966x0i503ygk2wafq6z83kg0lisacjjab4f3a0"))))
"0xs1qb6pcvc4c43fy5xi3nkqxcif77gakkw99irf0fc5iccdd5px"))))
(build-system gnu-build-system)
(native-inputs
`(("pkg-config" ,pkg-config)))
@ -445,7 +445,7 @@ and enhance them.")
(inputs
`(("boost" ,boost)
("enblend-enfuse" ,enblend-enfuse)
("exiv2" ,exiv2)
("exiv2" ,exiv2-0.26)
("fftw" ,fftw)
("flann" ,flann)
("freeglut" ,freeglut)

58
gnu/packages/pulseaudio.scm
View File

@ -8,6 +8,7 @@
;;; Copyright © 2017 Stefan Reichör <stefan@xsteve.at>
;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2018 Pierre Langlois <pierre.langlois@gmx.com>
;;; Copyright © 2019 Alex Griffin <a@ajgrf.com>
;;;
;;; This file is part of GNU Guix.
;;;
@ -27,6 +28,7 @@
(define-module (gnu packages pulseaudio)
#:use-module (guix packages)
#:use-module (guix download)
#:use-module (guix git-download)
#:use-module ((guix licenses) #:prefix l:)
#:use-module (guix build-system gnu)
#:use-module (guix build-system python)
@ -43,6 +45,10 @@
#:use-module (gnu packages web)
#:use-module (gnu packages linux)
#: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 xiph))
@ -303,3 +309,55 @@ sinks.")
(description "Pulsemixer is a PulseAudio mixer with command-line and
curses-style interfaces.")
(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 Jack Hill <jackhill@jackhill.us>
;;; Copyright © 2019 Guillaume Le Vaillant <glv@posteo.net>
;;; Copyright © 2019 Alex Griffin <a@ajgrf.com>
;;;
;;; This file is part of GNU Guix.
;;;
@ -660,14 +661,14 @@ other machines, such as over the network.")
(define-public python-setuptools
(package
(name "python-setuptools")
(version "40.0.0")
(version "41.0.1")
(source
(origin
(method url-fetch)
(uri (pypi-uri "setuptools" version ".zip"))
(sha256
(base32
"0pq116lr14gnc62v76nk0npkm6krb2mpp7p9ab369zgv4n7dnah1"))
"04sns22y2hhsrwfy1mha2lgslvpjsjsz8xws7h2rh5a7ylkd28m2"))
(modules '((guix build utils)))
(snippet
'(begin
@ -4331,19 +4332,18 @@ services for your Python modules and applications.")
(define-public python-olefile
(package
(name "python-olefile")
(version "0.45.1")
(version "0.46")
(source
(origin
(method url-fetch)
(uri (string-append "https://github.com/decalage2/olefile/archive/v"
version ".tar.gz"))
(uri (string-append "https://github.com/decalage2/olefile/releases/"
"download/v" version "/olefile-" version ".tar.gz"))
(file-name (string-append name "-" version ".tar.gz"))
(sha256
(base32
"18ai19zwagm6nli14k8bii31ipbab2rp7plrvsm6gmfql551a8ai"))))
"1kjxh4gr651hpqkjfv89cfzr40hyvf3vjlda7mifiail83j7j07m"))))
(build-system python-build-system)
(home-page
"https://www.decalage.info/python/olefileio")
(home-page "https://www.decalage.info/python/olefileio")
(synopsis "Read and write Microsoft OLE2 files.")
(description
"@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)"
(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
(package
(name "python-lxml")
@ -5706,14 +5733,14 @@ converts incoming documents to Unicode and outgoing documents to UTF-8.")
(define-public python-soupsieve
(package
(name "python-soupsieve")
(version "1.9.1")
(version "1.9.2")
(source
(origin
(method url-fetch)
(uri (pypi-uri "soupsieve" version))
(sha256
(base32
"1jnzkiwmjl6yvqckc9mf689g87b6yz07sv868hap2aa5arggy3mj"))))
"0in9rc9q3h8w5b4qf7kvl3qxcvw6vrz35ckblchgf70hm6pg3dbj"))))
(build-system python-build-system)
(arguments `(#:tests? #f))
;;XXX: 2 tests fail currently despite claming they were to be
@ -6904,6 +6931,41 @@ and MAC network addresses.")
(define-public python2-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
(package
(name "python-wrapt")
@ -15798,6 +15860,42 @@ by Igor Pavlov.")
(define-public python2-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
(package
(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
(package
(name "jsoncpp")
(version "1.8.4")
(version "1.9.0")
(home-page "https://github.com/open-source-parsers/jsoncpp")
(source (origin
(method url-fetch)
(uri (string-append
"https://github.com/open-source-parsers/jsoncpp/archive/"
version ".tar.gz"))
(file-name (string-append name "-" version ".tar.gz"))
(method git-fetch)
(uri (git-reference (url home-page) (commit version)))
(file-name (git-file-name name version))
(sha256
(base32
"1dpxk8hkni5dq4mdw8qbaj40jmid3a31d1gh8iqcnfwkw34ym7f4"))))
"10wnwlq92gp32f5p55kjcc12jfsl0yq6f2y4abb0si6wym12krw9"))))
(build-system cmake-build-system)
(home-page "https://github.com/open-source-parsers/jsoncpp")
(arguments
`(#:configure-flags '("-DBUILD_SHARED_LIBS:BOOL=YES")))
(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
(package
(name "wine-staging-patchset-data")
(version "4.11")
(version "4.12")
(source
(origin
(method git-fetch)
@ -320,7 +320,7 @@ integrate Windows applications into your desktop.")
(file-name (git-file-name name version))
(sha256
(base32
"0h8qldqr9w1kwn48qgg5m1cs2xqkv8xxg2c66cvfka91hy886jcf"))))
"1drsrps6bd5gcafzcfrr9pzajhh5s6qg5la7q4qpwzlng9969f3r"))))
(build-system trivial-build-system)
(native-inputs
`(("bash" ,bash)
@ -366,7 +366,7 @@ integrate Windows applications into your desktop.")
(file-name (string-append name "-" version ".tar.xz"))
(sha256
(base32
"1rmyfwlynzs2niz7l2lwjs2axm6in6gb43ldbzyzsflxsmk5fl9f"))))
"1az5pcczq2zl1cvfdggzf89n0sf77m3fjkc8rnna8qr3n585q4h0"))))
(inputs `(("autoconf" ,autoconf) ; for autoreconf
("faudio" ,faudio)
("ffmpeg" ,ffmpeg)

18
gnu/tests/docker.scm
View File

@ -27,7 +27,6 @@
#:use-module (gnu services networking)
#:use-module (gnu services docker)
#:use-module (gnu services desktop)
#:use-module (gnu packages bootstrap) ; %bootstrap-guile
#:use-module (gnu packages docker)
#:use-module (gnu packages guile)
#:use-module (guix gexp)
@ -101,7 +100,7 @@ inside %DOCKER-OS."
marionette))
(test-equal "Load docker image and run it"
'("hello world" "hi!")
'("hello world" "hi!" "JSON!")
(marionette-eval
`(begin
(define slurp
@ -125,8 +124,15 @@ inside %DOCKER-OS."
(response2 (slurp ;default entry point
,(string-append #$docker-cli "/bin/docker")
"run" repository&tag
"-c" "(display \"hi!\")")))
(list response1 response2)))
"-c" "(display \"hi!\")"))
;; 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))
(test-end)
@ -144,7 +150,7 @@ inside %DOCKER-OS."
(version "0")
(source #f)
(build-system trivial-build-system)
(arguments `(#:guile ,%bootstrap-guile
(arguments `(#:guile ,guile-2.2
#:builder
(let ((out (assoc-ref %outputs "out")))
(mkdir out)
@ -158,7 +164,7 @@ standard output device and then enters a new line.")
(home-page #f)
(license license:public-domain)))
(profile (profile-derivation (packages->manifest
(list %bootstrap-guile
(list guile-2.2 guile-json
guest-script-package))
#:hooks '()
#: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
parted --script /dev/vdb mklabel gpt \\
mkpart primary ext2 1M 3M \\
mkpart primary ext2 3M 1.2G \\
mkpart primary ext2 3M 1.4G \\
set 1 boot on \\
set 1 bios_grub on
echo -n thepassphrase | \\

18
gnu/tests/singularity.scm
View File

@ -111,6 +111,21 @@
"run" #$image "-c" "(exit 42)"))
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)
(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
@ -122,7 +137,8 @@
(guile (set-guile-for-build (default-guile)))
;; 'singularity exec' insists on having /bin/sh in the image.
(profile (profile-derivation (packages->manifest
(list bash-minimal guile-2.2))
(list bash-minimal
guile-2.2 guile-json))
#:hooks '()
#:locales? #f))
(tarball (squashfs-image "singularity-pack" profile

43
guix/channels.scm
View File

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

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

17
guix/docker.scm
View File

@ -73,7 +73,7 @@
`((,(generate-tag path) . ((latest . ,id)))))
;; See https://github.com/opencontainers/image-spec/blob/master/config.md
(define* (config layer time arch #:key entry-point)
(define* (config layer time arch #:key entry-point (environment '()))
"Generate a minimal image configuration for the given LAYER file."
;; "architecture" must be values matching "platform.arch" in the
;; runtime-spec at
@ -81,9 +81,13 @@
`((architecture . ,arch)
(comment . "Generated by GNU Guix")
(created . ,time)
(config . ,(if entry-point
`((entrypoint . ,entry-point))
#nil))
(config . ,`((env . ,(map (match-lambda
((name . value)
(string-append name "=" value)))
environment))
,@(if entry-point
`((entrypoint . ,entry-point))
'())))
(container_config . #nil)
(os . "linux")
(rootfs . ((type . "layers")
@ -113,6 +117,7 @@ return \"a\"."
(system (utsname:machine (uname)))
database
entry-point
(environment '())
compressor
(creation-time (current-time time-utc)))
"Write to IMAGE a Docker image archive containing the given PATHS. PREFIX
@ -124,6 +129,9 @@ When DATABASE is true, copy it to /var/guix/db in the image and create
When ENTRY-POINT is true, it must be a list of strings; it is stored as the
entry point in the Docker image JSON structure.
ENVIRONMENT must be a list of name/value pairs. It specifies the environment
variables that must be defined in the resulting image.
SYMLINKS must be a list of (SOURCE -> TARGET) tuples describing symlinks to be
created in the image, where each TARGET is relative to PREFIX.
TRANSFORMATIONS must be a list of (OLD -> NEW) tuples describing how to
@ -234,6 +242,7 @@ SRFI-19 time-utc object, as the creation time in metadata."
(lambda ()
(scm->json (config (string-append id "/layer.tar")
time arch
#:environment environment
#:entry-point entry-point))))
(with-output-to-file "manifest.json"
(lambda ()

240
guix/gexp.scm
View File

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

9
guix/inferior.scm
View File

@ -59,6 +59,7 @@
inferior-eval
inferior-eval-with-store
inferior-object?
read-repl-response
inferior-packages
inferior-available-packages
@ -183,7 +184,8 @@ equivalent. Return #f if the inferior could not be launched."
(set-record-type-printer! <inferior-object> write-inferior-object)
(define (read-inferior-response inferior)
(define (read-repl-response port)
"Read a (guix repl) response from PORT and return it as a Scheme object."
(define sexp->object
(match-lambda
(('value value)
@ -191,12 +193,15 @@ equivalent. Return #f if the inferior could not be launched."
(('non-self-quoting address string)
(inferior-object address string))))
(match (read (inferior-socket inferior))
(match (read port)
(('values objects ...)
(apply values (map sexp->object objects)))
(('exception key objects ...)
(apply throw key (map sexp->object objects)))))
(define (read-inferior-response inferior)
(read-repl-response (inferior-socket inferior)))
(define (send-inferior-request exp inferior)
(write exp (inferior-socket inferior))
(newline (inferior-socket inferior)))

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

56
guix/scripts/repl.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -19,6 +19,7 @@
(define-module (guix scripts repl)
#:use-module (guix ui)
#:use-module (guix scripts)
#:use-module (guix repl)
#:use-module (guix utils)
#:use-module (guix packages)
#:use-module (gnu packages)
@ -29,8 +30,7 @@
#:autoload (system repl repl) (start-repl)
#:autoload (system repl server)
(make-tcp-server-socket make-unix-domain-server-socket)
#:export (machine-repl
guix-repl))
#:export (guix-repl))
;;; Commentary:
;;;
@ -68,62 +68,12 @@ Start a Guile REPL in the Guix execution environment.\n"))
(newline)
(show-bug-report-information))
(define (self-quoting? x)
"Return #t if X is self-quoting."
(letrec-syntax ((one-of (syntax-rules ()
((_) #f)
((_ pred rest ...)
(or (pred x)
(one-of rest ...))))))
(one-of symbol? string? pair? null? vector?
bytevector? number? boolean?)))
(define user-module
;; Module where we execute user code.
(let ((module (resolve-module '(guix-user) #f #f #:ensure #t)))
(beautify-user-module! module)
module))
(define* (machine-repl #:optional
(input (current-input-port))
(output (current-output-port)))
"Run a machine-usable REPL over ports INPUT and OUTPUT.
The protocol of this REPL is meant to be machine-readable and provides proper
support to represent multiple-value returns, exceptions, objects that lack a
read syntax, and so on. As such it is more convenient and robust than parsing
Guile's REPL prompt."
(define (value->sexp value)
(if (self-quoting? value)
`(value ,value)
`(non-self-quoting ,(object-address value)
,(object->string value))))
(write `(repl-version 0 0) output)
(newline output)
(force-output output)
(let loop ()
(match (read input)
((? eof-object?) #t)
(exp
(catch #t
(lambda ()
(let ((results (call-with-values
(lambda ()
(primitive-eval exp))
list)))
(write `(values ,@(map value->sexp results))
output)
(newline output)
(force-output output)))
(lambda (key . args)
(write `(exception ,key ,@(map value->sexp args)))
(newline output)
(force-output output)))
(loop)))))
(define (call-with-connection spec thunk)
"Dynamically-bind the current input and output ports according to SPEC and
call THUNK."

10
guix/ssh.scm
View File

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

11
guix/store.scm
View File

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

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
;; DRV is a long list as is the case with 'guix environment'.
(if use-substitutes?
(substitution-oracle store (map derivation-input-derivation inputs)
#:mode mode)
(substitution-oracle store inputs #:mode mode)
(const #f)))
(let*-values (((build download)
@ -844,18 +843,6 @@ check and report what is prerequisites are available for download."
#:mode mode
#:substitutable-info
substitutable-info))
((download) ; add the references of DOWNLOAD
(if use-substitutes?
(delete-duplicates
(append download
(filter-map (lambda (item)
(if (valid-path? store item)
#f
(substitutable-info item)))
(append-map
substitutable-references
download))))
download))
((graft hook build)
(match (fold (lambda (drv acc)
(let ((file (derivation-file-name drv)))

2
po/guix/POTFILES.in
View File

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

29
tests/derivations.scm
View File

@ -896,6 +896,35 @@
(((= derivation-file-name build))
(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"
(with-store store
(let* ((drv (build-expression->derivation store "prereq-subst-local"

37
tests/gexp.scm
View File

@ -832,6 +832,43 @@
(built-derivations (list drv))
(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"
(mlet* %store-monad
((one (text-file "one" (random-text)))