summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorMarius Bakke <marius@gnu.org>2020-05-26 22:30:51 +0200
committerMarius Bakke <marius@gnu.org>2020-05-26 22:30:51 +0200
commit9edb3f66fd807b096b48283debdcddccfea34bad (patch)
treecfd86f44ad51df4341a0d48cf4978117e11d7f59 /guix
parente5f95fd897ad32c93bb48ceae30021976a917979 (diff)
parentb6d18fbdf6ab4a8821a58aa16587676e835001f2 (diff)
Merge branch 'master' into staging
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/cmake.scm18
-rw-r--r--guix/build-system/glib-or-gtk.scm16
-rw-r--r--guix/build-system/gnu.scm16
-rw-r--r--guix/build-system/meson.scm14
-rw-r--r--guix/build-system/texlive.scm4
-rw-r--r--guix/build/cmake-build-system.scm2
-rw-r--r--guix/build/compile.scm29
-rw-r--r--guix/build/emacs-build-system.scm2
-rw-r--r--guix/build/gnu-bootstrap.scm114
-rw-r--r--guix/build/gnu-build-system.scm14
-rw-r--r--guix/build/store-copy.scm1
-rw-r--r--guix/build/syscalls.scm81
-rw-r--r--guix/build/utils.scm103
-rw-r--r--guix/channels.scm86
-rw-r--r--guix/derivations.scm59
-rw-r--r--guix/gexp.scm58
-rw-r--r--guix/git.scm1
-rw-r--r--guix/graph.scm69
-rw-r--r--guix/import/cran.scm1
-rw-r--r--guix/import/hackage.scm2
-rw-r--r--guix/licenses.scm2
-rw-r--r--guix/nar.scm30
-rw-r--r--guix/openpgp.scm1108
-rw-r--r--guix/packages.scm19
-rw-r--r--guix/profiles.scm11
-rw-r--r--guix/quirks.scm124
-rw-r--r--guix/scripts/environment.scm4
-rw-r--r--guix/scripts/graph.scm69
-rw-r--r--guix/scripts/pack.scm98
-rw-r--r--guix/scripts/package.scm37
-rw-r--r--guix/scripts/pull.scm2
-rw-r--r--guix/scripts/show.scm2
-rw-r--r--guix/scripts/system.scm15
-rw-r--r--guix/self.scm12
-rw-r--r--guix/store.scm44
-rw-r--r--guix/store/database.scm13
-rw-r--r--guix/tests.scm5
37 files changed, 2018 insertions, 267 deletions
diff --git a/guix/build-system/cmake.scm b/guix/build-system/cmake.scm
index ca88fadddf..29259c5785 100644
--- a/guix/build-system/cmake.scm
+++ b/guix/build-system/cmake.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Cyril Roelandt <tipecaml@gmail.com>
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;;
@@ -43,16 +43,19 @@
`((guix build cmake-build-system)
,@%gnu-build-system-modules))
-(define (default-cmake)
+(define (default-cmake target)
"Return the default CMake package."
;; Do not use `@' to avoid introducing circular dependencies.
(let ((module (resolve-interface '(gnu packages cmake))))
- (module-ref module 'cmake-minimal)))
+ (module-ref module
+ (if target
+ 'cmake-minimal-cross
+ 'cmake-minimal))))
(define* (lower name
#:key source inputs native-inputs outputs system target
- (cmake (default-cmake))
+ (cmake (default-cmake target))
#:allow-other-keys
#:rest arguments)
"Return a bag for NAME."
@@ -69,6 +72,7 @@
'())
,@`(("cmake" ,cmake))
,@native-inputs
+ ,@(if target '() inputs)
,@(if target
;; Use the standard cross inputs of
;; 'gnu-build-system'.
@@ -76,7 +80,7 @@
'())
;; Keep the standard inputs of 'gnu-build-system'.
,@(standard-packages)))
- (host-inputs inputs)
+ (host-inputs (if target inputs '()))
;; The cross-libc is really a target package, but for bootstrapping
;; reasons, we can't put it in 'host-inputs'. Namely, 'cross-gcc' is a
@@ -99,7 +103,7 @@
(build-type "RelWithDebInfo")
(tests? #t)
(test-target "test")
- (parallel-build? #t) (parallel-tests? #f)
+ (parallel-build? #t) (parallel-tests? #t)
(validate-runpath? #t)
(patch-shebangs? #t)
(strip-binaries? #t)
@@ -178,7 +182,7 @@ provides a 'CMakeLists.txt' file as its build system."
(build-type "RelWithDebInfo")
(tests? #f) ; nothing can be done
(test-target "test")
- (parallel-build? #t) (parallel-tests? #f)
+ (parallel-build? #t) (parallel-tests? #t)
(validate-runpath? #t)
(patch-shebangs? #t)
(strip-binaries? #t)
diff --git a/guix/build-system/glib-or-gtk.scm b/guix/build-system/glib-or-gtk.scm
index 8de7dfbfc2..fb1f8fb930 100644
--- a/guix/build-system/glib-or-gtk.scm
+++ b/guix/build-system/glib-or-gtk.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Cyril Roelandt <tipecaml@gmail.com>
;;; Copyright © 2014 Federico Beffa <beffa@fbengineering.ch>
;;;
@@ -92,15 +92,15 @@
(bag
(name name)
(system system)
- (host-inputs `(,@(if source
- `(("source" ,source))
- '())
- ,@inputs))
- (build-inputs `(("glib:bin" ,glib "bin") ; to compile schemas
+ (host-inputs (if source
+ `(("source" ,source))
+ '()))
+ (build-inputs `(,@native-inputs
+ ,@inputs
+ ("glib:bin" ,glib "bin") ; to compile schemas
,@(if implicit-inputs?
(standard-packages)
- '())
- ,@native-inputs))
+ '())))
(outputs outputs)
(build glib-or-gtk-build)
(arguments (strip-keyword-arguments private-keywords arguments)))))
diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm
index 7266fa0009..f59567febb 100644
--- a/guix/build-system/gnu.scm
+++ b/guix/build-system/gnu.scm
@@ -296,13 +296,19 @@ standard packages used as implicit inputs of the GNU build system."
`(("source" ,source))
'())
,@native-inputs
+
+ ;; When not cross-compiling, ensure implicit inputs come
+ ;; last. That way, libc headers come last, which allows
+ ;; #include_next to work correctly; see
+ ;; <https://bugs.gnu.org/30756>.
+ ,@(if target '() inputs)
,@(if (and target implicit-cross-inputs?)
(standard-cross-packages target 'host)
'())
,@(if implicit-inputs?
(standard-packages)
'())))
- (host-inputs inputs)
+ (host-inputs (if target inputs '()))
;; The cross-libc is really a target package, but for bootstrapping
;; reasons, we can't put it in 'host-inputs'. Namely, 'cross-gcc' is a
@@ -454,13 +460,19 @@ is one of `host' or `target'."
(libc (module-ref cross 'cross-libc)))
(case kind
((host)
+ ;; Cross-GCC appears once here, so that it's in $PATH...
`(("cross-gcc" ,(gcc target
#:xbinutils (binutils target)
#:libc (libc target)))
("cross-binutils" ,(binutils target))))
((target)
(let ((libc (libc target)))
- `(("cross-libc" ,libc)
+ ;; ... and once here, so that libstdc++ & co. are in
+ ;; CROSS_CPLUS_INCLUDE_PATH, etc.
+ `(("cross-gcc" ,(gcc target
+ #:xbinutils (binutils target)
+ #:libc libc))
+ ("cross-libc" ,libc)
;; MinGW's libc doesn't have a "static" output.
,@(if (member "static" (package-outputs libc))
diff --git a/guix/build-system/meson.scm b/guix/build-system/meson.scm
index b29f2f4ecf..b68bcb80de 100644
--- a/guix/build-system/meson.scm
+++ b/guix/build-system/meson.scm
@@ -74,13 +74,13 @@
(system system)
(build-inputs `(("meson" ,meson)
("ninja" ,ninja)
- ,@native-inputs))
- (host-inputs `(,@(if source
- `(("source" ,source))
- '())
- ,@inputs
- ;; Keep the standard inputs of 'gnu-build-system'.
- ,@(standard-packages)))
+ ,@native-inputs
+ ,@inputs
+ ;; Keep the standard inputs of 'gnu-build-system'.
+ ,@(standard-packages)))
+ (host-inputs (if source
+ `(("source" ,source))
+ '()))
(outputs outputs)
(build meson-build)
(arguments (strip-keyword-arguments private-keywords arguments)))))
diff --git a/guix/build-system/texlive.scm b/guix/build-system/texlive.scm
index ad99d1e2d0..8bbca0ccb7 100644
--- a/guix/build-system/texlive.scm
+++ b/guix/build-system/texlive.scm
@@ -42,8 +42,8 @@
;; These variables specify the SVN tag and the matching SVN revision. They
;; are taken from https://www.tug.org/svn/texlive/tags/
-(define %texlive-tag "texlive-2018.2")
-(define %texlive-revision 49435)
+(define %texlive-tag "texlive-2019.3")
+(define %texlive-revision 51265)
(define (texlive-origin name version locations hash)
"Return an <origin> object for a TeX Live package consisting of multiple
diff --git a/guix/build/cmake-build-system.scm b/guix/build/cmake-build-system.scm
index 9b1112f2d6..d1ff5071be 100644
--- a/guix/build/cmake-build-system.scm
+++ b/guix/build/cmake-build-system.scm
@@ -67,6 +67,8 @@
,@(if target
(list (string-append "-DCMAKE_C_COMPILER="
target "-gcc")
+ (string-append "-DCMAKE_CXX_COMPILER="
+ target "-g++")
(if (string-contains target "mingw")
"-DCMAKE_SYSTEM_NAME=Windows"
"-DCMAKE_SYSTEM_NAME=Linux"))
diff --git a/guix/build/compile.scm b/guix/build/compile.scm
index c4dbb6e34c..63f24fa7d4 100644
--- a/guix/build/compile.scm
+++ b/guix/build/compile.scm
@@ -84,9 +84,32 @@
(define (optimization-options file)
"Return the default set of optimizations options for FILE."
- (if (string-contains file "gnu/packages/")
- (optimizations-for-level 1) ;build faster
- (optimizations-for-level 3)))
+ (define (strip-option option lst)
+ (let loop ((lst lst)
+ (result '()))
+ (match lst
+ (()
+ (reverse result))
+ ((kw value rest ...)
+ (if (eq? kw option)
+ (append (reverse result) rest)
+ (loop rest (cons* value kw result)))))))
+
+ (define (override-option option value lst)
+ `(,option ,value ,@(strip-option option lst)))
+
+ (cond ((string-contains file "gnu/packages/")
+ ;; Level 0 is good enough but partial evaluation helps preserve the
+ ;; "macro writer's bill of rights".
+ (override-option #:partial-eval? #t
+ (optimizations-for-level 0)))
+ ((string-contains file "gnu/services/")
+ ;; '-O2 -Ono-letrectify' compiles about ~20% faster than '-O2' for
+ ;; large files like gnu/services/mail.scm.
+ (override-option #:letrectify? #f
+ (optimizations-for-level 2)))
+ (else
+ (optimizations-for-level 3))))
(define (scm->go file)
"Strip the \".scm\" suffix from FILE, and append \".go\"."
diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm
index 219310cf08..26ea59bc25 100644
--- a/guix/build/emacs-build-system.scm
+++ b/guix/build/emacs-build-system.scm
@@ -21,7 +21,7 @@
(define-module (guix build emacs-build-system)
#:use-module ((guix build gnu-build-system) #:prefix gnu:)
- #:use-module (guix build utils)
+ #:use-module ((guix build utils) #:hide (delete))
#:use-module (guix build emacs-utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
diff --git a/guix/build/gnu-bootstrap.scm b/guix/build/gnu-bootstrap.scm
new file mode 100644
index 0000000000..1cb9dc5512
--- /dev/null
+++ b/guix/build/gnu-bootstrap.scm
@@ -0,0 +1,114 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2020 Timothy Sample <samplet@ngyro.com>
+;;;
+;;; 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/>.
+
+;; Commentary:
+;;
+;; These procedures can be used to adapt the GNU Build System to build
+;; pure Scheme packages targeting the bootstrap Guile.
+;;
+;; Code:
+
+(define-module (guix build gnu-bootstrap)
+ #:use-module (guix build utils)
+ #:use-module (system base compile)
+ #:export (bootstrap-configure
+ bootstrap-build
+ bootstrap-install))
+
+(define (bootstrap-configure version modules scripts)
+ "Create a procedure that configures an early bootstrap package. The
+procedure will search the MODULES directory and configure all of the
+'.in' files with VERSION. It will then search the SCRIPTS directory and
+configure all of the '.in' files with the bootstrap Guile and its module
+and object directories."
+ (lambda* (#:key inputs outputs #:allow-other-keys)
+ (let* ((out (assoc-ref outputs "out"))
+ (guile-dir (assoc-ref inputs "guile"))
+ (guile (string-append guile-dir "/bin/guile"))
+ (moddir (string-append out "/share/guile/site/"
+ (effective-version)))
+ (godir (string-append out "/lib/guile/"
+ (effective-version)
+ "/site-ccache")))
+ (for-each (lambda (template)
+ (format #t "Configuring ~a~%" template)
+ (let ((target (string-drop-right template 3)))
+ (copy-file template target)
+ (substitute* target
+ (("@VERSION@") version))))
+ (find-files modules
+ (lambda (fn st)
+ (string-suffix? ".in" fn))))
+ (for-each (lambda (template)
+ (format #t "Configuring ~a~%" template)
+ (let ((target (string-drop-right template 3)))
+ (copy-file template target)
+ (substitute* target
+ (("@GUILE@") guile)
+ (("@MODDIR@") moddir)
+ (("@GODIR@") godir))
+ (chmod target #o755)))
+ (find-files scripts
+ (lambda (fn st)
+ (string-suffix? ".in" fn))))
+ #t)))
+
+(define (bootstrap-build modules)
+ "Create a procedure that builds an early bootstrap package. The
+procedure will search the MODULES directory and compile all of the
+'.scm' files."
+ (lambda _
+ (add-to-load-path (getcwd))
+ (for-each (lambda (scm)
+ (let* ((base (string-drop-right scm 4))
+ (go (string-append base ".go"))
+ (dir (dirname scm)))
+ (format #t "Compiling ~a~%" scm)
+ (compile-file scm #:output-file go)))
+ (find-files modules "\\.scm$"))
+ #t))
+
+(define (bootstrap-install modules scripts)
+ "Create a procedure that installs an early bootstrap package. The
+procedure will install all of the '.scm' and '.go' files in the MODULES
+directory, and all the executable files in the SCRIPTS directory."
+ (lambda* (#:key inputs outputs #:allow-other-keys)
+ (let* ((out (assoc-ref outputs "out"))
+ (guile-dir (assoc-ref inputs "guile"))
+ (guile (string-append guile-dir "/bin/guile"))
+ (moddir (string-append out "/share/guile/site/"
+ (effective-version)))
+ (godir (string-append out "/lib/guile/"
+ (effective-version)
+ "/site-ccache")))
+ (for-each (lambda (scm)
+ (let* ((base (string-drop-right scm 4))
+ (go (string-append base ".go"))
+ (dir (dirname scm)))
+ (format #t "Installing ~a~%" scm)
+ (install-file scm (string-append moddir "/" dir))
+ (format #t "Installing ~a~%" go)
+ (install-file go (string-append godir "/" dir))))
+ (find-files modules "\\.scm$"))
+ (for-each (lambda (script)
+ (format #t "Installing ~a~%" script)
+ (install-file script (string-append out "/bin")))
+ (find-files scripts
+ (lambda (fn st)
+ (executable-file? fn))))
+ #t)))
diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm
index 4df0bb4904..2e7dff2034 100644
--- a/guix/build/gnu-build-system.scm
+++ b/guix/build/gnu-build-system.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2020 Brendan Tildesley <mail@brendan.scot>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -173,12 +174,16 @@ working directory."
\"autoreconf\". Otherwise do nothing."
;; Note: Run that right after 'unpack' so that the generated files are
;; visible when the 'patch-source-shebangs' phase runs.
- (if (not (file-exists? "configure"))
+ (define (script-exists? file)
+ (and (file-exists? file)
+ (not (file-is-directory? file))))
+
+ (if (not (script-exists? "configure"))
;; First try one of the BOOTSTRAP-SCRIPTS. If none exists, and it's
;; clearly an Autoconf-based project, run 'autoreconf'. Otherwise, do
;; nothing (perhaps the user removed or overrode the 'configure' phase.)
- (let ((script (find file-exists? bootstrap-scripts)))
+ (let ((script (find script-exists? bootstrap-scripts)))
;; GNU packages often invoke the 'git-version-gen' script from
;; 'configure.ac' so make sure it has a valid shebang.
(false-if-file-not-found
@@ -186,12 +191,15 @@ working directory."
(if script
(let ((script (string-append "./" script)))
+ (setenv "NOCONFIGURE" "true")
(format #t "running '~a'~%" script)
(if (executable-file? script)
(begin
(patch-shebang script)
(invoke script))
- (invoke "sh" script)))
+ (invoke "sh" script))
+ ;; Let's clean up after ourselves.
+ (unsetenv "NOCONFIGURE"))
(if (or (file-exists? "configure.ac")
(file-exists? "configure.in"))
(invoke "autoreconf" "-vif")
diff --git a/guix/build/store-copy.scm b/guix/build/store-copy.scm
index 549aa4f28b..ad551bca98 100644
--- a/guix/build/store-copy.scm
+++ b/guix/build/store-copy.scm
@@ -35,6 +35,7 @@
read-reference-graph
+ file-size
closure-size
populate-store))
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 73b439fb7d..ff008c5b78 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -5,6 +5,7 @@
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2019 Guillaume Le Vaillant <glv@posteo.net>
;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu>
+;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -23,6 +24,7 @@
(define-module (guix build syscalls)
#:use-module (system foreign)
+ #:use-module (system base target)
#:use-module (rnrs bytevectors)
#:autoload (ice-9 binary-ports) (get-bytevector-n)
#:use-module (srfi srfi-1)
@@ -77,6 +79,8 @@
fdatasync
pivot-root
scandir*
+ getxattr
+ setxattr
fcntl-flock
lock-file
@@ -194,9 +198,14 @@
(* (sizeof* type) n))
((_ type)
(let-syntax ((v (lambda (s)
- (let ((val (sizeof type)))
- (syntax-case s ()
- (_ val))))))
+ ;; When compiling natively, call 'sizeof' at expansion
+ ;; time; otherwise, emit code to call it at run time.
+ (syntax-case s ()
+ (_
+ (if (= (target-word-size)
+ (with-target %host-type target-word-size))
+ (sizeof type)
+ #'(sizeof type)))))))
v))))
(define-syntax alignof*
@@ -208,9 +217,14 @@
(alignof* type))
((_ type)
(let-syntax ((v (lambda (s)
- (let ((val (alignof type)))
- (syntax-case s ()
- (_ val))))))
+ ;; When compiling natively, call 'sizeof' at expansion
+ ;; time; otherwise, emit code to call it at run time.
+ (syntax-case s ()
+ (_
+ (if (= (target-word-size)
+ (with-target %host-type target-word-size))
+ (alignof type)
+ #'(alignof type)))))))
v))))
(define-syntax align ;as found in (system foreign)
@@ -711,6 +725,49 @@ backend device."
(list (strerror err))
(list err))))))
+(define getxattr
+ (let ((proc (syscall->procedure ssize_t "getxattr"
+ `(* * * ,size_t))))
+ (lambda (file key)
+ "Get the extended attribute value for KEY on FILE."
+ (let-values (((size err)
+ ;; Get size of VALUE for buffer.
+ (proc (string->pointer/utf-8 file)
+ (string->pointer key)
+ (string->pointer "")
+ 0)))
+ (cond ((< size 0) #f)
+ ((zero? size) "")
+ ;; Get VALUE in buffer of SIZE. XXX actual size can race.
+ (else (let*-values (((buf) (make-bytevector size))
+ ((size err)
+ (proc (string->pointer/utf-8 file)
+ (string->pointer key)
+ (bytevector->pointer buf)
+ size)))
+ (if (>= size 0)
+ (utf8->string buf)
+ (throw 'system-error "getxattr" "~S: ~A"
+ (list file key (strerror err))
+ (list err))))))))))
+
+(define setxattr
+ (let ((proc (syscall->procedure int "setxattr"
+ `(* * * ,size_t ,int))))
+ (lambda* (file key value #:optional (flags 0))
+ "Set extended attribute KEY to VALUE on FILE."
+ (let*-values (((bv) (string->utf8 value))
+ ((ret err)
+ (proc (string->pointer/utf-8 file)
+ (string->pointer key)
+ (bytevector->pointer bv)
+ (bytevector-length bv)
+ flags)))
+ (unless (zero? ret)
+ (throw 'system-error "setxattr" "~S: ~A"
+ (list file key value (strerror err))
+ (list err)))))))
+
;;;
;;; Random.
@@ -1194,6 +1251,8 @@ bytes."
;;;
(define SIOCGIFCONF ;from <bits/ioctls.h>
+ ; <net/if.h>
+ ; <hurd/ioctl.h>
(if (string-contains %host-type "linux")
#x8912 ;GNU/Linux
#xf00801a4)) ;GNU/Hurd
@@ -1204,23 +1263,23 @@ bytes."
(define SIOCSIFFLAGS
(if (string-contains %host-type "linux")
#x8914 ;GNU/Linux
- -1)) ;FIXME: GNU/Hurd?
+ #x84804190)) ;GNU/Hurd
(define SIOCGIFADDR
(if (string-contains %host-type "linux")
#x8915 ;GNU/Linux
- -1)) ;FIXME: GNU/Hurd?
+ #xc08401a1)) ;GNU/Hurd
(define SIOCSIFADDR
(if (string-contains %host-type "linux")
#x8916 ;GNU/Linux
- -1)) ;FIXME: GNU/Hurd?
+ #x8084018c)) ;GNU/Hurd
(define SIOCGIFNETMASK
(if (string-contains %host-type "linux")
#x891b ;GNU/Linux
- -1)) ;FIXME: GNU/Hurd?
+ #xc08401a5)) ;GNU/Hurd
(define SIOCSIFNETMASK
(if (string-contains %host-type "linux")
#x891c ;GNU/Linux
- -1)) ;FIXME: GNU/Hurd?
+ #x80840196)) ;GNU/Hurd
(define SIOCADDRT
(if (string-contains %host-type "linux")
#x890B ;GNU/Linux
diff --git a/guix/build/utils.scm b/guix/build/utils.scm
index b8be73ead4..419c10195b 100644
--- a/guix/build/utils.scm
+++ b/guix/build/utils.scm
@@ -108,6 +108,8 @@
invoke/quiet
+ make-desktop-entry-file
+
locale-category->string))
@@ -892,7 +894,7 @@ transferred and the continuation of the transfer as a thunk."
(x x)))
(define patch-shebang
- (let ((shebang-rx (make-regexp "^[[:blank:]]*([[:graph:]]+)[[:blank:]]*([[:graph:]]*)(.*)$")))
+ (let ((shebang-rx (make-regexp "^[[:blank:]]*(/[[:graph:]]+)[[:blank:]]*([[:graph:]]*)(.*)$")))
(lambda* (file
#:optional
(path (search-path-as-string->list (getenv "PATH")))
@@ -1324,6 +1326,105 @@ not supported."
(&wrap-error (program prog)
(type 'no-interpreter-found)))))))))
+(define* (make-desktop-entry-file destination #:key
+ (type "Application") ; One of "Application", "Link" or "Directory".
+ (version "1.1")
+ name
+ (generic-name name)
+ (no-display #f)
+ comment
+ icon
+ (hidden #f)
+ only-show-in
+ not-show-in
+ (d-bus-activatable #f)
+ try-exec
+ exec
+ path
+ (terminal #f)
+ actions
+ mime-type
+ (categories "Application")
+ implements
+ keywords
+ (startup-notify #t)
+ startup-w-m-class
+ #:rest all-args)
+ "Create a desktop entry file at DESTINATION.
+You must specify NAME.
+
+Values can be booleans, numbers, strings or list of strings.
+
+Additionally, locales can be specified with an alist where the key is the
+locale. The #f key specifies the default. Example:
+
+ #:name '((#f \"I love Guix\") (\"fr\" \"J'aime Guix\"))
+
+produces
+
+ Name=I love Guix
+ Name[fr]=J'aime Guix
+
+For a complete description of the format, see the specifications at
+https://specifications.freedesktop.org/desktop-entry-spec/desktop-entry-spec-latest.html."
+ (define (escape-semicolon s)
+ (string-join (string-split s #\;) "\\;"))
+ (define* (parse key value #:optional locale)
+ (set! value (match value
+ (#t "true")
+ (#f "false")
+ ((? number? n) n)
+ ((? string? s) (escape-semicolon s))
+ ((? list? value)
+ (catch 'wrong-type-arg
+ (lambda () (string-join (map escape-semicolon value) ";"))
+ (lambda args (error "List arguments can only contain strings: ~a" args))))
+ (_ (error "Value must be a boolean, number, string or list of strings"))))
+ (format #t "~a=~a~%"
+ (if locale
+ (format #f "~a[~a]" key locale)
+ key)
+ value))
+
+ (define key-error-message "This procedure only takes key arguments beside DESTINATION")
+
+ (unless name
+ (error "Missing NAME key argument"))
+ (unless (member #:type all-args)
+ (set! all-args (append (list #:type type) all-args)))
+ (mkdir-p (dirname destination))
+
+ (with-output-to-file destination
+ (lambda ()
+ (format #t "[Desktop Entry]~%")
+ (let loop ((args all-args))
+ (match args
+ (() #t)
+ ((_) (error key-error-message))
+ ((key value . ...)
+ (unless (keyword? key)
+ (error key-error-message))
+ (set! key
+ (string-join (map string-titlecase
+ (string-split (symbol->string
+ (keyword->symbol key))
+ #\-))
+ ""))
+ (match value
+ (((_ . _) . _)
+ (for-each (lambda (locale-subvalue)
+ (parse key
+ (if (and (list? (cdr locale-subvalue))
+ (= 1 (length (cdr locale-subvalue))))
+ ;; Support both proper and improper lists for convenience.
+ (cadr locale-subvalue)
+ (cdr locale-subvalue))
+ (car locale-subvalue)))
+ value))
+ (_
+ (parse key value)))
+ (loop (cddr args))))))))
+
;;;
;;; Locales.
diff --git a/guix/channels.scm b/guix/channels.scm
index 041fae2a9c..aca8302ba0 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -47,6 +47,7 @@
#:use-module (srfi srfi-35)
#:autoload (guix self) (whole-package make-config.scm)
#:autoload (guix inferior) (gexp->derivation-in-inferior) ;FIXME: circular dep
+ #:autoload (guix quirks) (%quirks %patches applicable-patch? apply-patch)
#:use-module (ice-9 match)
#:use-module (ice-9 vlist)
#:use-module ((ice-9 rdelim) #:select (read-string))
@@ -199,6 +200,37 @@ description file or its default value."
channel INSTANCE."
(channel-metadata-dependencies (channel-instance-metadata instance)))
+(define (apply-patches checkout commit patches)
+ "Apply the matching PATCHES to CHECKOUT, modifying files in place. The
+result is unspecified."
+ (let loop ((patches patches))
+ (match patches
+ (() #t)
+ ((patch rest ...)
+ (when (applicable-patch? patch checkout commit)
+ (apply-patch patch checkout))
+ (loop rest)))))
+
+(define* (latest-channel-instance store channel
+ #:key (patches %patches))
+ "Return the latest channel instance for CHANNEL."
+ (define (dot-git? file stat)
+ (and (string=? (basename file) ".git")
+ (eq? 'directory (stat:type stat))))
+
+ (let-values (((checkout commit)
+ (update-cached-checkout (channel-url channel)
+ #:ref (channel-reference channel))))
+ (when (guix-channel? channel)
+ ;; Apply the relevant subset of PATCHES directly in CHECKOUT. This is
+ ;; safe to do because 'switch-to-ref' eventually does a hard reset.
+ (apply-patches checkout commit patches))
+
+ (let* ((name (url+commit->name (channel-url channel) commit))
+ (checkout (add-to-store store name #t "sha256" checkout
+ #:select? (negate dot-git?))))
+ (channel-instance channel commit checkout))))
+
(define* (latest-channel-instances store channels #:optional (previous-channels '()))
"Return a list of channel instances corresponding to the latest checkouts of
CHANNELS and the channels on which they depend. PREVIOUS-CHANNELS is a list
@@ -224,20 +256,16 @@ of previously processed channels."
(G_ "Updating channel '~a' from Git repository at '~a'...~%")
(channel-name channel)
(channel-url channel))
- (let-values (((checkout commit)
- (latest-repository-commit store (channel-url channel)
- #:ref (channel-reference
- channel))))
- (let ((instance (channel-instance channel commit checkout)))
- (let-values (((new-instances new-channels)
- (latest-channel-instances
- store
- (channel-instance-dependencies instance)
- previous-channels)))
- (values (append (cons channel new-channels)
- previous-channels)
- (append (cons instance new-instances)
- instances))))))))
+ (let ((instance (latest-channel-instance store channel)))
+ (let-values (((new-instances new-channels)
+ (latest-channel-instances
+ store
+ (channel-instance-dependencies instance)
+ previous-channels)))
+ (values (append (cons channel new-channels)
+ previous-channels)
+ (append (cons instance new-instances)
+ instances)))))))
previous-channels
'() ;instances
channels))
@@ -309,36 +337,6 @@ to '%package-module-path'."
(gexp->derivation-in-inferior name build core)))
-(define (syscalls-reexports-local-variables? source)
- "Return true if (guix build syscalls) contains the bug described at
-<https://bugs.gnu.org/36723>."
- (catch 'system-error
- (lambda ()
- (define content
- (call-with-input-file (string-append source
- "/guix/build/syscalls.scm")
- read-string))
-
- ;; The faulty code would use the 're-export' macro, causing the
- ;; 'AT_SYMLINK_NOFOLLOW' local variable to be re-exported when using
- ;; Guile > 2.2.4.
- (string-contains content "(re-export variable)"))
- (lambda args
- (if (= ENOENT (system-error-errno args))
- #f
- (apply throw args)))))
-
-(define (guile-2.2.4)
- (module-ref (resolve-interface '(gnu packages guile))
- 'guile-2.2.4))
-
-(define %quirks
- ;; List of predicate/package pairs. This allows us provide information
- ;; about specific Guile versions that old Guix revisions might need to use
- ;; just to be able to build and run the trampoline in %SELF-BUILD-FILE. See
- ;; <https://bugs.gnu.org/37506>
- `((,syscalls-reexports-local-variables? . ,guile-2.2.4)))
-
(define* (guile-for-source source #:optional (quirks %quirks))
"Return the Guile package to use when building SOURCE or #f if the default
'%guile-for-build' should be good enough."
diff --git a/guix/derivations.scm b/guix/derivations.scm
index f6d6f7db25..7db61d272f 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -1105,39 +1105,13 @@ recursively."
(string-tokenize (dirname file-name) not-slash))))))
(define* (imported-files store files ;deprecated
- #:key (name "file-import")
- (system (%current-system))
- (guile (%guile-for-build)))
- "Return a derivation that imports FILES into STORE. FILES must be a list
+ #:key (name "file-import"))
+ "Return a store item that contains FILES. FILES must be a list
of (FINAL-PATH . FILE-NAME) pairs; each FILE-NAME is read from the file
system, imported, and appears under FINAL-PATH in the resulting store path."
- (let* ((files (map (match-lambda
- ((final-path . file-name)
- (list final-path
- (add-to-store store (basename final-path) #f
- "sha256" file-name))))
- files))
- (builder
- `(begin
- (mkdir %output) (chdir %output)
- ,@(append-map (match-lambda
- ((final-path store-path)
- (append (match (parent-directories final-path)
- (() '())
- ((head ... tail)
- (append (map (lambda (d)
- `(false-if-exception
- (mkdir ,d)))
- head)
- `((or (file-exists? ,tail)
- (mkdir ,tail))))))
- `((symlink ,store-path ,final-path)))))
- files))))
- (build-expression->derivation store name builder
- #:system system
- #:inputs files
- #:guile-for-build guile
- #:local-build? #t)))
+ (add-file-tree-to-store store
+ `(,name directory
+ ,@(file-mapping->tree files))))
;; The "file not found" error condition.
(define-condition-type &file-search-error &error
@@ -1164,10 +1138,8 @@ of symbols.)"
(define* (%imported-modules store modules ;deprecated
#:key (name "module-import")
- (system (%current-system))
- (guile (%guile-for-build))
(module-path %load-path))
- "Return a derivation that contains the source files of MODULES, a list of
+ "Return a store item that contains the source files of MODULES, a list of
module names such as `(ice-9 q)'. All of MODULES must be in the MODULE-PATH
search path."
;; TODO: Determine the closure of MODULES, build the `.go' files,
@@ -1176,8 +1148,7 @@ search path."
(let ((f (module->source-file-name m)))
(cons f (search-path* module-path f))))
modules)))
- (imported-files store files #:name name #:system system
- #:guile guile)))
+ (imported-files store files #:name name)))
(define* (%compiled-modules store modules ;deprecated
#:key (name "module-import-compiled")
@@ -1187,11 +1158,8 @@ search path."
"Return a derivation that builds a tree containing the `.go' files
corresponding to MODULES. All the MODULES are built in a context where
they can refer to each other."
- (let* ((module-drv (%imported-modules store modules
- #:system system
- #:guile guile
+ (let* ((module-dir (%imported-modules store modules
#:module-path module-path))
- (module-dir (derivation->output-path module-drv))
(files (map (lambda (m)
(let ((f (string-join (map symbol->string m)
"/")))
@@ -1222,7 +1190,7 @@ they can refer to each other."
files)))
(build-expression->derivation store name builder
- #:inputs `(("modules" ,module-drv))
+ #:inputs `(("modules" ,module-dir))
#:system system
#:guile-for-build guile
#:local-build? #t)))
@@ -1240,8 +1208,7 @@ MODULES are compiled."
(list modules (derivation-file-name guile) system))
(or (hash-ref %module-cache key)
- (let ((result (cons (%imported-modules store modules
- #:system system #:guile guile)
+ (let ((result (cons (%imported-modules store modules)
(%compiled-modules store modules
#:system system #:guile guile))))
(hash-set! %module-cache key result)
@@ -1375,10 +1342,8 @@ and PROPERTIES."
#:guile guile-drv
#:system system)
'(#f . #f)))
- (mod-drv (car mod+go-drv))
+ (mod-dir (car mod+go-drv))
(go-drv (cdr mod+go-drv))
- (mod-dir (and mod-drv
- (derivation->output-path mod-drv)))
(go-dir (and go-drv
(derivation->output-path go-drv))))
(derivation store name guile
@@ -1395,7 +1360,7 @@ and PROPERTIES."
#:inputs `((,(or guile-for-build (%guile-for-build)))
(,builder)
,@(map cdr inputs)
- ,@(if mod-drv `((,mod-drv) (,go-drv)) '()))
+ ,@(if mod-dir `((,mod-dir) (,go-drv)) '()))
;; When MODULES is non-empty, shamelessly clobber
;; $GUILE_LOAD_COMPILED_PATH.
diff --git a/guix/gexp.scm b/guix/gexp.scm
index c320065546..2a4b36519c 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -787,7 +787,7 @@ second element is the derivation to compile them."
(target 'current)
(graft? (%graft?))
(guile-for-build (%guile-for-build))
- (effective-version "2.2")
+ (effective-version "3.0")
deprecation-warnings)
"*Note: This API is subject to change; use at your own risk!*
@@ -888,7 +888,7 @@ derivations--e.g., code evaluated for its side effects."
(modules '())
(module-path %load-path)
(guile-for-build (%guile-for-build))
- (effective-version "2.2")
+ (effective-version "3.0")
(graft? (%graft?))
references-graphs
allowed-references disallowed-references
@@ -1304,49 +1304,6 @@ execution environment."
;;; Module handling.
;;;
-(define %not-slash
- (char-set-complement (char-set #\/)))
-
-(define (file-mapping->tree mapping)
- "Convert MAPPING, an alist like:
-
- ((\"guix/build/utils.scm\" . \"…/utils.scm\"))
-
-to a tree suitable for 'interned-file-tree'."
- (let ((mapping (map (match-lambda
- ((destination . source)
- (cons (string-tokenize destination
- %not-slash)
- source)))
- mapping)))
- (fold (lambda (pair result)
- (match pair
- ((destination . source)
- (let loop ((destination destination)
- (result result))
- (match destination
- ((file)
- (let* ((mode (stat:mode (stat source)))
- (type (if (zero? (logand mode #o100))
- 'regular
- 'executable)))
- (alist-cons file
- `(,type (file ,source))
- result)))
- ((file rest ...)
- (let ((directory (assoc-ref result file)))
- (alist-cons file
- `(directory
- ,@(loop rest
- (match directory
- (('directory . entries) entries)
- (#f '()))))
- (if directory
- (alist-delete file result)
- result)))))))))
- '()
- mapping)))
-
(define %utils-module
;; This file provides 'mkdir-p', needed to implement 'imported-files' and
;; other primitives below. Note: We give the file name relative to this
@@ -1481,14 +1438,9 @@ TARGET, a GNU triplet."
(ice-9 format)
(srfi srfi-1)
(srfi srfi-26)
+ (system base target)
(system base compile))
- ;; TODO: Inline this on the next rebuild cycle.
- (ungexp-splicing
- (if target
- (gexp ((use-modules (system base target))))
- (gexp ())))
-
(define (regular? file)
(not (member file '("." ".."))))
@@ -1603,12 +1555,12 @@ TARGET, a GNU triplet."
;;;
(define (default-guile)
- ;; Lazily resolve 'guile-2.2' (not 'guile-final' because this is for
+ ;; Lazily resolve 'guile-3.0' (not 'guile-final' because this is for
;; programs returned by 'program-file' and we don't want to keep references
;; to several Guile packages). This module must not refer to (gnu …)
;; modules directly, to avoid circular dependencies, hence this hack.
(module-ref (resolve-interface '(gnu packages guile))
- 'guile-2.2))
+ 'guile-3.0))
(define* (load-path-expression modules #:optional (path %load-path)
#:key (extensions '()) system target)
diff --git a/guix/git.scm b/guix/git.scm
index 5fffd429bd..92121156cf 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -40,6 +40,7 @@
with-repository
update-cached-checkout
+ url+commit->name
latest-repository-commit
commit-difference
diff --git a/guix/graph.scm b/guix/graph.scm
index d7fd5f3e4b..b695ca4306 100644
--- a/guix/graph.scm
+++ b/guix/graph.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
@@ -42,6 +42,7 @@
traverse/depth-first
node-transitive-edges
node-reachable-count
+ shortest-path
%graph-backends
%d3js-backend
@@ -140,6 +141,72 @@ typically returned by 'node-edges' or 'node-back-edges'."
0
nodes node-edges))
+(define (shortest-path node1 node2 type)
+ "Return as a monadic value the shorted path, represented as a list, from
+NODE1 to NODE2 of the given TYPE. Return #f when there is no path."
+ (define node-edges
+ (node-type-edges type))
+
+ (define (find-shortest lst)
+ ;; Return the shortest path among LST, where each path is represented as a
+ ;; vlist.
+ (let loop ((lst lst)
+ (best +inf.0)
+ (shortest #f))
+ (match lst
+ (()
+ shortest)
+ ((head . tail)
+ (let ((len (vlist-length head)))
+ (if (< len best)
+ (loop tail len head)
+ (loop tail best shortest)))))))
+
+ (define (find-path node path paths)
+ ;; Return the a vhash that maps nodes to paths, with each path from the
+ ;; given node to NODE2.
+ (define (augment-paths child paths)
+ ;; When using %REFERENCE-NODE-TYPE, nodes can contain self references,
+ ;; hence this test.
+ (if (eq? child node)
+ (store-return paths)
+ (find-path child vlist-null paths)))
+
+ (cond ((eq? node node2)
+ (store-return (vhash-consq node (vlist-cons node path)
+ paths)))
+ ((vhash-assq node paths)
+ (store-return paths))
+ (else
+ ;; XXX: We could stop recursing if one if CHILDREN is NODE2, but in
+ ;; practice it's good enough.
+ (mlet* %store-monad ((children (node-edges node))
+ (paths (foldm %store-monad
+ augment-paths
+ paths
+ children)))
+ (define sub-paths
+ (filter-map (lambda (child)
+ (match (vhash-assq child paths)
+ (#f #f)
+ ((_ . path) path)))
+ children))
+
+ (match sub-paths
+ (()
+ (return (vhash-consq node #f paths)))
+ (lst
+ (return (vhash-consq node
+ (vlist-cons node (find-shortest sub-paths))
+ paths))))))))
+
+ (mlet %store-monad ((paths (find-path node1
+ (vlist-cons node1 vlist-null)
+ vlist-null)))
+ (return (match (vhash-assq node1 paths)
+ ((_ . #f) #f)
+ ((_ . path) (vlist->list path))))))
+
;;;
;;; Graphviz export.
diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index 53b930acd0..ad66a644ee 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -312,6 +312,7 @@ empty list when the FIELD cannot be found."
(define default-r-packages
(list "base"
"compiler"
+ "datasets"
"grDevices"
"graphics"
"grid"
diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm
index 9cf07c9504..dbc1afa4a7 100644
--- a/guix/import/hackage.scm
+++ b/guix/import/hackage.scm
@@ -1,7 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
;;; Copyright © 2016 Eric Bavier <bavier@member.fsf.org>
-;;; Copyright © 2016 ng0 <ng0@n0.is>
+;;; Copyright © 2016 Nikita <nikita@n0.is>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2019 Robert Vollmert <rob@vllmrt.net>
;;;
diff --git a/guix/licenses.scm b/guix/licenses.scm
index ab2ad3f169..a16d2241ad 100644
--- a/guix/licenses.scm
+++ b/guix/licenses.scm
@@ -8,7 +8,7 @@
;;; Copyright © 2016 Leo Famulari <leo@famulari.name>
;;; Copyright © 2016 Fabian Harfert <fhmgufs@web.de>
;;; Copyright © 2016 Rene Saavedra <rennes@openmailbox.org>
-;;; Copyright © 2016, 2017 ng0 <ng0@n0.is>
+;;; Copyright © 2016, 2017 Nikita <nikita@n0.is>
;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2017 Petter <petter@mykolab.ch>
;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
diff --git a/guix/nar.scm b/guix/nar.scm
index 29636aa0f8..eff4becbce 100644
--- a/guix/nar.scm
+++ b/guix/nar.scm
@@ -82,10 +82,28 @@
REFERENCES and DERIVER. When LOCK? is true, acquire exclusive locks on TARGET
before attempting to register it; otherwise, assume TARGET's locks are already
held."
+ ;; TODO: make this reusable
+ (define (acquire-lock file)
+ (let ((port (lock-file file)))
+ ;; There is an inherent race condition between opening the lock file and
+ ;; attempting to acquire the lock on it, and because we like deleting
+ ;; these lock files when we release them, only the first successful
+ ;; acquisition on a given lock file matters. To make it easier to tell
+ ;; when an acquisition is and isn't the first, the first to acquire it
+ ;; writes a deletion token (arbitrary character) prior to releasing the
+ ;; lock.
+ (if (zero? (stat:size (stat port)))
+ port
+ ;; if FILE is non-empty, that's because it contains the deletion
+ ;; token, so we aren't the first to acquire it. So try again!
+ (begin
+ (close port)
+ (acquire-lock file)))))
+
(with-database %default-database-file db
(unless (path-id db target)
(let ((lock (and lock?
- (lock-file (string-append target ".lock")))))
+ (acquire-lock (string-append target ".lock")))))
(unless (path-id db target)
;; If FILE already exists, delete it (it's invalid anyway.)
@@ -102,6 +120,12 @@ held."
#:deriver deriver))
(when lock?
+ (delete-file (string-append target ".lock"))
+ ;; Write the deletion token to inform anyone who acquires the lock
+ ;; on this particular file next that they aren't the first to
+ ;; acquire it, so they should retry.
+ (display "d" lock)
+ (force-output lock)
(unlock-file lock))))))
(define (temporary-store-file)
@@ -114,8 +138,8 @@ held."
(define-syntax-rule (with-temporary-store-file name body ...)
"Evaluate BODY with NAME bound to the file name of a temporary store item
protected from GC."
- (let loop ((name (temporary-store-file)))
- (with-store store
+ (with-store store
+ (let loop ((name (temporary-store-file)))
;; Add NAME to the current process' roots. (Opening this connection to
;; the daemon allows us to reuse its code that deals with the
;; per-process roots file.)
diff --git a/guix/openpgp.scm b/guix/openpgp.scm
new file mode 100644
index 0000000000..b74f8ff5bf
--- /dev/null
+++ b/guix/openpgp.scm
@@ -0,0 +1,1108 @@
+;; -*- mode: scheme; coding: utf-8 -*-
+;; Copyright © 2010, 2012 Göran Weinholt <goran@weinholt.se>
+;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
+
+;; Permission is hereby granted, free of charge, to any person obtaining a
+;; copy of this software and associated documentation files (the "Software"),
+;; to deal in the Software without restriction, including without limitation
+;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
+;; and/or sell copies of the Software, and to permit persons to whom the
+;; Software is furnished to do so, subject to the following conditions:
+
+;; The above copyright notice and this permission notice shall be included in
+;; all copies or substantial portions of the Software.
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
+;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;; DEALINGS IN THE SOFTWARE.
+
+;;; This code was originally written by Göran Weinholt for Industria and
+;;; released under the Expat license shown above. It was then modified by
+;;; Ludovic Courtès for use in GNU Guix: turned into a native Guile module,
+;;; ported to Guile-Gcrypt, and extended and simplified in other ways.
+
+(define-module (guix openpgp)
+ #:export (get-openpgp-detached-signature/ascii
+ (get-packet . get-openpgp-packet)
+ verify-openpgp-signature
+ port-ascii-armored?
+
+ openpgp-error?
+ openpgp-unrecognized-packet-error?
+ openpgp-unrecognized-packet-error-port
+ openpgp-invalid-signature-error?
+ openpgp-invalid-signature-error-port
+
+ openpgp-signature?
+ openpgp-signature-issuer-key-id
+ openpgp-signature-issuer-fingerprint
+ openpgp-signature-public-key-algorithm
+ openpgp-signature-hash-algorithm
+ openpgp-signature-creation-time
+ openpgp-signature-expiration-time
+
+ openpgp-user-id?
+ openpgp-user-id-value
+ openpgp-user-attribute?
+
+ openpgp-public-key?
+ openpgp-public-key-subkey?
+ openpgp-public-key-value
+ openpgp-public-key-fingerprint openpgp-format-fingerprint
+ openpgp-public-key-id
+
+ openpgp-keyring?
+ %empty-keyring
+ lookup-key-by-id
+ lookup-key-by-fingerprint
+ get-openpgp-keyring
+
+ read-radix-64
+ string->openpgp-packet)
+ #:use-module (rnrs bytevectors)
+ #:use-module (rnrs io ports)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:use-module (srfi srfi-60)
+ #:use-module (ice-9 match)
+ #:use-module ((ice-9 rdelim) #:select (read-line))
+ #:use-module (ice-9 vlist)
+ #:use-module (gcrypt hash)
+ #:use-module (gcrypt pk-crypto)
+ #:use-module (gcrypt base64)
+ #:use-module (gcrypt base16)
+ #:use-module ((guix build utils) #:select (dump-port)))
+
+;;; Commentary:
+;;;
+;;; This module contains code to read OpenPGP messages as described in
+;;; <https://tools.ietf.org/html/rfc4880>, with extensions from
+;;; <https://tools.ietf.org/html/draft-ietf-openpgp-rfc4880bis-06> (notably
+;;; EdDSA support and extra signature sub-packets).
+;;;
+;;; Currently this module does enough to verify detached signatures of binary
+;;; data. It does _not_ perform sanity checks on self-signatures, subkey
+;;; binding signatures, etc., among others. Use only in a context where this
+;;; limitations are acceptable!
+;;;
+;;; Code:
+
+(define-syntax print
+ (syntax-rules ()
+ ;; ((_ args ...) (pk 'openpgp args))
+ ((_ args ...) (values))))
+
+(define-syntax-rule (define-alias new old)
+ (define-syntax new (identifier-syntax old)))
+
+(define-alias fx+ +)
+(define-alias fx- -)
+(define-alias fx* *)
+(define-alias fx/ /)
+(define-alias fxdiv quotient)
+(define-alias fxand logand)
+(define-alias fxbit-set? bit-set?)
+(define-alias fxbit-field bit-field)
+(define-alias bitwise-bit-field bit-field)
+(define-alias fxarithmetic-shift-left ash)
+(define-inlinable (fxarithmetic-shift-right i n) (ash i (- n)))
+(define-inlinable (port-eof? port) (eof-object? (lookahead-u8 port)))
+
+(define (string-hex-pad str)
+ (if (odd? (string-length str))
+ (string-append "0" str)
+ str))
+
+(define (unixtime n)
+ (time-monotonic->date (make-time 'time-monotonic 0 n)))
+
+;; Root of the error hierarchy.
+(define-condition-type &openpgp-error &error
+ openpgp-error?)
+
+;; Error raised when reading an unsupported or unrecognized packet tag.
+(define-condition-type &openpgp-unrecognized-packet-error &openpgp-error
+ openpgp-unrecognized-packet-error?
+ (port openpgp-unrecognized-packet-error-port))
+
+;; Error raised when reading an invalid signature packet.
+(define-condition-type &openpgp-invalid-signature-error &openpgp-error
+ openpgp-invalid-signature-error?
+ (port openpgp-invalid-signature-error-port))
+
+
+;;;
+;;; Bitwise I/O.
+;;;
+;;; TODO: Use Bytestructures instead.
+;;;
+
+(define-syntax-rule (integer-read size)
+ (lambda (port)
+ "Read from PORT a big-endian integer of SIZE bytes. Return the EOF object
+on end-of-file."
+ (let ((buf (make-bytevector size)))
+ (match (get-bytevector-n! port buf 0 size)
+ (size (bytevector-uint-ref buf 0 (endianness big) size))
+ (_ (eof-object))))))
+
+(define get-u16 (integer-read 2))
+(define get-u32 (integer-read 4))
+(define get-u64 (integer-read 8))
+
+(define-syntax get-integers
+ (syntax-rules ()
+ "Read from PORT integers of the given TYPE, in big endian encoding. Each
+TYPE must be one of u8, u16, u32, u64, or _, as in this example:
+
+ (get-integers port u8 _ _ _ u32 u16)
+
+In the case of _ (wildcard), one byte is read and discarded. Return as many
+values as there are TYPEs."
+ ((_ port type ...)
+ (letrec-syntax ((get-integer (syntax-rules (u8 u16 u32 u64)
+ ((x u8) (get-u8 port))
+ ((x u16) (get-u16 port))
+ ((x u32) (get-u32 port))
+ ((x u64) (get-u64 port))))
+ (values* (syntax-rules (_)
+ ((x (result (... ...)))
+ (values result (... ...)))
+ ((x (result (... ...)) _ rest (... ...))
+ (let ((x (get-u8 port)))
+ (values* (result (... ...))
+ rest (... ...))))
+ ((x (result (... ...)) t rest (... ...))
+ (let ((x (get-integer t)))
+ (values* (result (... ...) x)
+ rest (... ...)))))))
+ (values* () type ...)))))
+
+(define (bytevector->uint bv)
+ (bytevector-uint-ref bv 0 (endianness big)
+ (bytevector-length bv)))
+
+(define-syntax-rule (integer-write size)
+ (lambda (port integer)
+ "Write INTEGER to PORT as a SIZE-byte integer and as big endian."
+ (let ((bv (make-bytevector size)))
+ (bytevector-uint-set! bv 0 integer (endianness big) size)
+ (put-bytevector port bv))))
+
+(define put-u16 (integer-write 2))
+(define put-u32 (integer-write 4))
+(define put-u64 (integer-write 8))
+
+(define-syntax put-integers
+ (syntax-rules ()
+ "Write the given integers as big endian to PORT. For example:
+
+ (put-integers port u8 42 u32 #x7777)
+
+writes to PORT the value 42 as an 8-bit integer and the value #x7777 as a
+32-bit integer."
+ ((_ port)
+ #t)
+ ((_ port type value rest ...)
+ (let-syntax ((put (syntax-rules (u8 u16 u32 u64)
+ ((_ u8 port integer)
+ (put-u8 port integer))
+ ((_ u16 port integer)
+ (put-u16 port integer))
+ ((_ u32 port integer)
+ (put-u32 port integer))
+ ((_ u64 port integer)
+ (put-u64 port integer)))))
+ (begin
+ (put type port value)
+ (put-integers port rest ...))))))
+
+(define-syntax-rule (integers->bytevector type value rest ...)
+ "Return the the TYPE/VALUE integers representation as a bytevector."
+ (let-values (((port get) (open-bytevector-output-port)))
+ (put-integers port type value rest ...)
+ (force-output port)
+ (get)))
+
+
+(define (bytevector->bitnames bv names)
+ (define (bit-set? bv i)
+ (let ((idx (fxarithmetic-shift-right i 3))
+ (bit (fxand i #b111)))
+ (and (< idx (bytevector-length bv))
+ (fxbit-set? (bytevector-u8-ref bv idx) bit))))
+ (do ((names names (cdr names))
+ (i 0 (fx+ i 1))
+ (bits '()
+ (if (bit-set? bv i)
+ (cons (car names) bits)
+ bits)))
+ ((null? names) (reverse bits))))
+
+(define (openpgp-format-fingerprint bv)
+ "Return a string representing BV, a bytevector, in the conventional OpenPGP
+hexadecimal format for fingerprints."
+ (define (h i)
+ (string-pad (string-upcase
+ (number->string
+ (bytevector-u16-ref bv (* i 2) (endianness big))
+ 16))
+ 4 #\0))
+ (string-append (h 0) " " (h 1) " " (h 2) " " (h 3) " " (h 4)
+ " "
+ (h 5) " " (h 6) " " (h 7) " " (h 8) " " (h 9)))
+
+;;; Constants
+
+
+(define PACKET-SESSION-KEY 1)
+(define PACKET-SIGNATURE 2)
+(define PACKET-SYMMETRIC-SESSION-KEY 3)
+(define PACKET-ONE-PASS-SIGNATURE 4)
+(define PACKET-SECRET-KEY 5)
+(define PACKET-PUBLIC-KEY 6)
+(define PACKET-SECRET-SUBKEY 7)
+(define PACKET-COMPRESSED-DATA 8)
+(define PACKET-SYMMETRIC-ENCRYPTED-DATA 9)
+(define PACKET-MARKER 10)
+(define PACKET-LITERAL-DATA 11)
+(define PACKET-TRUST 12)
+(define PACKET-USER-ID 13)
+(define PACKET-PUBLIC-SUBKEY 14)
+(define PACKET-USER-ATTRIBUTE 17)
+(define PACKET-SYMMETRIC-ENCRYPTED/PROTECTED-DATA 18)
+(define PACKET-MDC 19)
+
+(define PUBLIC-KEY-RSA 1)
+(define PUBLIC-KEY-RSA-ENCRYPT-ONLY 2)
+(define PUBLIC-KEY-RSA-SIGN-ONLY 3)
+(define PUBLIC-KEY-ELGAMAL-ENCRYPT-ONLY 16)
+(define PUBLIC-KEY-DSA 17)
+(define PUBLIC-KEY-ECDH 18) ;RFC-6637
+(define PUBLIC-KEY-ECDSA 19) ;RFC-6639
+(define PUBLIC-KEY-ELGAMAL 20) ;encrypt + sign (legacy)
+(define PUBLIC-KEY-EDDSA 22) ;"not yet assigned" says GPG
+
+(define (public-key-algorithm id)
+ (cond ((= id PUBLIC-KEY-RSA) 'rsa)
+ ((= id PUBLIC-KEY-DSA) 'dsa)
+ ((= id PUBLIC-KEY-ELGAMAL-ENCRYPT-ONLY) 'elgamal)
+ ((= id PUBLIC-KEY-EDDSA) 'eddsa)
+ (else id)))
+
+(define SYMMETRIC-KEY-PLAINTEXT 0)
+(define SYMMETRIC-KEY-IDEA 1)
+(define SYMMETRIC-KEY-TRIPLE-DES 2)
+(define SYMMETRIC-KEY-CAST5-128 3)
+(define SYMMETRIC-KEY-BLOWFISH-128 4)
+(define SYMMETRIC-KEY-AES-128 7)
+(define SYMMETRIC-KEY-AES-192 8)
+(define SYMMETRIC-KEY-AES-256 9)
+(define SYMMETRIC-KEY-TWOFISH-256 10)
+(define SYMMETRIC-KEY-CAMELLIA-128 11) ;RFC-5581
+(define SYMMETRIC-KEY-CAMELLIA-192 12)
+(define SYMMETRIC-KEY-CAMELLIA-256 13)
+
+(define (symmetric-key-algorithm id)
+ (cond ((= id SYMMETRIC-KEY-PLAINTEXT) 'plaintext)
+ ((= id SYMMETRIC-KEY-IDEA) 'idea)
+ ((= id SYMMETRIC-KEY-TRIPLE-DES) 'tdea)
+ ((= id SYMMETRIC-KEY-CAST5-128) 'cast5-128)
+ ((= id SYMMETRIC-KEY-BLOWFISH-128) 'blowfish-128)
+ ((= id SYMMETRIC-KEY-AES-128) 'aes-128)
+ ((= id SYMMETRIC-KEY-AES-192) 'aes-192)
+ ((= id SYMMETRIC-KEY-AES-256) 'aes-256)
+ ((= id SYMMETRIC-KEY-TWOFISH-256) 'twofish-256)
+ (else id)))
+
+(define HASH-MD5 1)
+(define HASH-SHA-1 2)
+(define HASH-RIPE-MD160 3)
+(define HASH-SHA-256 8)
+(define HASH-SHA-384 9)
+(define HASH-SHA-512 10)
+(define HASH-SHA-224 11)
+
+(define (openpgp-hash-algorithm id signature-port)
+ (cond ((= id HASH-MD5) 'md5)
+ ((= id HASH-SHA-1) 'sha1)
+ ((= id HASH-RIPE-MD160) 'rmd160)
+ ((= id HASH-SHA-256) 'sha256)
+ ((= id HASH-SHA-384) 'sha384)
+ ((= id HASH-SHA-512) 'sha512)
+ ((= id HASH-SHA-224) 'sha224)
+ (else
+ (raise (condition
+ (&openpgp-invalid-signature-error (port signature-port)))))))
+
+(define COMPRESSION-UNCOMPRESSED 0)
+(define COMPRESSION-ZIP 1) ;deflate
+
+(define COMPRESSION-ZLIB 2)
+(define COMPRESSION-BZIP2 3)
+
+(define (compression-algorithm id)
+ (cond ((= id COMPRESSION-UNCOMPRESSED) 'uncompressed)
+ ((= id COMPRESSION-ZIP) 'deflate)
+ ((= id COMPRESSION-ZLIB) 'zlib)
+ ((= id COMPRESSION-BZIP2) 'bzip2)
+ (else id)))
+
+(define SUBPACKET-SIGNATURE-CTIME 2)
+(define SUBPACKET-SIGNATURE-ETIME 3)
+ ;; 4 = Exportable Certification
+
+(define SUBPACKET-TRUST-SIGNATURE 5)
+ ;; 6 = Regular Expression
+
+(define SUBPACKET-REVOCABLE 7)
+(define SUBPACKET-KEY-ETIME 9)
+(define SUBPACKET-PREFERRED-SYMMETRIC-ALGORITHMS 11)
+ ;; 12 = Revocation Key
+
+(define SUBPACKET-ISSUER 16)
+(define SUBPACKET-NOTATION-DATA 20)
+(define SUBPACKET-PREFERRED-HASH-ALGORITHMS 21)
+(define SUBPACKET-PREFERRED-COMPRESSION-ALGORITHMS 22)
+(define SUBPACKET-KEY-SERVER-PREFERENCES 23)
+(define SUBPACKET-PREFERRED-KEY-SERVER 24)
+(define SUBPACKET-PRIMARY-USER-ID 25)
+(define SUBPACKET-POLICY-URI 26)
+(define SUBPACKET-KEY-FLAGS 27)
+(define SUBPACKET-SIGNER-USER-ID 28)
+(define SUBPACKET-REASON-FOR-REVOCATION 29)
+(define SUBPACKET-FEATURES 30)
+ ;; 31 = Signature Target
+(define SUBPACKET-EMBEDDED-SIGNATURE 32)
+(define SUBPACKET-ISSUER-FINGERPRINT 33) ;defined in RFC4880bis
+
+(define SIGNATURE-BINARY #x00)
+(define SIGNATURE-TEXT #x01)
+(define SIGNATURE-STANDALONE #x02)
+(define SIGNATURE-GENERIC-CERT #x10)
+(define SIGNATURE-PERSONA-CERT #x11)
+(define SIGNATURE-CASUAL-CERT #x12)
+(define SIGNATURE-POSITIVE-CERT #x13)
+(define SIGNATURE-SUBKEY-BINDING #x18)
+(define SIGNATURE-PRIMARY-KEY-BINDING #x19)
+(define SIGNATURE-DIRECT #x1f)
+(define SIGNATURE-KEY-REVOCATION #x20)
+(define SIGNATURE-SUBKEY-REVOCATION #x28)
+(define SIGNATURE-CERT-REVOCATION #x30)
+(define SIGNATURE-TIMESTAMP #x40)
+(define SIGNATURE-THIRD-PARTY #x50)
+
+;;; Parsing
+
+ ;; Look at the tag byte and see if it looks reasonable, if it does
+ ;; then the file is likely not armored. Does not move the port
+ ;; position.
+
+(define (port-ascii-armored? p)
+ (let ((tag (lookahead-u8 p)))
+ (cond ((eof-object? tag) #f)
+ ((not (fxbit-set? tag 7)) #t)
+ (else
+ (let ((type (if (fxbit-set? tag 6)
+ (fxbit-field tag 0 6)
+ (fxbit-field tag 2 6))))
+ (not (<= PACKET-SESSION-KEY type PACKET-MDC)))))))
+
+(define (get-mpi/bytevector p)
+ (let* ((bitlen (get-u16 p))
+ (bytelen (fxdiv (fx+ bitlen 7) 8)))
+ (get-bytevector-n p bytelen)))
+
+(define (get-mpi p)
+ (bytevector->uint (get-mpi/bytevector p)))
+
+(define (get-v4-length p)
+ ;; TODO: indeterminate length (only for data packets)
+ (let ((o1 (get-u8 p)))
+ (cond ((< o1 192) o1)
+ ((< o1 255)
+ (+ (fxarithmetic-shift-left (fx- o1 192) 8)
+ (get-u8 p)
+ 192))
+ ((= o1 255)
+ (get-u32 p)))))
+
+(define (get-packet p)
+ (if (port-eof? p)
+ (eof-object)
+ (get-packet* p get-data)))
+
+(define (get-packet* p get-data)
+ (let ((tag (get-u8 p)))
+ ;; (unless (fxbit-set? tag 7) (error 'get-packet "Invalid tag" tag))
+ (cond ((fxbit-set? tag 6) ;New packet format
+ (let ((tag (fxbit-field tag 0 6))
+ (len (get-v4-length p)))
+ (get-data p tag len)))
+ (else ;Old packet format
+ (let ((tag (fxbit-field tag 2 6))
+ (len (case (fxbit-field tag 0 2)
+ ((0) (get-u8 p))
+ ((1) (get-u16 p))
+ ((2) (get-u32 p))
+ ((3) #f))))
+ (get-data p tag len))))))
+
+(define (get-data p tag len)
+ (let ((pp (if len
+ (open-bytevector-input-port (get-bytevector-n p len))
+ p))) ;indeterminate length
+ (cond
+ ((= tag PACKET-SIGNATURE)
+ (get-signature pp))
+ ((= tag PACKET-PUBLIC-KEY)
+ (get-public-key pp #f))
+ ((= tag PACKET-TRUST)
+ 'openpgp-trust) ;XXX: non-standard format?
+ ((= tag PACKET-USER-ID)
+ (get-user-id pp len))
+ ((= tag PACKET-PUBLIC-SUBKEY)
+ (get-public-key pp #t))
+ ((= tag PACKET-USER-ATTRIBUTE)
+ (get-user-attribute pp len))
+ ((= tag PACKET-ONE-PASS-SIGNATURE)
+ 'one-pass-signature) ;TODO: implement
+ (else
+ (raise (condition (&openpgp-unrecognized-packet-error (port p))))))))
+
+(define-record-type <openpgp-public-key>
+ (make-openpgp-public-key version subkey? time value fingerprint)
+ openpgp-public-key?
+ (version openpgp-public-key-version)
+ (subkey? openpgp-public-key-subkey?)
+ (time openpgp-public-key-time)
+ (value openpgp-public-key-value)
+ (fingerprint openpgp-public-key-fingerprint))
+
+;;; Signatures
+
+(define-record-type <openpgp-signature>
+ (make-openpgp-signature version type pk-algorithm hash-algorithm hashl16
+ append-data hashed-subpackets unhashed-subpackets
+ value issuer issuer-fingerprint)
+ openpgp-signature?
+ (version openpgp-signature-version)
+ (type openpgp-signature-type)
+ (pk-algorithm openpgp-signature-public-key-algorithm)
+ (hash-algorithm openpgp-signature-hash-algorithm)
+ (hashl16 openpgp-signature-hashl16) ;left 16 bits of signed hash
+ (append-data openpgp-signature-append-data) ;append to data when hashing
+ (hashed-subpackets openpgp-signature-hashed-subpackets)
+ (unhashed-subpackets openpgp-signature-unhashed-subpackets)
+ (value openpgp-signature-value)
+ (issuer openpgp-signature-issuer-key-id) ;integer | #f
+ (issuer-fingerprint openpgp-signature-issuer-fingerprint)) ;bytevector | #f
+
+(define (openpgp-signature-creation-time sig)
+ (cond ((assq 'signature-ctime (openpgp-signature-hashed-subpackets sig))
+ => (lambda (x) (unixtime (cdr x))))
+ ;; XXX: should be an error?
+ (else #f)))
+
+(define (openpgp-signature-expiration-time sig)
+ (cond ((assq 'signature-etime (openpgp-signature-hashed-subpackets sig))
+ => (lambda (x)
+ (unixtime (+ (cdr x)
+ (openpgp-signature-creation-time sig)))))
+ (else #f)))
+
+
+(define (get-openpgp-detached-signature/ascii port)
+ "Read from PORT an ASCII-armored detached signature. Return an
+<openpgp-signature> record or the end-of-file object. Raise an error if the
+data read from PORT does is invalid or does not correspond to a detached
+signature."
+ (let-values (((data type) (read-radix-64 port)))
+ (cond ((eof-object? data) data)
+ ((string=? type "PGP SIGNATURE")
+ (get-packet (open-bytevector-input-port data)))
+ (else
+ (print "expected PGP SIGNATURE" type)
+ (raise (condition
+ (&openpgp-invalid-signature-error (port port))))))))
+
+(define (hash-algorithm-name algorithm) ;XXX: should be in Guile-Gcrypt
+ "Return the name of ALGORITHM, a 'hash-algorithm' integer, as a symbol."
+ (letrec-syntax ((->name (syntax-rules ()
+ ((_) #f)
+ ((_ name rest ...)
+ (if (= algorithm (hash-algorithm name))
+ 'name
+ (->name rest ...))))))
+ (->name sha1 sha256 sha384 sha512 sha224
+ sha3-224 sha3-256 sha3-384 sha3-512)))
+
+(define (verify-openpgp-signature sig keyring dataport)
+ "Verify that the data read from DATAPORT matches SIG, an
+<openpgp-signature>. Fetch the public key of the issuer of SIG from KEYRING,
+a keyring as returned by 'get-openpgp-keyring'. Return two values: a status
+symbol, such as 'bad-signature or 'missing-key, and additional info, such as
+the issuer's OpenPGP public key extracted from KEYRING."
+ (define (check key sig)
+ (let*-values (((hash-algorithm) (lookup-hash-algorithm
+ (openpgp-signature-hash-algorithm sig)))
+ ((port get-hash) (open-hash-port hash-algorithm)))
+ (dump-port dataport port)
+
+ ;; As per RFC4880 Section 5.2.4 ("Computing Signatures"), hash some of
+ ;; the fields from the signature packet.
+ (for-each (cut put-bytevector port <>)
+ (openpgp-signature-append-data sig))
+ (close-port port)
+
+ (let* ((signature (openpgp-signature-value sig))
+ (public-key (openpgp-public-key-value key))
+ (hash (get-hash))
+ (key-type (key-type public-key))
+ (data
+ ;; See "(gcrypt) Cryptographic Functions".
+ (sexp->canonical-sexp
+ (if (eq? key-type 'ecc)
+ `(data
+ (flags eddsa)
+ (hash-algo sha512)
+ (value ,hash))
+ `(data
+ (flags ,(match key-type
+ ('rsa 'pkcs1)
+ ('dsa 'rfc6979)))
+ (hash ,(hash-algorithm-name hash-algorithm)
+ ,hash))))))
+ (values (if (verify signature data public-key)
+ 'good-signature
+ 'bad-signature)
+ key))))
+
+ ;; TODO: Support SIGNATURE-TEXT.
+ (if (= (openpgp-signature-type sig) SIGNATURE-BINARY)
+ (let* ((id (openpgp-signature-issuer-key-id sig))
+ (fingerprint (openpgp-signature-issuer-fingerprint sig))
+ (key (if fingerprint
+ (lookup-key-by-fingerprint keyring fingerprint)
+ (lookup-key-by-id keyring id))))
+ (if key
+ (check key sig)
+ (values 'missing-key (or fingerprint id))))
+ (values 'unsupported-signature sig)))
+
+(define (key-id-matches-fingerprint? key-id fingerprint)
+ "Return true if KEY-ID, a number, corresponds to the low 8 bytes of
+FINGERPRINT, a bytevector."
+ (let* ((len (bytevector-length fingerprint))
+ (low (make-bytevector 8)))
+ (bytevector-copy! fingerprint (- len 8) low 0 8)
+ (= (bytevector->uint low) key-id)))
+
+(define (get-signature p)
+ (define (->hex n)
+ (string-hex-pad (number->string n 16)))
+
+ (define (get-sig p pkalg)
+ (cond ((= pkalg PUBLIC-KEY-RSA)
+ (print "RSA signature")
+ (string->canonical-sexp
+ (format #f "(sig-val (rsa (s #~a#)))"
+ (->hex (get-mpi p)))))
+ ((= pkalg PUBLIC-KEY-DSA)
+ (print "DSA signature")
+ (let ((r (get-mpi p)) (s (get-mpi p)))
+ (string->canonical-sexp
+ (format #f "(sig-val (dsa (r #~a#) (s #~a#)))"
+ (->hex r) (->hex s)))))
+ ((= pkalg PUBLIC-KEY-EDDSA)
+ (print "EdDSA signature")
+ (let ((r (get-mpi/bytevector p))
+ (s (get-mpi/bytevector p)))
+ ;; XXX: 'verify' fails down the road with GPG_ERR_INV_LENGTH if
+ ;; we provide a 31-byte R or S below, hence the second argument
+ ;; to '->hex' ensuring the MPIs are represented as two-byte
+ ;; multiples, with leading zeros.
+ (define (bytevector->hex bv)
+ (let ((str (bytevector->base16-string bv)))
+ (if (odd? (bytevector-length bv))
+ (string-append "00" str)
+ str)))
+
+ (string->canonical-sexp
+ (format #f "(sig-val (eddsa (r #~a#) (s #~a#)))"
+ (bytevector->hex r) (bytevector->hex s)))))
+ (else
+ (list 'unsupported-algorithm
+ (public-key-algorithm pkalg)
+ (get-bytevector-all p)))))
+ (let ((version (get-u8 p)))
+ (case version
+ ((3)
+ (let-values (((hmlen type ctime keyid pkalg halg hashl16)
+ (get-integers p u8 u8 u32 u64 u8 u8 u16)))
+ (unless (= hmlen 5)
+ (raise (condition
+ (&openpgp-invalid-signature-error (port p)))))
+
+ (print "Signature type: " type " creation time: " (unixtime ctime))
+ (print "Hash algorithm: " (openpgp-hash-algorithm halg p))
+ (let ((value (get-sig p pkalg)))
+ (unless (port-eof? p)
+ (print "Trailing data in signature: " (get-bytevector-all p)))
+ (make-openpgp-signature version type
+ (public-key-algorithm pkalg)
+ (openpgp-hash-algorithm halg p) hashl16
+ (list (integers->bytevector u8 type
+ u32 ctime))
+ ;; Emulate hashed subpackets
+ (list (cons 'signature-ctime ctime))
+ ;; Unhashed subpackets
+ (list (cons 'issuer keyid))
+ value
+ keyid #f))))
+ ((4)
+ (let*-values (((type pkalg halg) (get-integers p u8 u8 u8))
+ ((hashed-subpackets)
+ (get-bytevector-n p (get-u16 p)))
+ ((unhashed-subpackets)
+ (get-bytevector-n p (get-u16 p)))
+ ((hashl16) (get-u16 p)))
+ (print "Signature type: " type)
+ (print "Hash algorithm: " (openpgp-hash-algorithm halg p))
+ (let ((value (get-sig p pkalg)))
+ (unless (port-eof? p)
+ (print "Trailing data in signature: " (get-bytevector-all p)))
+ (let* ((subpacket-len (bytevector-length hashed-subpackets))
+ (append-data
+ (list
+ (integers->bytevector u8 version
+ u8 type
+ u8 pkalg
+ u8 halg
+ u16 subpacket-len)
+ hashed-subpackets
+ ;; http://www.rfc-editor.org/errata_search.php?rfc=4880
+ ;; Errata ID: 2214.
+ (integers->bytevector u8 #x04
+ u8 #xff
+ u32 (+ 6 subpacket-len))))
+ (unhashed-subpackets
+ (parse-subpackets unhashed-subpackets p))
+ (hashed-subpackets (parse-subpackets hashed-subpackets p))
+ (subpackets (append hashed-subpackets
+ unhashed-subpackets))
+ (issuer-key-id (assoc-ref subpackets 'issuer))
+ (issuer (assoc-ref subpackets
+ 'issuer-fingerprint)))
+ (unless (or (not issuer) (not issuer-key-id)
+ (key-id-matches-fingerprint? issuer-key-id issuer))
+ (print "issuer key id does not match fingerprint"
+ issuer-key-id issuer)
+ (raise (condition
+ (&openpgp-invalid-signature-error (port p)))))
+
+ (make-openpgp-signature version type
+ (public-key-algorithm pkalg)
+ (openpgp-hash-algorithm halg p)
+ hashl16
+ append-data
+ hashed-subpackets
+ unhashed-subpackets
+ value
+ issuer-key-id issuer)))))
+ (else
+ (print "Unsupported signature version: " version)
+ 'unsupported-signature-version))))
+
+(define (parse-subpackets bv signature-port)
+ (define (parse tag data)
+ (let ((type (fxbit-field tag 0 7))
+ (critical? (fxbit-set? tag 7)))
+ (cond
+ ((= type SUBPACKET-SIGNATURE-CTIME)
+ (cons 'signature-ctime
+ (bytevector-u32-ref data 0 (endianness big))))
+ ((= type SUBPACKET-SIGNATURE-ETIME)
+ (cons 'signature-etime
+ (bytevector-u32-ref data 0 (endianness big))))
+ ((= type SUBPACKET-TRUST-SIGNATURE)
+ (cons 'trust-signature
+ (bytevector-u8-ref data 0)))
+ ((= type SUBPACKET-REVOCABLE)
+ (cons 'revocable
+ (= (bytevector-u8-ref data 0) 1)))
+ ((= type SUBPACKET-KEY-ETIME)
+ (cons 'key-etime
+ (bytevector-u32-ref data 0 (endianness big))))
+ ((= type SUBPACKET-PREFERRED-SYMMETRIC-ALGORITHMS)
+ (cons 'preferred-symmetric-algorithms
+ (map symmetric-key-algorithm (bytevector->u8-list data))))
+ ((= type SUBPACKET-ISSUER)
+ (cons 'issuer
+ (bytevector-u64-ref data 0 (endianness big))))
+ ((= type SUBPACKET-ISSUER-FINGERPRINT) ;v4+ only, RFC4880bis
+ (cons 'issuer-fingerprint
+ (let* ((version (bytevector-u8-ref data 0))
+ (len (match version (4 20) (5 32)) )
+ (fingerprint (make-bytevector len)))
+ (bytevector-copy! data 1 fingerprint 0 len)
+ fingerprint)))
+ ((= type SUBPACKET-NOTATION-DATA)
+ (let ((p (open-bytevector-input-port data)))
+ (let-values (((f1 nlen vlen)
+ (get-integers p u8 _ _ _ u16 u16)))
+ (let* ((name (get-bytevector-n p nlen))
+ (value (get-bytevector-n p vlen)))
+ (cons 'notation-data
+ (list (utf8->string name)
+ (if (fxbit-set? f1 7)
+ (utf8->string value)
+ value)))))))
+ ((= type SUBPACKET-PREFERRED-HASH-ALGORITHMS)
+ (cons 'preferred-hash-algorithms
+ (map (cut openpgp-hash-algorithm <> signature-port)
+ (bytevector->u8-list data))))
+ ((= type SUBPACKET-PREFERRED-COMPRESSION-ALGORITHMS)
+ (cons 'preferred-compression-algorithms
+ (map compression-algorithm (bytevector->u8-list data))))
+ ((= type SUBPACKET-KEY-SERVER-PREFERENCES)
+ (cons 'key-server-preferences
+ (if (and (>= (bytevector-length data) 1)
+ (fxbit-set? (bytevector-u8-ref data 0) 7))
+ (list 'no-modify)
+ (list))))
+ ((= type SUBPACKET-PREFERRED-KEY-SERVER)
+ (cons 'preferred-key-server (utf8->string data)))
+ ((= type SUBPACKET-PRIMARY-USER-ID)
+ (cons 'primary-user-id (not (zero? (bytevector-u8-ref data 0)))))
+ ((= type SUBPACKET-POLICY-URI)
+ (cons 'policy-uri (utf8->string data)))
+ ((= type SUBPACKET-KEY-FLAGS)
+ (cons 'key-flags (bytevector->bitnames
+ data
+ '(certification sign-data
+ communications-encryption
+ storage-encryption
+ split-key authentication
+ group-key))))
+ ((= type SUBPACKET-SIGNER-USER-ID)
+ (cons 'signer-user-id (utf8->string data)))
+ ((= type SUBPACKET-REASON-FOR-REVOCATION)
+ (let* ((p (open-bytevector-input-port data))
+ (revocation-code (get-u8 p)))
+ (cons 'reason-for-revocation
+ (list revocation-code
+ (if (port-eof? p)
+ ""
+ (utf8->string (get-bytevector-all p)))))))
+ ((= type SUBPACKET-FEATURES)
+ (cons 'features (bytevector->bitnames
+ data '(modification-detection))))
+ ((= type SUBPACKET-EMBEDDED-SIGNATURE)
+ (cons 'embedded-signature
+ (get-signature (open-bytevector-input-port data))))
+ (else
+ ;; Unknown subpacket type. If it is critical, then the signature
+ ;; should be considered invalid.
+ (print "Unknown subpacket type: " type)
+ (if critical?
+ (raise (condition
+ (&openpgp-unrecognized-packet-error
+ (port signature-port))))
+ (list 'unsupported-subpacket type data))))))
+
+ (let ((p (open-bytevector-input-port bv)))
+ (let lp ((subpackets '()))
+ ;; In case of multiple subpackets of the same type, the last
+ ;; one should be used. Therefore the list is not reversed
+ ;; here.
+ (if (port-eof? p)
+ (reverse subpackets)
+ (let* ((len (- (get-v4-length p) 1))
+ (tag (get-u8 p))
+ (sp (parse tag (get-bytevector-n p len))))
+ (print "#;Subpacket " sp)
+ (lp (cons sp subpackets)))))))
+
+;;; Public keys
+
+
+(define (openpgp-public-key-id k)
+ (let ((bv (openpgp-public-key-fingerprint k)))
+ (bytevector-u64-ref bv
+ (- (bytevector-length bv) 8)
+ (endianness big))))
+
+(define (get-public-key p subkey?)
+ (define (fingerprint p)
+ (let ((len (port-position p)))
+ (set-port-position! p 0)
+ (let-values (((sha1-port get)
+ (open-hash-port (hash-algorithm sha1))))
+ (put-u8 sha1-port #x99)
+ (put-u16 sha1-port len)
+ (dump-port p sha1-port)
+ (close-port sha1-port)
+ (get))))
+ (define (get-key p alg)
+ (define (->hex n)
+ (string-hex-pad (number->string n 16)))
+
+ (cond ((= alg PUBLIC-KEY-RSA)
+ (print "Public RSA key")
+ (let* ((n (get-mpi p)) (e (get-mpi p)))
+ (string->canonical-sexp
+ (format #f "(public-key (rsa (n #~a#) (e #~a#)))"
+ (->hex n) (->hex e)))))
+ ((= alg PUBLIC-KEY-DSA)
+ (print "Public DSA key")
+ (let* ((p* (get-mpi p)) (q (get-mpi p))
+ (g (get-mpi p)) (y (get-mpi p)))
+ (string->canonical-sexp
+ (format #f "(public-key (dsa (p #~a#)(q #~a#)(g #~a#)(y #~a#)))"
+ (->hex p*) (->hex q) (->hex g) (->hex y)))))
+ #;
+ ((= alg PUBLIC-KEY-ELGAMAL-ENCRYPT-ONLY) ; ; ; ;
+ (print "Public El-Gamal Key") ; ; ; ;
+ (let* ((p* (get-mpi p)) (g (get-mpi p)) (y (get-mpi p))) ; ; ; ;
+ (make-public-elgamal-key p* g y)))
+ ((= alg PUBLIC-KEY-EDDSA)
+ ;; See
+ ;; <https://tools.ietf.org/html/draft-koch-eddsa-for-openpgp-04>
+ ;; and openpgp-oid.c in GnuPG.
+ (print "Public EdDSA key")
+ (let* ((len (get-u8 p))
+ (oid (bytevector->uint (get-bytevector-n p len)))
+ (q (get-mpi p)))
+ (define curve
+ (match oid
+ (#x2b06010401da470f01 'Ed25519)
+ (#x2b060104019755010501 'Curve25519)))
+
+ (string->canonical-sexp
+ (format #f "(public-key (ecc (curve ~a)(flags ~a)(q #~a#)))"
+ curve
+ (if (eq? curve 'Curve25519) 'djb-tweak 'eddsa)
+ (->hex q)))))
+ (else
+ (list 'unsupported-algorithm ;FIXME: throw
+ (public-key-algorithm alg)
+ (get-bytevector-all p)))))
+ (let ((version (get-u8 p)))
+ (case version
+ ((4)
+ (let-values (((ctime alg) (get-integers p u32 u8)))
+ (print "Key creation time: " (unixtime ctime))
+ (let ((key (get-key p alg)))
+ (unless (port-eof? p)
+ ;; Probably an error? Gonna cause trouble anyway.
+ (print "Trailing data in public key: " (get-bytevector-all p)))
+ (let ((digest (fingerprint p)))
+ (make-openpgp-public-key version subkey? ctime key
+ digest)))))
+ (else
+ (print "Unsupported public key version: " version)
+ 'unsupported-public-key-version))))
+
+(define (openpgp-public-key-primary? key)
+ (and (openpgp-public-key? key)
+ (not (openpgp-public-key-subkey? key))))
+
+;;; User IDs and User attributes
+
+
+(define-record-type <openpgp-user-id>
+ (make-openpgp-user-id value unparsed)
+ openpgp-user-id?
+ (value openpgp-user-id-value)
+ (unparsed openpgp-user-id-unparsed))
+
+(define (get-user-id p len)
+ (let ((unparsed (get-bytevector-n p len)))
+ (make-openpgp-user-id (utf8->string unparsed) unparsed)))
+
+(define-record-type <openpgp-user-attribute>
+ (make-openpgp-user-attribute unparsed)
+ openpgp-user-attribute?
+ (unparsed openpgp-user-attribute-unparsed))
+
+(define (get-user-attribute p len)
+ (let ((bv (get-bytevector-n p len)))
+ ;; TODO: bv contains subpackets. Type 1 is JFIF.
+ (make-openpgp-user-attribute bv)))
+
+
+;;; Keyring management
+
+(define-record-type <openpgp-keyring>
+ (openpgp-keyring ids fingerprints)
+ openpgp-keyring?
+ (ids openpgp-keyring-ids) ;vhash mapping key id to packets
+ (fingerprints openpgp-keyring-fingerprints)) ;mapping fingerprint to packets
+
+(define* (keyring-insert key keyring #:optional (packets '()))
+ "Insert the KEY/PACKETS association into KEYRING and return the resulting
+keyring. PACKETS typically contains KEY, an <openpgp-public-key>, alongside
+with additional <openpgp-public-key> records for sub-keys, <openpgp-user-id>
+records, and so on."
+ (openpgp-keyring (vhash-consv (openpgp-public-key-id key)
+ (cons key packets)
+ (openpgp-keyring-ids keyring))
+ (vhash-cons (openpgp-public-key-fingerprint key)
+ (cons key packets)
+ (openpgp-keyring-fingerprints keyring))))
+
+(define (lookup-key-by-id keyring id)
+ "Return two values: the first key with ID in KEYRING, and a list of
+associated packets (user IDs, signatures, etc.). Return #f and the empty list
+of ID was not found. ID must be the 64-bit key ID of the key, an integer."
+ (match (vhash-assv id (openpgp-keyring-ids keyring))
+ ((_ key packets ...) (values key packets))
+ (#f (values #f '()))))
+
+(define (lookup-key-by-fingerprint keyring fingerprint)
+ "Return two values: the key with FINGERPRINT in KEYRING, and a list of
+associated packets (user IDs, signatures, etc.). Return #f and the empty list
+of FINGERPRINT was not found. FINGERPRINT must be a bytevector."
+ (match (vhash-assoc fingerprint (openpgp-keyring-fingerprints keyring))
+ ((_ key packets ...) (values key packets))
+ (#f (values #f '()))))
+
+;; Reads a keyring from the binary input port p. It must not be
+;; ASCII armored.
+
+(define %empty-keyring
+ ;; The empty keyring.
+ (openpgp-keyring vlist-null vlist-null))
+
+(define* (get-openpgp-keyring port
+ #:optional (keyring %empty-keyring)
+ #:key (limit -1))
+ "Read from PORT an OpenPGP keyring in binary format; return a keyring based
+on all the OpenPGP primary keys that were read. The returned keyring
+complements KEYRING. LIMIT is the maximum number of keys to read, or -1 if
+there is no limit."
+ (let lp ((pkt (get-packet port))
+ (limit limit)
+ (keyring keyring))
+ (print "#;key " pkt)
+ (cond ((or (zero? limit) (eof-object? pkt))
+ keyring)
+ ((openpgp-public-key-primary? pkt)
+ ;; Read signatures, user id's, subkeys
+ (let lp* ((pkt (get-packet port))
+ (pkts (list pkt))
+ (keys (list pkt)))
+ (print "#;keydata " pkt)
+ (cond ((or (eof-object? pkt)
+ (eq? pkt 'unsupported-public-key-version)
+ (openpgp-public-key-primary? pkt))
+ ;; KEYRING is indexed by key-id. Key ids for both the
+ ;; primary key and subkeys all point to the list of
+ ;; packets.
+ (lp pkt
+ (- limit 1)
+ (fold (cute keyring-insert <> <> (reverse pkts))
+ keyring keys)))
+ ((openpgp-public-key? pkt) ;subkey
+ (lp* (get-packet port) (cons pkt pkts)
+ (cons pkt keys)))
+ (else
+ (lp* (get-packet port) (cons pkt pkts) keys)))))
+ (else
+ ;; Skip until there's a primary key. Ignore errors...
+ (lp (get-packet port) limit keyring)))))
+
+
+;;;
+;;; Radix-64 (RFC4880).
+;;;
+
+(define (crc24 bv)
+ "Compute a CRC24 as described in RFC4880, Section 6.1."
+ (define poly #x1864cfb)
+
+ (let loop ((crc #xb704ce)
+ (index 0))
+ (if (= index (bytevector-length bv))
+ (logand crc #xffffff)
+ (let ((crc (logxor (ash (bytevector-u8-ref bv index) 16)
+ crc)))
+ (let inner ((i 0)
+ (crc crc))
+ (if (< i 8)
+ (let ((crc (ash crc 1)))
+ (inner (+ i 1)
+ (if (zero? (logand crc #x1000000))
+ crc
+ (logxor crc poly))))
+ (loop crc (+ index 1))))))))
+
+(define %begin-block-prefix "-----BEGIN ")
+(define %begin-block-suffix "-----")
+
+(define %end-block-prefix "-----END ")
+(define %end-block-suffix "-----")
+
+(define (read-radix-64 port)
+ "Read from PORT an ASCII-armored Radix-64 stream, decode it, and return the
+result as a bytevector as well as the type, a string such as \"PGP MESSAGE\".
+Return #f if PORT does not contain a valid Radix-64 stream, and the
+end-of-file object if the Radix-64 sequence was truncated."
+ ;; This is the same as 'get-delimited-base64', except that it implements the
+ ;; CRC24 check.
+ (define (skip-headers port)
+ ;; Skip the Radix-64 "armor headers".
+ (match (read-line port)
+ ((? eof-object? eof) eof)
+ ((= string-trim-both "") "")
+ (_ (skip-headers port))))
+
+ (let ((line (string-trim-right (read-line port))))
+ (if (and (string-prefix? %begin-block-prefix line)
+ (string-suffix? %begin-block-suffix line))
+ (let* ((kind (string-drop-right
+ (string-drop line (string-length %begin-block-prefix))
+ (string-length %begin-block-suffix)))
+ (end (string-append %end-block-prefix kind
+ %end-block-suffix)))
+ (skip-headers port)
+ (let loop ((lines '()))
+ (let ((line (read-line port)))
+ (match line
+ ((? eof-object? eof)
+ (values eof kind))
+ ((= string-trim-both "")
+ (loop lines))
+ ((= string-trim-both str)
+ (if (string=? str end)
+ (match lines
+ ((crc lines ...)
+ ;; The last line should be the CRC, starting with an
+ ;; "=" sign.
+ (let ((crc (and (string-prefix? "=" crc)
+ (base64-decode (string-drop crc 1))))
+ (data (base64-decode
+ (string-concatenate-reverse lines))))
+ (if (and crc (= (bytevector->uint crc) (crc24 data)))
+ (values data kind)
+ (values #f kind))))
+ (_
+ (values #f kind)))
+ (loop (cons str lines))))))))
+ (values #f #f))))
+
+(define (string->openpgp-packet str)
+ "Read STR, an ASCII-armored OpenPGP packet, and return the corresponding
+OpenPGP record."
+ (get-packet
+ (open-bytevector-input-port (call-with-input-string str read-radix-64))))
diff --git a/guix/packages.scm b/guix/packages.scm
index 2fa4fd05d7..3fff50a6e8 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -3,7 +3,7 @@
;;; Copyright © 2014, 2015, 2017, 2018 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
-;;; Copyright © 2017, 2019 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2017, 2019, 2020 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2019 Marius Bakke <mbakke@fastmail.com>
;;;
;;; This file is part of GNU Guix.
@@ -234,7 +234,7 @@ name of its URI."
(define %supported-systems
;; This is the list of system types that are supported. By default, we
;; expect all packages to build successfully here.
- '("x86_64-linux" "i686-linux" "armhf-linux" "aarch64-linux" "mips64el-linux"))
+ '("x86_64-linux" "i686-linux" "armhf-linux" "aarch64-linux" "mips64el-linux" "i586-gnu"))
(define %hurd-systems
;; The GNU/Hurd systems for which support is being developed.
@@ -638,8 +638,10 @@ specifies modules in scope when evaluating SNIPPET."
(apply invoke
(string-append #+tar "/bin/tar")
"cvfa" #$output
- ;; avoid non-determinism in the archive
- "--mtime=@0"
+ ;; Avoid non-determinism in the archive. Set the mtime
+ ;; to 1 as is the case in the store (software like gzip
+ ;; behaves differently when it stumbles upon mtime = 0).
+ "--mtime=@1"
"--owner=root:0"
"--group=root:0"
(if tar-supports-sort?
@@ -812,11 +814,13 @@ dependencies are known to build on SYSTEM."
(define (bag-transitive-inputs bag)
"Same as 'package-transitive-inputs', but applied to a bag."
- (transitive-inputs (bag-direct-inputs bag)))
+ (parameterize ((%current-target-system #f))
+ (transitive-inputs (bag-direct-inputs bag))))
(define (bag-transitive-build-inputs bag)
"Same as 'package-transitive-native-inputs', but applied to a bag."
- (transitive-inputs (bag-build-inputs bag)))
+ (parameterize ((%current-target-system #f))
+ (transitive-inputs (bag-build-inputs bag))))
(define (bag-transitive-host-inputs bag)
"Same as 'package-transitive-target-inputs', but applied to a bag."
@@ -825,7 +829,8 @@ dependencies are known to build on SYSTEM."
(define (bag-transitive-target-inputs bag)
"Return the \"target inputs\" of BAG, recursively."
- (transitive-inputs (bag-target-inputs bag)))
+ (parameterize ((%current-target-system (bag-target bag)))
+ (transitive-inputs (bag-target-inputs bag))))
(define* (package-closure packages #:key (system (%current-system)))
"Return the closure of PACKAGES on SYSTEM--i.e., PACKAGES and the list of
diff --git a/guix/profiles.scm b/guix/profiles.scm
index ab265cce62..25ff146bdf 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -1171,6 +1171,8 @@ for both major versions of GTK+."
;; Don't run the hook when there's nothing to do.
(let* ((pkg-gtk+ (module-ref ; lazy reference
(resolve-interface '(gnu packages gtk)) 'gtk+))
+ (pkg-gtk+2 (module-ref ; lazy reference
+ (resolve-interface '(gnu packages gtk)) 'gtk+-2))
(gexp #~(begin
#$(if gtk+
(build
@@ -1184,7 +1186,7 @@ for both major versions of GTK+."
(build
gtk+-2 "2.10.0"
#~(string-append
- #$gtk+-2 "/bin/gtk-query-immodules-2.0"))
+ #$pkg-gtk+2:bin "/bin/gtk-query-immodules-2.0"))
#t))))
(if (or gtk+ gtk+-2)
(gexp->derivation "gtk-im-modules" gexp
@@ -1487,6 +1489,7 @@ the entries in MANIFEST."
;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=29654#23>.
#:env-vars `(("MALLOC_PERTURB_" . "1"))
+ #:substitutable? #f
#:local-build? #t
#:properties
`((type . profile-hook)
@@ -1624,8 +1627,10 @@ are cross-built for TARGET."
(guix search-paths)
(srfi srfi-1))
- (setvbuf (current-output-port) _IOLBF)
- (setvbuf (current-error-port) _IOLBF)
+ (let ((line (cond-expand (guile-2.2 'line)
+ (else _IOLBF)))) ;Guile 2.0
+ (setvbuf (current-output-port) line)
+ (setvbuf (current-error-port) line))
#+(if locales? set-utf8-locale #t)
diff --git a/guix/quirks.scm b/guix/quirks.scm
new file mode 100644
index 0000000000..483169e70d
--- /dev/null
+++ b/guix/quirks.scm
@@ -0,0 +1,124 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2020 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 quirks)
+ #:use-module ((guix build utils) #:select (substitute*))
+ #:use-module (srfi srfi-9)
+ #:use-module (ice-9 rdelim)
+ #:export (%quirks
+
+ patch?
+ applicable-patch?
+ apply-patch
+
+ %patches))
+
+;;; Commentary:
+;;;
+;;; Time traveling is a challenge! Sometimes, going back to the past requires
+;;; adjusting the old source code so it can be evaluated with our modern day
+;;; Guile and against our modern Guix APIs. This file describes quirks found
+;;; in old Guix revisions, along with ways to address them or patch them.
+;;;
+;;; Code:
+
+(define (syscalls-reexports-local-variables? source)
+ "Return true if (guix build syscalls) contains the bug described at
+<https://bugs.gnu.org/36723>."
+ (catch 'system-error
+ (lambda ()
+ (define content
+ (call-with-input-file (string-append source
+ "/guix/build/syscalls.scm")
+ read-string))
+
+ ;; The faulty code would use the 're-export' macro, causing the
+ ;; 'AT_SYMLINK_NOFOLLOW' local variable to be re-exported when using
+ ;; Guile > 2.2.4.
+ (string-contains content "(re-export variable)"))
+ (lambda args
+ (if (= ENOENT (system-error-errno args))
+ #f
+ (apply throw args)))))
+
+(define (guile-2.2.4)
+ (module-ref (resolve-interface '(gnu packages guile))
+ 'guile-2.2.4))
+
+(define %quirks
+ ;; List of predicate/package pairs. This allows us to provide information
+ ;; about specific Guile versions that old Guix revisions might need to use
+ ;; just to be able to build and run the trampoline in %SELF-BUILD-FILE. See
+ ;; <https://bugs.gnu.org/37506>
+ `((,syscalls-reexports-local-variables? . ,guile-2.2.4)))
+
+
+;;;
+;;; Patches.
+;;;
+
+;; Patch to apply to a source tree.
+(define-record-type <patch>
+ (patch predicate application)
+ patch?
+ (predicate patch-predicate) ;procedure
+ (application patch-application)) ;procedure
+
+(define (applicable-patch? patch source commit)
+ "Return true if PATCH is applicable to SOURCE, a directory, which
+corresponds to the given Guix COMMIT, a SHA1 hexadecimal string."
+ ;; The predicate is passed COMMIT so that it can choose to only apply to
+ ;; ancestors.
+ ((patch-predicate patch) source commit))
+
+(define (apply-patch patch source)
+ "Apply PATCH onto SOURCE, directly modifying files beneath it."
+ ((patch-application patch) source))
+
+(define %self-build-file
+ ;; The file containing code to build Guix.
+ "build-aux/build-self.scm")
+
+(define %bug-41028-patch
+ ;; Patch for <https://bugs.gnu.org/41028>. The faulty code is the
+ ;; 'compute-guix-derivation' body, which uses 'call-with-new-thread' without
+ ;; importing (ice-9 threads). However, the 'call-with-new-thread' binding
+ ;; is no longer available in the default name space on Guile 3.0.
+ (let ()
+ (define (missing-ice-9-threads-import? source commit)
+ ;; Return true if %SELF-BUILD-FILE is missing an (ice-9 threads) import.
+ (define content
+ (call-with-input-file (string-append source "/" %self-build-file)
+ read-string))
+
+ (and (string-contains content "(call-with-new-thread")
+ (not (string-contains content "(ice-9 threads)"))))
+
+ (define (add-missing-ice-9-threads-import source)
+ ;; Add (ice-9 threads) import in the gexp of 'compute-guix-derivation'.
+ (substitute* (string-append source "/" %self-build-file)
+ (("^ +\\(use-modules \\(ice-9 match\\)\\)")
+ (object->string '(use-modules (ice-9 match) (ice-9 threads))))))
+
+ (patch missing-ice-9-threads-import? add-missing-ice-9-threads-import)))
+
+(define %patches
+ ;; Bits of past Guix revisions can become incompatible with newer Guix and
+ ;; Guile. This variable lists <patch> records for the Guix source tree that
+ ;; apply to the Guix source.
+ (list %bug-41028-patch))
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index bfc4039c2b..03f455ab7b 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -38,8 +38,6 @@
#:use-module (gnu system file-systems)
#:use-module (gnu packages)
#:use-module (gnu packages bash)
- #:use-module (gnu packages commencement)
- #:use-module (gnu packages guile)
#:use-module ((gnu packages bootstrap)
#:select (bootstrap-executable %bootstrap-guile))
#:use-module (ice-9 format)
@@ -724,7 +722,7 @@ message if any test fails."
store
(if bootstrap?
%bootstrap-guile
- (canonical-package guile-2.2)))))
+ (default-guile)))))
(run-with-store store
;; Containers need a Bourne shell at /bin/sh.
(mlet* %store-monad ((bash (environment-bash container?
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
index fca1e3777c..1d5db3b3cb 100644
--- a/guix/scripts/graph.scm
+++ b/guix/scripts/graph.scm
@@ -307,6 +307,14 @@ derivation graph")))))))
;;; DAG of residual references (aka. run-time dependencies).
;;;
+(define intern
+ (mlambda (str)
+ "Intern STR, a string denoting a store item."
+ ;; This is necessary for %REFERENCE-NODE-TYPE and %REFERRER-NODE-TYPE
+ ;; because their nodes are strings but the (guix graph) traversal
+ ;; procedures expect to be able to compare nodes with 'eq?'.
+ str))
+
(define ensure-store-items
;; Return a list of store items as a monadic value based on the given
;; argument, which may be a store item or a package.
@@ -316,10 +324,10 @@ derivation graph")))))))
(mlet %store-monad ((drv (package->derivation package)))
(return (match (derivation->output-paths drv)
(((_ . file-names) ...)
- file-names)))))
+ (map intern file-names))))))
((? store-path? item)
(with-monad %store-monad
- (return (list item))))
+ (return (list (intern item)))))
(x
(raise
(condition (&message (message "unsupported argument for \
@@ -333,18 +341,19 @@ substitutes."
(guard (c ((store-protocol-error? c)
(match (substitutable-path-info store (list item))
((info)
- (values (substitutable-references info) store))
+ (values (map intern (substitutable-references info))
+ store))
(()
(leave (G_ "references for '~a' are not known~%")
item)))))
- (values (references store item) store))))
+ (values (map intern (references store item)) store))))
(define %reference-node-type
(node-type
(name "references")
(description "the DAG of run-time dependencies (store references)")
(convert ensure-store-items)
- (identifier (lift1 identity %store-monad))
+ (identifier (lift1 intern %store-monad))
(label store-path-package-name)
(edges references*)))
@@ -353,14 +362,14 @@ substitutes."
(lambda (item)
"Return the referrers of ITEM, except '.drv' files."
(mlet %store-monad ((items (referrers item)))
- (return (remove derivation-path? items))))))
+ (return (map intern (remove derivation-path? items)))))))
(define %referrer-node-type
(node-type
(name "referrers")
(description "the DAG of referrers in the store")
(convert ensure-store-items)
- (identifier (lift1 identity %store-monad))
+ (identifier (lift1 intern %store-monad))
(label store-path-package-name)
(edges non-derivation-referrers)))
@@ -448,6 +457,29 @@ package modules, while attempting to retain user package modules."
;;;
+;;; Displaying a path.
+;;;
+
+(define (display-path node1 node2 type)
+ "Display the shortest path from NODE1 to NODE2, of TYPE."
+ (mlet %store-monad ((path (shortest-path node1 node2 type)))
+ (define node-label
+ (let ((label (node-type-label type)))
+ ;; Special-case derivations and store items to print them in full,
+ ;; contrary to what their 'node-type-label' normally does.
+ (match-lambda
+ ((? derivation? drv) (derivation-file-name drv))
+ ((? string? str) str)
+ (node (label node)))))
+
+ (if path
+ (format #t "~{~a~%~}" (map node-label path))
+ (leave (G_ "no path from '~a' to '~a'~%")
+ (node-label node1) (node-label node2)))
+ (return #t)))
+
+
+;;;
;;; Command-line options.
;;;
@@ -456,6 +488,9 @@ package modules, while attempting to retain user package modules."
(lambda (opt name arg result)
(alist-cons 'node-type (lookup-node-type arg)
result)))
+ (option '("path") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'path? #t result)))
(option '("list-types") #f #f
(lambda (opt name arg result)
(list-node-types)
@@ -502,6 +537,8 @@ Emit a representation of the dependency graph of PACKAGE...\n"))
(display (G_ "
--list-types list the available graph types"))
(display (G_ "
+ --path display the shortest path between the given nodes"))
+ (display (G_ "
-e, --expression=EXPR consider the package EXPR evaluates to"))
(display (G_ "
-s, --system=SYSTEM consider the graph for SYSTEM--e.g., \"i686-linux\""))
@@ -557,11 +594,19 @@ Emit a representation of the dependency graph of PACKAGE...\n"))
(mlet %store-monad ((_ (set-grafting #f))
(nodes (mapm %store-monad
(node-type-convert type)
- items)))
- (export-graph (concatenate nodes)
- (current-output-port)
- #:node-type type
- #:backend backend))
+ (reverse items))))
+ (if (assoc-ref opts 'path?)
+ (match nodes
+ (((node1 _ ...) (node2 _ ...))
+ (display-path node1 node2 type))
+ (_
+ (leave (G_ "'--path' option requires exactly two \
+nodes (given ~a)~%")
+ (length nodes))))
+ (export-graph (concatenate nodes)
+ (current-output-port)
+ #:node-type type
+ #:backend backend)))
#:system (assq-ref opts 'system)))))
#t)
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index f3d1b41c6f..518bf6e7e3 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -286,6 +286,7 @@ added to the pack."
(gexp->derivation (string-append name ".tar"
(compressor-extension compressor))
build
+ #:target target
#:references-graphs `(("profile" ,profile))))
(define (singularity-environment-file profile)
@@ -384,7 +385,7 @@ added to the pack."
;; Reset all UIDs and GIDs.
"-force-uid" "0" "-force-gid" "0")))
- (setenv "PATH" (string-append #$archiver "/bin"))
+ (setenv "PATH" #+(file-append archiver "/bin"))
;; We need an empty file in order to have a valid file argument when
;; we reparent the root file system. Read on for why that's
@@ -484,6 +485,7 @@ added to the pack."
(compressor-extension compressor)
".squashfs")
build
+ #:target target
#:references-graphs `(("profile" ,profile))))
(define* (docker-image name profile
@@ -558,7 +560,7 @@ the image."
((_) str)
((names ... _) (loop names))))))) ;drop one entry
- (setenv "PATH" (string-append #$archiver "/bin"))
+ (setenv "PATH" #+(file-append archiver "/bin"))
(build-docker-image #$output
(map store-info-item
@@ -574,12 +576,13 @@ the image."
#~(list (string-append #$profile "/"
#$entry-point)))
#:extra-files directives
- #:compressor '#$(compressor-command compressor)
+ #:compressor '#+(compressor-command compressor)
#:creation-time (make-time time-utc 0 1))))))
(gexp->derivation (string-append name ".tar"
(compressor-extension compressor))
build
+ #:target target
#:references-graphs `(("profile" ,profile))))
@@ -681,18 +684,50 @@ last resort for relocation."
(define runner
(local-file (search-auxiliary-file "run-in-namespace.c")))
+ (define audit-source
+ (local-file (search-auxiliary-file "pack-audit.c")))
+
(define (proot)
(specification->package "proot-static"))
+ (define (fakechroot-library)
+ (computed-file "libfakechroot.so"
+ #~(copy-file #$(file-append
+ (specification->package "fakechroot")
+ "/lib/fakechroot/libfakechroot.so")
+ #$output)))
+
+ (define (audit-module)
+ ;; Return an ld.so audit module for use by the 'fakechroot' execution
+ ;; engine that translates file names of all the files ld.so loads.
+ (computed-file "pack-audit.so"
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils))
+
+ (copy-file #$audit-source "audit.c")
+ (substitute* "audit.c"
+ (("@STORE_DIRECTORY@")
+ (%store-directory)))
+
+ (invoke #$compiler "-std=gnu99"
+ "-shared" "-fPIC" "-Os" "-g0"
+ "-Wall" "audit.c" "-o" #$output)))))
+
(define build
(with-imported-modules (source-module-closure
'((guix build utils)
- (guix build union)))
+ (guix build union)
+ (guix elf)))
#~(begin
(use-modules (guix build utils)
((guix build union) #:select (relative-file-name))
+ (guix elf)
+ (ice-9 binary-ports)
(ice-9 ftw)
- (ice-9 match))
+ (ice-9 match)
+ (srfi srfi-1)
+ (rnrs bytevectors))
(define input
;; The OUTPUT* output of PACKAGE.
@@ -711,6 +746,48 @@ last resort for relocation."
(#f base)
(index (string-drop base index)))))
+ (define (elf-interpreter elf)
+ ;; Return the interpreter of ELF as a string, or #f if ELF has no
+ ;; interpreter segment.
+ (match (find (lambda (segment)
+ (= (elf-segment-type segment) PT_INTERP))
+ (elf-segments elf))
+ (#f #f) ;maybe a .so
+ (segment
+ (let ((bv (make-bytevector (- (elf-segment-memsz segment) 1))))
+ (bytevector-copy! (elf-bytes elf)
+ (elf-segment-offset segment)
+ bv 0 (bytevector-length bv))
+ (utf8->string bv)))))
+
+ (define (elf-loader-compile-flags program)
+ ;; Return the cpp flags defining macros for the ld.so/fakechroot
+ ;; wrapper of PROGRAM.
+
+ ;; TODO: Handle scripts by wrapping their interpreter.
+ (if (elf-file? program)
+ (let* ((bv (call-with-input-file program
+ get-bytevector-all))
+ (elf (parse-elf bv))
+ (interp (elf-interpreter elf))
+ (gconv (and interp
+ (string-append (dirname interp)
+ "/gconv"))))
+ (if interp
+ (list (string-append "-DPROGRAM_INTERPRETER=\""
+ interp "\"")
+ (string-append "-DFAKECHROOT_LIBRARY=\""
+ #$(fakechroot-library) "\"")
+
+ (string-append "-DLOADER_AUDIT_MODULE=\""
+ #$(audit-module) "\"")
+ (if gconv
+ (string-append "-DGCONV_DIRECTORY=\""
+ gconv "\"")
+ "-UGCONV_DIRECTORY"))
+ '()))
+ '()))
+
(define (build-wrapper program)
;; Build a user-namespace wrapper for PROGRAM.
(format #t "building wrapper for '~a'...~%" program)
@@ -730,10 +807,11 @@ last resort for relocation."
(mkdir-p (dirname result))
(apply invoke #$compiler "-std=gnu99" "-static" "-Os" "-g0" "-Wall"
"run.c" "-o" result
- (if proot
- (list (string-append "-DPROOT_PROGRAM=\""
- proot "\""))
- '()))
+ (append (if proot
+ (list (string-append "-DPROOT_PROGRAM=\""
+ proot "\""))
+ '())
+ (elf-loader-compile-flags program)))
(delete-file "run.c")))
(setvbuf (current-output-port) 'line)
@@ -1035,7 +1113,7 @@ Create a bundle of PACKAGE.\n"))
store
(if (assoc-ref opts 'bootstrap?)
%bootstrap-guile
- (canonical-package guile-2.2))
+ (default-guile))
(assoc-ref opts 'system)
#:graft? (assoc-ref opts 'graft?))))
(let* ((derivation? (assoc-ref opts 'derivation-only?))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 2eb18919cc..a69efa365e 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -8,6 +8,7 @@
;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -55,8 +56,6 @@
#:use-module (srfi srfi-35)
#:use-module (srfi srfi-37)
#:use-module (gnu packages)
- #:autoload (gnu packages base) (canonical-package)
- #:autoload (gnu packages guile) (guile-2.2)
#:autoload (gnu packages bootstrap) (%bootstrap-guile)
#:export (build-and-use-profile
delete-generations
@@ -789,18 +788,26 @@ processed, #f otherwise."
(display-search-results matches (current-output-port)))
#t))
- (('show requested-name)
- (let-values (((name version)
- (package-name->name+version requested-name)))
- (match (remove package-superseded
- (find-packages-by-name name version))
- (()
- (leave (G_ "~a~@[@~a~]: package not found~%") name version))
- (packages
- (leave-on-EPIPE
- (for-each (cute package->recutils <> (current-output-port))
- packages))))
- #t))
+ (('show _)
+ (let ((requested-names
+ (filter-map (match-lambda
+ (('query 'show requested-name) requested-name)
+ (_ #f))
+ opts)))
+ (for-each
+ (lambda (requested-name)
+ (let-values (((name version)
+ (package-name->name+version requested-name)))
+ (match (remove package-superseded
+ (find-packages-by-name name version))
+ (()
+ (leave (G_ "~a~@[@~a~]: package not found~%") name version))
+ (packages
+ (leave-on-EPIPE
+ (for-each (cute package->recutils <> (current-output-port))
+ packages))))))
+ requested-names))
+ #t)
(('search-paths kind)
(let* ((manifests (map profile-manifest profiles))
@@ -963,5 +970,5 @@ option processing with 'parse-command-line'."
(%store)
(if (assoc-ref opts 'bootstrap?)
%bootstrap-guile
- (canonical-package guile-2.2)))))
+ (default-guile)))))
(process-actions (%store) opts))))))))
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 42c9956136..dfe7ee7ad5 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -787,7 +787,7 @@ Use '~/.config/guix/channels.scm' instead."))
store
(if (assoc-ref opts 'bootstrap?)
%bootstrap-guile
- (canonical-package guile-2.2)))))
+ (default-guile)))))
(with-profile-lock profile
(run-with-store store
(build-and-install instances profile)))))))))))))))
diff --git a/guix/scripts/show.scm b/guix/scripts/show.scm
index ef64b5755b..a2b0030a63 100644
--- a/guix/scripts/show.scm
+++ b/guix/scripts/show.scm
@@ -73,4 +73,4 @@ This is an alias for 'guix package --show='.\n"))
(unless (assoc-ref opts 'query)
(leave (G_ "missing arguments: no package to show~%")))
- (guix-package* opts))
+ (guix-package* (reverse opts)))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 2664c66a30..3efd113ac8 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -54,9 +54,11 @@
#:autoload (gnu build linux-modules)
(device-module-aliases matching-modules)
#:use-module (gnu system linux-initrd)
+ #:use-module (gnu image)
#:use-module (gnu system)
#:use-module (gnu bootloader)
#:use-module (gnu system file-systems)
+ #:use-module (gnu system image)
#:use-module (gnu system mapped-devices)
#:use-module (gnu system linux-container)
#:use-module (gnu system uuid)
@@ -692,14 +694,13 @@ checking this by themselves in their 'check' procedure."
(* 70 (expt 2 20)))
#:mappings mappings))
((disk-image)
- (system-disk-image os
- #:name (match file-system-type
- ("iso9660" "image.iso")
- (_ "disk-image"))
- #:disk-image-size image-size
- #:file-system-type file-system-type))
+ (system-image
+ (image
+ (inherit (find-image file-system-type))
+ (size image-size)
+ (operating-system os))))
((docker-image)
- (system-docker-image os))))
+ (system-docker-image os #:shared-network? container-shared-network?))))
(define (maybe-suggest-running-guix-pull)
"Suggest running 'guix pull' if this has never been done before."
diff --git a/guix/self.scm b/guix/self.scm
index 4682cd221c..a9568049b2 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -48,12 +48,12 @@
(let ((ref (lambda (module variable)
(module-ref (resolve-interface module) variable))))
(match-lambda
- ("guile" (ref '(gnu packages guile) 'guile-3.0))
- ("guile-json" (ref '(gnu packages guile) 'guile3.0-json))
- ("guile-ssh" (ref '(gnu packages ssh) 'guile3.0-ssh))
- ("guile-git" (ref '(gnu packages guile) 'guile3.0-git))
- ("guile-sqlite3" (ref '(gnu packages guile) 'guile3.0-sqlite3))
- ("guile-gcrypt" (ref '(gnu packages gnupg) 'guile3.0-gcrypt))
+ ("guile" (ref '(gnu packages guile) 'guile-3.0/libgc-7))
+ ("guile-json" (ref '(gnu packages guile) 'guile-json-3))
+ ("guile-ssh" (ref '(gnu packages ssh) 'guile-ssh))
+ ("guile-git" (ref '(gnu packages guile) 'guile-git))
+ ("guile-sqlite3" (ref '(gnu packages guile) 'guile-sqlite3))
+ ("guile-gcrypt" (ref '(gnu packages gnupg) 'guile-gcrypt))
("gnutls" (ref '(gnu packages tls) 'guile3.0-gnutls))
("zlib" (ref '(gnu packages compression) 'zlib))
("lzlib" (ref '(gnu packages compression) 'lzlib))
diff --git a/guix/store.scm b/guix/store.scm
index fb4b92e0c4..014d08aaec 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -103,6 +103,7 @@
add-text-to-store
add-to-store
add-file-tree-to-store
+ file-mapping->tree
binary-file
with-build-handler
map/accumulate-builds
@@ -1237,6 +1238,45 @@ an arbitrary directory layout in the store without creating a derivation."
(hash-set! cache tree result)
result)))))
+(define (file-mapping->tree mapping)
+ "Convert MAPPING, an alist like:
+
+ ((\"guix/build/utils.scm\" . \"…/utils.scm\"))
+
+to a tree suitable for 'add-file-tree-to-store' and 'interned-file-tree'."
+ (let ((mapping (map (match-lambda
+ ((destination . source)
+ (cons (string-tokenize destination %not-slash)
+ source)))
+ mapping)))
+ (fold (lambda (pair result)
+ (match pair
+ ((destination . source)
+ (let loop ((destination destination)
+ (result result))
+ (match destination
+ ((file)
+ (let* ((mode (stat:mode (stat source)))
+ (type (if (zero? (logand mode #o100))
+ 'regular
+ 'executable)))
+ (alist-cons file
+ `(,type (file ,source))
+ result)))
+ ((file rest ...)
+ (let ((directory (assoc-ref result file)))
+ (alist-cons file
+ `(directory
+ ,@(loop rest
+ (match directory
+ (('directory . entries) entries)
+ (#f '()))))
+ (if directory
+ (alist-delete file result)
+ result)))))))))
+ '()
+ mapping)))
+
(define current-build-prompt
;; When true, this is the prompt to abort to when 'build-things' is called.
(make-parameter #f))
@@ -1859,7 +1899,9 @@ coalesce them into a single call."
(values (map/accumulate-builds store
(lambda (obj)
(run-with-store store
- (mproc obj)))
+ (mproc obj)
+ #:system (%current-system)
+ #:target (%current-target-system)))
lst)
store)))
diff --git a/guix/store/database.scm b/guix/store/database.scm
index 88d05dc42e..ef52036ede 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2019 Caleb Ristvedt <caleb.ristvedt@cune.org>
-;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -228,16 +228,18 @@ Every store item in REFERENCES must already be registered."
;;; High-level interface.
;;;
-(define (reset-timestamps file)
+(define* (reset-timestamps file #:key preserve-permissions?)
"Reset the modification time on FILE and on all the files it contains, if
-it's a directory. While at it, canonicalize file permissions."
+it's a directory. Canonicalize file permissions unless PRESERVE-PERMISSIONS?
+is true."
;; Note: We're resetting to one second after the Epoch like 'guix-daemon'
;; has always done.
(let loop ((file file)
(type (stat:type (lstat file))))
(case type
((directory)
- (chmod file #o555)
+ (unless preserve-permissions?
+ (chmod file #o555))
(utime file 1 1 0 0)
(let ((parent file))
(for-each (match-lambda
@@ -254,7 +256,8 @@ it's a directory. While at it, canonicalize file permissions."
((symlink)
(utime file 1 1 0 0 AT_SYMLINK_NOFOLLOW))
(else
- (chmod file (if (executable-file? file) #o555 #o444))
+ (unless preserve-permissions?
+ (chmod file (if (executable-file? file) #o555 #o444)))
(utime file 1 1 0 0)))))
(define* (register-path path
diff --git a/guix/tests.scm b/guix/tests.scm
index ff31bcad44..95a7d7c4b8 100644
--- a/guix/tests.scm
+++ b/guix/tests.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -415,6 +415,9 @@ default values, and with EXTRA-FIELDS set as specified."
#:implicit-inputs? #f
#:tests? #f ;cannot run "make check"
,@(substitute-keyword-arguments (package-arguments gnu-make)
+ ((#:configure-flags flags ''())
+ ;; As in 'gnu-make-boot0', work around a 'config.status' defect.
+ `(cons "--disable-dependency-tracking" ,flags))
((#:phases phases)
`(modify-phases ,phases
(replace 'build
generated by cgit v1.2.3 (git 2.46.2) at 2024-11-11 01:21:40 +0000