Switch to Guile-Gcrypt.

This removes (guix hash) and (guix pk-crypto), which now live as part of
Guile-Gcrypt (version 0.1.0.)

* guix/gcrypt.scm, guix/hash.scm, guix/pk-crypto.scm,
tests/hash.scm, tests/pk-crypto.scm: Remove.
* configure.ac: Test for Guile-Gcrypt.  Remove LIBGCRYPT and
LIBGCRYPT_LIBDIR assignments.
* m4/guix.m4 (GUIX_ASSERT_LIBGCRYPT_USABLE): Remove.
* README: Add Guile-Gcrypt to the dependencies; move libgcrypt as
"required unless --disable-daemon".
* doc/guix.texi (Requirements): Likewise.
* gnu/packages/bash.scm, guix/derivations.scm, guix/docker.scm,
guix/git.scm, guix/http-client.scm, guix/import/cpan.scm,
guix/import/cran.scm, guix/import/crate.scm, guix/import/elpa.scm,
guix/import/gnu.scm, guix/import/hackage.scm,
guix/import/texlive.scm, guix/import/utils.scm, guix/nar.scm,
guix/pki.scm, guix/scripts/archive.scm,
guix/scripts/authenticate.scm, guix/scripts/download.scm,
guix/scripts/hash.scm, guix/scripts/pack.scm,
guix/scripts/publish.scm, guix/scripts/refresh.scm,
guix/scripts/substitute.scm, guix/store.scm,
guix/store/deduplication.scm, guix/tests.scm, tests/base32.scm,
tests/builders.scm, tests/challenge.scm, tests/cpan.scm,
tests/crate.scm, tests/derivations.scm, tests/gem.scm,
tests/nar.scm, tests/opam.scm, tests/pki.scm,
tests/publish.scm, tests/pypi.scm, tests/store-deduplication.scm,
tests/store.scm, tests/substitute.scm: Adjust imports.
* gnu/system/vm.scm: Likewise.
(guile-sqlite3&co): Rename to...
(gcrypt-sqlite3&co): ... this.  Add GUILE-GCRYPT.
(expression->derivation-in-linux-vm)[config]: Remove.
(iso9660-image)[config]: Remove.
(qemu-image)[config]: Remove.
(system-docker-image)[config]: Remove.
* guix/scripts/pack.scm: Adjust imports.
(guile-sqlite3&co): Rename to...
(gcrypt-sqlite3&co): ... this.  Add GUILE-GCRYPT.
(self-contained-tarball)[build]: Call 'make-config.scm' without
 #:libgcrypt argument.
(squashfs-image)[libgcrypt]: Remove.
[build]: Call 'make-config.scm' without #:libgcrypt.
(docker-image)[config, json]: Remove.
[build]: Add GUILE-GCRYPT to the extensions  Remove (guix config) from
the imported modules.
* guix/self.scm (specification->package): Remove "libgcrypt", add
"guile-gcrypt".
(compiled-guix): Remove #:libgcrypt.
[guile-gcrypt]: New variable.
[dependencies]: Add it.
[*core-modules*]: Remove #:libgcrypt from 'make-config.scm' call.
Add #:extensions.
[*config*]: Remove #:libgcrypt from 'make-config.scm' call.
(%dependency-variables): Remove %libgcrypt.
(make-config.scm): Remove #:libgcrypt.
* build-aux/build-self.scm (guile-gcrypt): New variable.
(make-config.scm): Remove #:libgcrypt.
(build-program)[fake-gcrypt-hash]: New variable.
Add (gcrypt hash) to the imported modules.  Adjust load path
assignments.
* gnu/packages/package-management.scm (guix)[propagated-inputs]: Add
GUILE-GCRYPT.
[arguments]: In 'wrap-program' phase, add GUILE-GCRYPT to the search
path.
This commit is contained in:
Ludovic Courtès 2018-08-31 17:07:07 +02:00
parent 7e1d229019
commit ca71942445
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
56 changed files with 179 additions and 1240 deletions

View File

@ -63,9 +63,6 @@ MODULES = \
guix/base64.scm \ guix/base64.scm \
guix/cpio.scm \ guix/cpio.scm \
guix/records.scm \ guix/records.scm \
guix/gcrypt.scm \
guix/hash.scm \
guix/pk-crypto.scm \
guix/pki.scm \ guix/pki.scm \
guix/progress.scm \ guix/progress.scm \
guix/combinators.scm \ guix/combinators.scm \
@ -331,8 +328,6 @@ SCM_TESTS = \
tests/base32.scm \ tests/base32.scm \
tests/base64.scm \ tests/base64.scm \
tests/cpio.scm \ tests/cpio.scm \
tests/hash.scm \
tests/pk-crypto.scm \
tests/pki.scm \ tests/pki.scm \
tests/print.scm \ tests/print.scm \
tests/sets.scm \ tests/sets.scm \

3
README
View File

@ -21,7 +21,7 @@ Guix is based on the [[https://nixos.org/nix/][Nix]] package manager.
GNU Guix currently depends on the following packages: GNU Guix currently depends on the following packages:
- [[https://gnu.org/software/guile/][GNU Guile 2.2.x or 2.0.x]], version 2.0.13 or later - [[https://gnu.org/software/guile/][GNU Guile 2.2.x or 2.0.x]], version 2.0.13 or later
- [[https://gnupg.org/][GNU libgcrypt]] - [[https://notabug.org/cwebber/guile-gcrypt][Guile-Gcrypt]] 0.1.0 or later
- [[https://www.gnu.org/software/make/][GNU Make]] - [[https://www.gnu.org/software/make/][GNU Make]]
- [[https://www.gnutls.org][GnuTLS]] compiled with guile support enabled - [[https://www.gnutls.org][GnuTLS]] compiled with guile support enabled
- [[https://notabug.org/civodul/guile-sqlite3][Guile-SQLite3]], version 0.1.0 or later - [[https://notabug.org/civodul/guile-sqlite3][Guile-SQLite3]], version 0.1.0 or later
@ -31,6 +31,7 @@ GNU Guix currently depends on the following packages:
Unless `--disable-daemon' was passed, the following packages are needed: Unless `--disable-daemon' was passed, the following packages are needed:
- [[https://gnupg.org/][GNU libgcrypt]]
- [[https://sqlite.org/][SQLite 3]] - [[https://sqlite.org/][SQLite 3]]
- [[https://gcc.gnu.org][GCC's g++]] - [[https://gcc.gnu.org][GCC's g++]]
- optionally [[http://www.bzip.org][libbz2]] - optionally [[http://www.bzip.org][libbz2]]

View File

@ -22,6 +22,7 @@
#:use-module (guix ui) #:use-module (guix ui)
#:use-module (guix config) #:use-module (guix config)
#:use-module (guix modules) #:use-module (guix modules)
#:use-module (guix build-system gnu)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-19) #:use-module (srfi srfi-19)
#:use-module (rnrs io ports) #:use-module (rnrs io ports)
@ -72,7 +73,7 @@
(variables rest ...)))))) (variables rest ...))))))
(variables %localstatedir %storedir %sysconfdir %system))) (variables %localstatedir %storedir %sysconfdir %system)))
(define* (make-config.scm #:key libgcrypt zlib gzip xz bzip2 (define* (make-config.scm #:key zlib gzip xz bzip2
(package-name "GNU Guix") (package-name "GNU Guix")
(package-version "0") (package-version "0")
(bug-report-address "bug-guix@gnu.org") (bug-report-address "bug-guix@gnu.org")
@ -92,7 +93,6 @@
%state-directory %state-directory
%store-database-directory %store-database-directory
%config-directory %config-directory
%libgcrypt
%libz %libz
%gzip %gzip
%bzip2 %bzip2
@ -137,9 +137,6 @@
(define %xz (define %xz
#+(and xz (file-append xz "/bin/xz"))) #+(and xz (file-append xz "/bin/xz")))
(define %libgcrypt
#+(and libgcrypt
(file-append libgcrypt "/lib/libgcrypt")))
(define %libz (define %libz
#+(and zlib #+(and zlib
(file-append zlib "/lib/libz"))))))) (file-append zlib "/lib/libz")))))))
@ -200,6 +197,44 @@ person's version identifier."
;; XXX: Replace with a Git commit id. ;; XXX: Replace with a Git commit id.
(date->string (current-date 0) "~Y~m~d.~H")) (date->string (current-date 0) "~Y~m~d.~H"))
(define guile-gcrypt
;; The host Guix may or may not have 'guile-gcrypt', which was introduced in
;; August 2018. If it has it, it's at least version 0.1.0, which is good
;; enough. If it doesn't, specify our own package because the target Guix
;; requires it.
(match (find-best-packages-by-name "guile-gcrypt" #f)
(()
(package
(name "guile-gcrypt")
(version "0.1.0")
(home-page "https://notabug.org/cwebber/guile-gcrypt")
(source (origin
(method url-fetch)
(uri (string-append home-page "/archive/v" version ".tar.gz"))
(sha256
(base32
"1gir7ifknbmbvjlql5j6wzk7bkb5lnmq80q59ngz43hhpclrk5k3"))
(file-name (string-append name "-" version ".tar.gz"))))
(build-system gnu-build-system)
(native-inputs
`(("pkg-config" ,(specification->package "pkg-config"))
("autoconf" ,(specification->package "autoconf"))
("automake" ,(specification->package "automake"))
("texinfo" ,(specification->package "texinfo"))))
(inputs
`(("guile" ,(specification->package "guile"))
("libgcrypt" ,(specification->package "libgcrypt"))))
(synopsis "Cryptography library for Guile using Libgcrypt")
(description
"Guile-Gcrypt provides a Guile 2.x interface to a subset of the
GNU Libgcrypt crytographic library. It provides modules for cryptographic
hash functions, message authentication codes (MAC), public-key cryptography,
strong randomness, and more. It is implemented using the foreign function
interface (FFI) of Guile.")
(license #f))) ;license:gpl3+
((package . _)
package)))
(define* (build-program source version (define* (build-program source version
#:optional (guile-version (effective-version)) #:optional (guile-version (effective-version))
#:key (pull-version 0)) #:key (pull-version 0))
@ -212,10 +247,21 @@ person's version identifier."
(('gnu _ ...) #t) (('gnu _ ...) #t)
(_ #f))) (_ #f)))
(define fake-gcrypt-hash
;; Fake (gcrypt hash) module; see below.
(scheme-file "hash.scm"
#~(define-module (gcrypt hash)
#:export (sha1 sha256))))
(with-imported-modules `(((guix config) (with-imported-modules `(((guix config)
=> ,(make-config.scm => ,(make-config.scm))
#:libgcrypt
(specification->package "libgcrypt"))) ;; To avoid relying on 'with-extensions', which was
;; introduced in 0.15.0, provide a fake (gcrypt
;; hash) just so that we can build modules, and
;; adjust %LOAD-PATH later on.
((gcrypt hash) => ,fake-gcrypt-hash)
,@(source-module-closure `((guix store) ,@(source-module-closure `((guix store)
(guix self) (guix self)
(guix derivations) (guix derivations)
@ -237,13 +283,24 @@ person's version identifier."
(match %load-path (match %load-path
((front _ ...) ((front _ ...)
(unless (string=? front source) ;already done? (unless (string=? front source) ;already done?
(set! %load-path (list source front))))))) (set! %load-path
(list source
(string-append #$guile-gcrypt
"/share/guile/site/"
(effective-version))
front)))))))
;; Only load our own modules or those of Guile. ;; Only load Guile-Gcrypt, our own modules, or those
;; of Guile.
(match %load-compiled-path (match %load-compiled-path
((front _ ... sys1 sys2) ((front _ ... sys1 sys2)
(set! %load-compiled-path (unless (string-prefix? #$guile-gcrypt front)
(list front sys1 sys2))))) (set! %load-compiled-path
(list (string-append #$guile-gcrypt
"/lib/guile/"
(effective-version)
"/site-ccache")
front sys1 sys2))))))
(use-modules (guix store) (use-modules (guix store)
(guix self) (guix self)

View File

@ -130,6 +130,11 @@ if test "x$guix_cv_have_recent_guile_sqlite3" != "xyes"; then
AC_MSG_ERROR([A recent Guile-SQLite3 could not be found; please install it.]) AC_MSG_ERROR([A recent Guile-SQLite3 could not be found; please install it.])
fi fi
GUILE_MODULE_AVAILABLE([have_guile_gcrypt], [(gcrypt hash)])
if test "x$have_guile_gcrypt" != "xyes"; then
AC_MSG_ERROR([Guile-Gcrypt could not be found; please install it.])
fi
dnl Make sure we have a full-fledged Guile. dnl Make sure we have a full-fledged Guile.
GUIX_ASSERT_GUILE_FEATURES([regex posix socket net-db threads]) GUIX_ASSERT_GUILE_FEATURES([regex posix socket net-db threads])
@ -213,16 +218,10 @@ AC_ARG_WITH([libgcrypt-libdir],
esac]) esac])
dnl If none of the --with-libgcrypt-* options was used, try to determine the dnl If none of the --with-libgcrypt-* options was used, try to determine the
dnl absolute file name of libgcrypt.so. dnl the library directory.
case "x$LIBGCRYPT_PREFIX$LIBGCRYPT_LIBDIR" in case "x$LIBGCRYPT_PREFIX$LIBGCRYPT_LIBDIR" in
xnono) xnono)
GUIX_LIBGCRYPT_LIBDIR([LIBGCRYPT_LIBDIR]) GUIX_LIBGCRYPT_LIBDIR([LIBGCRYPT_LIBDIR])
if test "x$LIBGCRYPT_LIBDIR" != x; then
LIBGCRYPT="$LIBGCRYPT_LIBDIR/libgcrypt"
else
dnl 'config-daemon.ac' expects "no" in this case.
LIBGCRYPT_LIBDIR="no"
fi
;; ;;
esac esac

View File

@ -620,7 +620,8 @@ GNU Guix depends on the following packages:
@itemize @itemize
@item @url{http://gnu.org/software/guile/, GNU Guile}, version 2.0.13 or @item @url{http://gnu.org/software/guile/, GNU Guile}, version 2.0.13 or
later, including 2.2.x; later, including 2.2.x;
@item @url{http://gnupg.org/, GNU libgcrypt}; @item @url{https://notabug.org/cwebber/guile-gcrypt, Guile-Gcrypt}, version
0.1.0 or later;
@item @item
@uref{http://gnutls.org/, GnuTLS}, specifically its Guile bindings @uref{http://gnutls.org/, GnuTLS}, specifically its Guile bindings
(@pxref{Guile Preparations, how to install the GnuTLS bindings for (@pxref{Guile Preparations, how to install the GnuTLS bindings for
@ -662,6 +663,7 @@ Unless @code{--disable-daemon} was passed to @command{configure}, the
following packages are also needed: following packages are also needed:
@itemize @itemize
@item @url{http://gnupg.org/, GNU libgcrypt};
@item @url{http://sqlite.org, SQLite 3}; @item @url{http://sqlite.org, SQLite 3};
@item @url{http://gcc.gnu.org, GCC's g++}, with support for the @item @url{http://gcc.gnu.org, GCC's g++}, with support for the
C++11 standard. C++11 standard.

View File

@ -36,7 +36,7 @@
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix build-system gnu) #:use-module (guix build-system gnu)
#:autoload (guix gnupg) (gnupg-verify*) #:autoload (guix gnupg) (gnupg-verify*)
#:autoload (guix hash) (port-sha256) #:autoload (gcrypt hash) (port-sha256)
#:autoload (guix base32) (bytevector->nix-base32-string) #:autoload (guix base32) (bytevector->nix-base32-string)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)

View File

@ -213,6 +213,7 @@
;; Guile-JSON, and Guile-Git automatically. ;; Guile-JSON, and Guile-Git automatically.
(let* ((out (assoc-ref outputs "out")) (let* ((out (assoc-ref outputs "out"))
(guile (assoc-ref inputs "guile")) (guile (assoc-ref inputs "guile"))
(gcrypt (assoc-ref inputs "guile-gcrypt"))
(json (assoc-ref inputs "guile-json")) (json (assoc-ref inputs "guile-json"))
(sqlite (assoc-ref inputs "guile-sqlite3")) (sqlite (assoc-ref inputs "guile-sqlite3"))
(git (assoc-ref inputs "guile-git")) (git (assoc-ref inputs "guile-git"))
@ -220,7 +221,8 @@
"guile-bytestructures")) "guile-bytestructures"))
(ssh (assoc-ref inputs "guile-ssh")) (ssh (assoc-ref inputs "guile-ssh"))
(gnutls (assoc-ref inputs "gnutls")) (gnutls (assoc-ref inputs "gnutls"))
(deps (list json sqlite gnutls git bs ssh)) (deps (list gcrypt json sqlite gnutls
git bs ssh))
(effective (effective
(read-line (read-line
(open-pipe* OPEN_READ (open-pipe* OPEN_READ
@ -279,6 +281,7 @@
'()))) '())))
(propagated-inputs (propagated-inputs
`(("gnutls" ,gnutls) `(("gnutls" ,gnutls)
("guile-gcrypt" ,guile-gcrypt)
("guile-json" ,guile-json) ("guile-json" ,guile-json)
("guile-sqlite3" ,guile-sqlite3) ("guile-sqlite3" ,guile-sqlite3)
("guile-ssh" ,guile-ssh) ("guile-ssh" ,guile-ssh)

View File

@ -32,7 +32,7 @@
#:use-module (guix modules) #:use-module (guix modules)
#:use-module (guix scripts pack) #:use-module (guix scripts pack)
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix hash) #:use-module (gcrypt hash)
#:use-module (guix base32) #:use-module (guix base32)
#:use-module ((guix self) #:select (make-config.scm)) #:use-module ((guix self) #:select (make-config.scm))
@ -43,7 +43,7 @@
#:use-module (gnu packages cdrom) #:use-module (gnu packages cdrom)
#:use-module (gnu packages compression) #:use-module (gnu packages compression)
#:use-module (gnu packages guile) #:use-module (gnu packages guile)
#:autoload (gnu packages gnupg) (libgcrypt) #:autoload (gnu packages gnupg) (guile-gcrypt)
#:use-module (gnu packages gawk) #:use-module (gnu packages gawk)
#:use-module (gnu packages bash) #:use-module (gnu packages bash)
#:use-module (gnu packages less) #:use-module (gnu packages less)
@ -124,10 +124,12 @@
(('gnu rest ...) #t) (('gnu rest ...) #t)
(rest #f))) (rest #f)))
(define guile-sqlite3&co (define gcrypt-sqlite3&co
;; Guile-SQLite3 and its propagated inputs. ;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs.
(cons guile-sqlite3 (append-map (lambda (package)
(package-transitive-propagated-inputs guile-sqlite3))) (cons package
(package-transitive-propagated-inputs package)))
(list guile-gcrypt guile-sqlite3)))
(define* (expression->derivation-in-linux-vm name exp (define* (expression->derivation-in-linux-vm name exp
#:key #:key
@ -164,10 +166,6 @@ based on the size of the closure of REFERENCES-GRAPHS.
When REFERENCES-GRAPHS is true, it must be a list of file name/store path When REFERENCES-GRAPHS is true, it must be a list of file name/store path
pairs, as for `derivation'. The files containing the reference graphs are pairs, as for `derivation'. The files containing the reference graphs are
made available under the /xchg CIFS share." made available under the /xchg CIFS share."
(define config
;; (guix config) module for consumption by (guix gcrypt).
(make-config.scm #:libgcrypt libgcrypt))
(define user-builder (define user-builder
(program-file "builder-in-linux-vm" exp)) (program-file "builder-in-linux-vm" exp))
@ -195,12 +193,14 @@ made available under the /xchg CIFS share."
(define builder (define builder
;; Code that launches the VM that evaluates EXP. ;; Code that launches the VM that evaluates EXP.
(with-extensions guile-sqlite3&co (with-extensions gcrypt-sqlite3&co
(with-imported-modules `(,@(source-module-closure (with-imported-modules `(,@(source-module-closure
'((guix build utils) '((guix build utils)
(gnu build vm)) (gnu build vm))
#:select? not-config?) #:select? not-config?)
((guix config) => ,config))
;; For consumption by (gnu store database).
((guix config) => ,(make-config.scm)))
#~(begin #~(begin
(use-modules (guix build utils) (use-modules (guix build utils)
(gnu build vm)) (gnu build vm))
@ -255,9 +255,6 @@ made available under the /xchg CIFS share."
"Return a bootable, stand-alone iso9660 image. "Return a bootable, stand-alone iso9660 image.
INPUTS is a list of inputs (as for packages)." INPUTS is a list of inputs (as for packages)."
(define config
(make-config.scm #:libgcrypt libgcrypt))
(define schema (define schema
(and register-closures? (and register-closures?
(local-file (search-path %load-path (local-file (search-path %load-path
@ -265,12 +262,12 @@ INPUTS is a list of inputs (as for packages)."
(expression->derivation-in-linux-vm (expression->derivation-in-linux-vm
name name
(with-extensions guile-sqlite3&co (with-extensions gcrypt-sqlite3&co
(with-imported-modules `(,@(source-module-closure '((gnu build vm) (with-imported-modules `(,@(source-module-closure '((gnu build vm)
(guix store database) (guix store database)
(guix build utils)) (guix build utils))
#:select? not-config?) #:select? not-config?)
((guix config) => ,config)) ((guix config) => ,(make-config.scm)))
#~(begin #~(begin
(use-modules (gnu build vm) (use-modules (gnu build vm)
(guix store database) (guix store database)
@ -347,9 +344,6 @@ INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy
all of INPUTS into the image being built. When REGISTER-CLOSURES? is true, all of INPUTS into the image being built. When REGISTER-CLOSURES? is true,
register INPUTS in the store database of the image so that Guix can be used in register INPUTS in the store database of the image so that Guix can be used in
the image." the image."
(define config
(make-config.scm #:libgcrypt libgcrypt))
(define schema (define schema
(and register-closures? (and register-closures?
(local-file (search-path %load-path (local-file (search-path %load-path
@ -357,13 +351,13 @@ the image."
(expression->derivation-in-linux-vm (expression->derivation-in-linux-vm
name name
(with-extensions guile-sqlite3&co (with-extensions gcrypt-sqlite3&co
(with-imported-modules `(,@(source-module-closure '((gnu build vm) (with-imported-modules `(,@(source-module-closure '((gnu build vm)
(gnu build bootloader) (gnu build bootloader)
(guix store database) (guix store database)
(guix build utils)) (guix build utils))
#:select? not-config?) #:select? not-config?)
((guix config) => ,config)) ((guix config) => ,(make-config.scm)))
#~(begin #~(begin
(use-modules (gnu build bootloader) (use-modules (gnu build bootloader)
(gnu build vm) (gnu build vm)
@ -462,10 +456,6 @@ makes sense when you want to build a GuixSD Docker image that has Guix
installed inside of it. If you don't need Guix (e.g., your GuixSD Docker installed inside of it. If you don't need Guix (e.g., your GuixSD Docker
image just contains a web server that is started by the Shepherd), then you image just contains a web server that is started by the Shepherd), then you
should set REGISTER-CLOSURES? to #f." should set REGISTER-CLOSURES? to #f."
(define config
;; (guix config) module for consumption by (guix gcrypt).
(make-config.scm #:libgcrypt libgcrypt))
(define schema (define schema
(and register-closures? (and register-closures?
(local-file (search-path %load-path (local-file (search-path %load-path
@ -475,8 +465,8 @@ should set REGISTER-CLOSURES? to #f."
(name -> (string-append name ".tar.gz")) (name -> (string-append name ".tar.gz"))
(graph -> "system-graph")) (graph -> "system-graph"))
(define build (define build
(with-extensions (cons guile-json ;for (guix docker) (with-extensions (cons guile-json ;for (guix docker)
guile-sqlite3&co) ;for (guix store database) gcrypt-sqlite3&co) ;for (guix store database)
(with-imported-modules `(,@(source-module-closure (with-imported-modules `(,@(source-module-closure
'((guix docker) '((guix docker)
(guix store database) (guix store database)
@ -484,7 +474,7 @@ should set REGISTER-CLOSURES? to #f."
(guix build store-copy) (guix build store-copy)
(gnu build vm)) (gnu build vm))
#:select? not-config?) #:select? not-config?)
((guix config) => ,config)) ((guix config) => ,(make-config.scm)))
#~(begin #~(begin
(use-modules (guix docker) (use-modules (guix docker)
(guix build utils) (guix build utils)

View File

@ -35,7 +35,7 @@
#:use-module (guix memoization) #:use-module (guix memoization)
#:use-module (guix combinators) #:use-module (guix combinators)
#:use-module (guix monads) #:use-module (guix monads)
#:use-module (guix hash) #:use-module (gcrypt hash)
#:use-module (guix base32) #:use-module (guix base32)
#:use-module (guix records) #:use-module (guix records)
#:use-module (guix sets) #:use-module (guix sets)

View File

@ -19,7 +19,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix docker) (define-module (guix docker)
#:use-module (guix hash) #:use-module (gcrypt hash)
#:use-module (guix base16) #:use-module (guix base16)
#:use-module ((guix build utils) #:use-module ((guix build utils)
#:select (mkdir-p #:select (mkdir-p

View File

@ -1,49 +0,0 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015 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 gcrypt)
#:use-module (guix config)
#:use-module (system foreign)
#:export (gcrypt-version
libgcrypt-func))
;;; Commentary:
;;;
;;; Common code for the GNU Libgcrypt bindings. Loading this module
;;; initializes Libgcrypt as a side effect.
;;;
;;; Code:
(define libgcrypt-func
(let ((lib (dynamic-link %libgcrypt)))
(lambda (func)
"Return a pointer to symbol FUNC in libgcrypt."
(dynamic-func func lib))))
(define gcrypt-version
;; According to the manual, this function must be called before any other,
;; and it's not clear whether it can be called more than once. So call it
;; right here from the top level.
(let* ((ptr (libgcrypt-func "gcry_check_version"))
(proc (pointer->procedure '* ptr '(*)))
(version (pointer->string (proc %null-pointer))))
(lambda ()
"Return the version number of libgcrypt as a string."
version)))
;;; gcrypt.scm ends here

View File

@ -21,7 +21,7 @@
#:use-module (git) #:use-module (git)
#:use-module (git object) #:use-module (git object)
#:use-module (guix base32) #:use-module (guix base32)
#:use-module (guix hash) #:use-module (gcrypt hash)
#:use-module ((guix build utils) #:select (mkdir-p)) #:use-module ((guix build utils) #:select (mkdir-p))
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix utils) #:use-module (guix utils)

View File

@ -1,184 +0,0 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018 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 hash)
#:use-module (guix gcrypt)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 binary-ports)
#:use-module (system foreign)
#:use-module ((guix build utils) #:select (dump-port))
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:export (sha1
sha256
open-sha256-port
port-sha256
file-sha256
open-sha256-input-port))
;;; Commentary:
;;;
;;; Cryptographic hashes.
;;;
;;; Code:
;;;
;;; Hash.
;;;
(define-syntax GCRY_MD_SHA256
;; Value as of Libgcrypt 1.5.2.
(identifier-syntax 8))
(define-syntax GCRY_MD_SHA1
(identifier-syntax 2))
(define bytevector-hash
(let ((hash (pointer->procedure void
(libgcrypt-func "gcry_md_hash_buffer")
`(,int * * ,size_t))))
(lambda (bv type size)
"Return the hash TYPE, of SIZE bytes, of BV as a bytevector."
(let ((digest (make-bytevector size)))
(hash type (bytevector->pointer digest)
(bytevector->pointer bv) (bytevector-length bv))
digest))))
(define sha1
(cut bytevector-hash <> GCRY_MD_SHA1 20))
(define sha256
(cut bytevector-hash <> GCRY_MD_SHA256 (/ 256 8)))
(define open-sha256-md
(let ((open (pointer->procedure int
(libgcrypt-func "gcry_md_open")
`(* ,int ,unsigned-int))))
(lambda ()
(let* ((md (bytevector->pointer (make-bytevector (sizeof '*))))
(err (open md GCRY_MD_SHA256 0)))
(if (zero? err)
(dereference-pointer md)
(throw 'gcrypt-error err))))))
(define md-write
(pointer->procedure void
(libgcrypt-func "gcry_md_write")
`(* * ,size_t)))
(define md-read
(pointer->procedure '*
(libgcrypt-func "gcry_md_read")
`(* ,int)))
(define md-close
(pointer->procedure void
(libgcrypt-func "gcry_md_close")
'(*)))
(define (open-sha256-port)
"Return two values: an output port, and a thunk. When the thunk is called,
it returns the SHA256 hash (a bytevector) of all the data written to the
output port."
(define sha256-md
(open-sha256-md))
(define digest #f)
(define position 0)
(define (finalize!)
(let ((ptr (md-read sha256-md 0)))
(set! digest (bytevector-copy (pointer->bytevector ptr 32)))
(md-close sha256-md)))
(define (write! bv offset len)
(if (zero? len)
(begin
(finalize!)
0)
(let ((ptr (bytevector->pointer bv offset)))
(md-write sha256-md ptr len)
(set! position (+ position len))
len)))
(define (get-position)
position)
(define (close)
(unless digest
(finalize!)))
(values (make-custom-binary-output-port "sha256"
write! get-position #f
close)
(lambda ()
(unless digest
(finalize!))
digest)))
(define (port-sha256 port)
"Return the SHA256 hash (a bytevector) of all the data drained from PORT."
(let-values (((out get)
(open-sha256-port)))
(dump-port port out)
(close-port out)
(get)))
(define (file-sha256 file)
"Return the SHA256 hash (a bytevector) of FILE."
(call-with-input-file file port-sha256))
(define (open-sha256-input-port port)
"Return an input port that wraps PORT and a thunk to get the hash of all the
data read from PORT. The thunk always returns the same value."
(define md
(open-sha256-md))
(define (read! bv start count)
(let ((n (get-bytevector-n! port bv start count)))
(if (eof-object? n)
0
(begin
(unless digest
(let ((ptr (bytevector->pointer bv start)))
(md-write md ptr n)))
n))))
(define digest #f)
(define (finalize!)
(let ((ptr (md-read md 0)))
(set! digest (bytevector-copy (pointer->bytevector ptr 32)))
(md-close md)))
(define (get-hash)
(unless digest
(finalize!))
digest)
(define (unbuffered port)
;; Guile <= 2.0.9 does not support 'setvbuf' on custom binary input ports.
(setvbuf port _IONBF)
port)
(values (unbuffered (make-custom-binary-input-port "sha256" read! #f #f #f))
get-hash))
;;; hash.scm ends here

View File

@ -34,7 +34,7 @@
#:use-module (guix ui) #:use-module (guix ui)
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix base64) #:use-module (guix base64)
#:autoload (guix hash) (sha256) #:autoload (gcrypt hash) (sha256)
#:use-module ((guix build utils) #:use-module ((guix build utils)
#:select (mkdir-p dump-port)) #:select (mkdir-p dump-port))
#:use-module ((guix build download) #:use-module ((guix build download)

View File

@ -27,7 +27,7 @@
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (json) #:use-module (json)
#:use-module (guix hash) #:use-module (gcrypt hash)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix base32) #:use-module (guix base32)

View File

@ -29,7 +29,7 @@
#:use-module (web uri) #:use-module (web uri)
#:use-module (guix memoization) #:use-module (guix memoization)
#:use-module (guix http-client) #:use-module (guix http-client)
#:use-module (guix hash) #:use-module (gcrypt hash)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix base32) #:use-module (guix base32)
#:use-module ((guix download) #:select (download-to-store)) #:use-module ((guix download) #:select (download-to-store))

View File

@ -20,7 +20,7 @@
#:use-module (guix base32) #:use-module (guix base32)
#:use-module (guix build-system cargo) #:use-module (guix build-system cargo)
#:use-module ((guix download) #:prefix download:) #:use-module ((guix download) #:prefix download:)
#:use-module (guix hash) #:use-module (gcrypt hash)
#:use-module (guix http-client) #:use-module (guix http-client)
#:use-module (guix import json) #:use-module (guix import json)
#:use-module (guix import utils) #:use-module (guix import utils)

View File

@ -32,7 +32,7 @@
#:use-module (guix http-client) #:use-module (guix http-client)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix ui) #:use-module (guix ui)
#:use-module (guix hash) #:use-module (gcrypt hash)
#:use-module (guix base32) #:use-module (guix base32)
#:use-module (guix upstream) #:use-module (guix upstream)
#:use-module (guix packages) #:use-module (guix packages)

View File

@ -21,7 +21,7 @@
#:use-module (guix import utils) #:use-module (guix import utils)
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix hash) #:use-module (gcrypt hash)
#:use-module (guix base32) #:use-module (guix base32)
#:use-module (guix upstream) #:use-module (guix upstream)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)

View File

@ -33,7 +33,7 @@
#:use-module ((guix import utils) #:select (factorize-uri recursive-import)) #:use-module ((guix import utils) #:select (factorize-uri recursive-import))
#:use-module (guix import cabal) #:use-module (guix import cabal)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix hash) #:use-module (gcrypt hash)
#:use-module (guix base32) #:use-module (guix base32)
#:use-module (guix memoization) #:use-module (guix memoization)
#:use-module (guix upstream) #:use-module (guix upstream)

View File

@ -26,7 +26,7 @@
#:use-module (srfi srfi-34) #:use-module (srfi srfi-34)
#:use-module (web uri) #:use-module (web uri)
#:use-module (guix http-client) #:use-module (guix http-client)
#:use-module (guix hash) #:use-module (gcrypt hash)
#:use-module (guix memoization) #:use-module (guix memoization)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix base32) #:use-module (guix base32)

View File

@ -23,7 +23,7 @@
(define-module (guix import utils) (define-module (guix import utils)
#:use-module (guix base32) #:use-module (guix base32)
#:use-module ((guix build download) #:prefix build:) #:use-module ((guix build download) #:prefix build:)
#:use-module (guix hash) #:use-module (gcrypt hash)
#:use-module (guix http-client) #:use-module (guix http-client)
#:use-module ((guix licenses) #:prefix license:) #:use-module ((guix licenses) #:prefix license:)
#:use-module (guix utils) #:use-module (guix utils)

View File

@ -25,9 +25,9 @@
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix store database) #:use-module (guix store database)
#:use-module (guix ui) ; for '_' #:use-module (guix ui) ; for '_'
#:use-module (guix hash) #:use-module (gcrypt hash)
#:use-module (guix pki) #:use-module (guix pki)
#:use-module (guix pk-crypto) #:use-module (gcrypt pk-crypto)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)

View File

@ -1,407 +0,0 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2017 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 pk-crypto)
#:use-module (guix base16)
#:use-module (guix gcrypt)
#:use-module (system foreign)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
#:export (canonical-sexp?
error-source
error-string
string->canonical-sexp
canonical-sexp->string
read-file-sexp
number->canonical-sexp
canonical-sexp-car
canonical-sexp-cdr
canonical-sexp-nth
canonical-sexp-nth-data
canonical-sexp-length
canonical-sexp-null?
canonical-sexp-list?
bytevector->hash-data
hash-data->bytevector
key-type
sign
verify
generate-key
find-sexp-token
canonical-sexp->sexp
sexp->canonical-sexp)
#:re-export (gcrypt-version))
;;; Commentary:
;;;
;;; Public key cryptographic routines from GNU Libgcrypt.
;;;;
;;; Libgcrypt uses "canonical s-expressions" to represent key material,
;;; parameters, and data. We keep it as an opaque object to map them to
;;; Scheme s-expressions because (1) Libgcrypt sexps may be stored in secure
;;; memory, and (2) the read syntax is different.
;;;
;;; A 'canonical-sexp->sexp' procedure is provided nevertheless, for use in
;;; cases where it is safe to move data out of Libgcrypt---e.g., when
;;; processing ACL entries, public keys, etc.
;;;
;;; Canonical sexps were defined by Rivest et al. in the IETF draft at
;;; <http://people.csail.mit.edu/rivest/Sexp.txt> for the purposes of SPKI
;;; (see <http://www.ietf.org/rfc/rfc2693.txt>.)
;;;
;;; Code:
;; Libgcrypt "s-expressions".
(define-wrapped-pointer-type <canonical-sexp>
canonical-sexp?
naked-pointer->canonical-sexp
canonical-sexp->pointer
(lambda (obj port)
;; Don't print OBJ's external representation: we don't want key material
;; to leak in backtraces and such.
(format port "#<canonical-sexp ~a | ~a>"
(number->string (object-address obj) 16)
(number->string (pointer-address (canonical-sexp->pointer obj))
16))))
(define finalize-canonical-sexp!
(libgcrypt-func "gcry_sexp_release"))
(define-inlinable (pointer->canonical-sexp ptr)
"Return a <canonical-sexp> that wraps PTR."
(let* ((sexp (naked-pointer->canonical-sexp ptr))
(ptr* (canonical-sexp->pointer sexp)))
;; Did we already have a <canonical-sexp> object for PTR?
(when (equal? ptr ptr*)
;; No, so we can safely add a finalizer (in Guile 2.0.9
;; 'set-pointer-finalizer!' *adds* a finalizer rather than replacing the
;; existing one.)
(set-pointer-finalizer! ptr finalize-canonical-sexp!))
sexp))
(define error-source
(let* ((ptr (libgcrypt-func "gcry_strsource"))
(proc (pointer->procedure '* ptr (list int))))
(lambda (err)
"Return the error source (a string) for ERR, an error code as thrown
along with 'gcry-error'."
(pointer->string (proc err)))))
(define error-string
(let* ((ptr (libgcrypt-func "gcry_strerror"))
(proc (pointer->procedure '* ptr (list int))))
(lambda (err)
"Return the error description (a string) for ERR, an error code as
thrown along with 'gcry-error'."
(pointer->string (proc err)))))
(define string->canonical-sexp
(let* ((ptr (libgcrypt-func "gcry_sexp_new"))
(proc (pointer->procedure int ptr `(* * ,size_t ,int))))
(lambda (str)
"Parse STR and return the corresponding gcrypt s-expression."
;; When STR comes from 'canonical-sexp->string', it may contain
;; characters that are really meant to be interpreted as bytes as in a C
;; 'char *'. Thus, convert STR to ISO-8859-1 so the byte values of the
;; characters are preserved.
(let* ((sexp (bytevector->pointer (make-bytevector (sizeof '*))))
(err (proc sexp (string->pointer str "ISO-8859-1") 0 1)))
(if (= 0 err)
(pointer->canonical-sexp (dereference-pointer sexp))
(throw 'gcry-error 'string->canonical-sexp err))))))
(define-syntax GCRYSEXP_FMT_ADVANCED
(identifier-syntax 3))
(define canonical-sexp->string
(let* ((ptr (libgcrypt-func "gcry_sexp_sprint"))
(proc (pointer->procedure size_t ptr `(* ,int * ,size_t))))
(lambda (sexp)
"Return a textual representation of SEXP."
(let loop ((len 1024))
(let* ((buf (bytevector->pointer (make-bytevector len)))
(size (proc (canonical-sexp->pointer sexp)
GCRYSEXP_FMT_ADVANCED buf len)))
(if (zero? size)
(loop (* len 2))
(pointer->string buf size "ISO-8859-1")))))))
(define (read-file-sexp file)
"Return the canonical sexp read from FILE."
(call-with-input-file file
(compose string->canonical-sexp
read-string)))
(define canonical-sexp-car
(let* ((ptr (libgcrypt-func "gcry_sexp_car"))
(proc (pointer->procedure '* ptr '(*))))
(lambda (lst)
"Return the first element of LST, an sexp, if that element is a list;
return #f if LST or its first element is not a list (this is different from
the usual Lisp 'car'.)"
(let ((result (proc (canonical-sexp->pointer lst))))
(if (null-pointer? result)
#f
(pointer->canonical-sexp result))))))
(define canonical-sexp-cdr
(let* ((ptr (libgcrypt-func "gcry_sexp_cdr"))
(proc (pointer->procedure '* ptr '(*))))
(lambda (lst)
"Return the tail of LST, an sexp, or #f if LST is not a list."
(let ((result (proc (canonical-sexp->pointer lst))))
(if (null-pointer? result)
#f
(pointer->canonical-sexp result))))))
(define canonical-sexp-nth
(let* ((ptr (libgcrypt-func "gcry_sexp_nth"))
(proc (pointer->procedure '* ptr `(* ,int))))
(lambda (lst index)
"Return the INDEXth nested element of LST, an s-expression. Return #f
if that element does not exist, or if it's an atom. (Note: this is obviously
different from Scheme's 'list-ref'.)"
(let ((result (proc (canonical-sexp->pointer lst) index)))
(if (null-pointer? result)
#f
(pointer->canonical-sexp result))))))
(define (dereference-size_t p)
"Return the size_t value pointed to by P."
(bytevector-uint-ref (pointer->bytevector p (sizeof size_t))
0 (native-endianness)
(sizeof size_t)))
(define canonical-sexp-length
(let* ((ptr (libgcrypt-func "gcry_sexp_length"))
(proc (pointer->procedure int ptr '(*))))
(lambda (sexp)
"Return the length of SEXP if it's a list (including the empty list);
return zero if SEXP is an atom."
(proc (canonical-sexp->pointer sexp)))))
(define token-string?
(let ((token-cs (char-set-union char-set:digit
char-set:letter
(char-set #\- #\. #\/ #\_
#\: #\* #\+ #\=))))
(lambda (str)
"Return #t if STR is a token as per Section 4.3 of
<http://people.csail.mit.edu/rivest/Sexp.txt>."
(and (not (string-null? str))
(string-every token-cs str)
(not (char-set-contains? char-set:digit (string-ref str 0)))))))
(define canonical-sexp-nth-data
(let* ((ptr (libgcrypt-func "gcry_sexp_nth_data"))
(proc (pointer->procedure '* ptr `(* ,int *))))
(lambda (lst index)
"Return as a symbol (for \"sexp tokens\") or a bytevector (for any other
\"octet string\") the INDEXth data element (atom) of LST, an s-expression.
Return #f if that element does not exist, or if it's a list."
(let* ((size* (bytevector->pointer (make-bytevector (sizeof '*))))
(result (proc (canonical-sexp->pointer lst) index size*)))
(if (null-pointer? result)
#f
(let* ((len (dereference-size_t size*))
(str (pointer->string result len "ISO-8859-1")))
;; The sexp spec speaks of "tokens" and "octet strings".
;; Sometimes these octet strings are actual strings (text),
;; sometimes they're bytevectors, and sometimes they're
;; multi-precision integers (MPIs). Only the application knows.
;; However, for convenience, we return a symbol when a token is
;; encountered since tokens are frequent (at least in the 'car'
;; of each sexp.)
(if (token-string? str)
(string->symbol str) ; an sexp "token"
(bytevector-copy ; application data, textual or binary
(pointer->bytevector result len)))))))))
(define (number->canonical-sexp number)
"Return an s-expression representing NUMBER."
(string->canonical-sexp (string-append "#" (number->string number 16) "#")))
(define* (bytevector->hash-data bv
#:optional
(hash-algo "sha256")
#:key (key-type 'ecc))
"Given BV, a bytevector containing a hash of type HASH-ALGO, return an
s-expression suitable for use as the 'data' argument for 'sign'. KEY-TYPE
must be a symbol: 'dsa, 'ecc, or 'rsa."
(string->canonical-sexp
(format #f "(data (flags ~a) (hash \"~a\" #~a#))"
(case key-type
((ecc dsa) "rfc6979")
((rsa) "pkcs1")
(else (error "unknown key type" key-type)))
hash-algo
(bytevector->base16-string bv))))
(define (key-type sexp)
"Return a symbol denoting the type of public or private key represented by
SEXP--e.g., 'rsa', 'ecc'--or #f if SEXP does not denote a valid key."
(case (canonical-sexp-nth-data sexp 0)
((public-key private-key)
(canonical-sexp-nth-data (canonical-sexp-nth sexp 1) 0))
(else #f)))
(define* (hash-data->bytevector data)
"Return two values: the hash value (a bytevector), and the hash algorithm (a
string) extracted from DATA, an sexp as returned by 'bytevector->hash-data'.
Return #f if DATA does not conform."
(let ((hash (find-sexp-token data 'hash)))
(if hash
(let ((algo (canonical-sexp-nth-data hash 1))
(value (canonical-sexp-nth-data hash 2)))
(values value (symbol->string algo)))
(values #f #f))))
(define sign
(let* ((ptr (libgcrypt-func "gcry_pk_sign"))
(proc (pointer->procedure int ptr '(* * *))))
(lambda (data secret-key)
"Sign DATA, a canonical s-expression representing a suitable hash, with
SECRET-KEY (a canonical s-expression whose car is 'private-key'.) Note that
DATA must be a 'data' s-expression, as returned by
'bytevector->hash-data' (info \"(gcrypt) Cryptographic Functions\")."
(let* ((sig (bytevector->pointer (make-bytevector (sizeof '*))))
(err (proc sig (canonical-sexp->pointer data)
(canonical-sexp->pointer secret-key))))
(if (= 0 err)
(pointer->canonical-sexp (dereference-pointer sig))
(throw 'gcry-error 'sign err))))))
(define verify
(let* ((ptr (libgcrypt-func "gcry_pk_verify"))
(proc (pointer->procedure int ptr '(* * *))))
(lambda (signature data public-key)
"Verify that SIGNATURE is a signature of DATA with PUBLIC-KEY, all of
which are gcrypt s-expressions."
(zero? (proc (canonical-sexp->pointer signature)
(canonical-sexp->pointer data)
(canonical-sexp->pointer public-key))))))
(define generate-key
(let* ((ptr (libgcrypt-func "gcry_pk_genkey"))
(proc (pointer->procedure int ptr '(* *))))
(lambda (params)
"Return as an s-expression a new key pair for PARAMS. PARAMS must be an
s-expression like: (genkey (rsa (nbits 4:2048)))."
(let* ((key (bytevector->pointer (make-bytevector (sizeof '*))))
(err (proc key (canonical-sexp->pointer params))))
(if (zero? err)
(pointer->canonical-sexp (dereference-pointer key))
(throw 'gcry-error 'generate-key err))))))
(define find-sexp-token
(let* ((ptr (libgcrypt-func "gcry_sexp_find_token"))
(proc (pointer->procedure '* ptr `(* * ,size_t))))
(lambda (sexp token)
"Find in SEXP the first element whose 'car' is TOKEN and return it;
return #f if not found."
(let* ((token (string->pointer (symbol->string token)))
(res (proc (canonical-sexp->pointer sexp) token 0)))
(if (null-pointer? res)
#f
(pointer->canonical-sexp res))))))
(define-inlinable (canonical-sexp-null? sexp)
"Return #t if SEXP is the empty-list sexp."
(null-pointer? (canonical-sexp->pointer sexp)))
(define (canonical-sexp-list? sexp)
"Return #t if SEXP is a list."
(or (canonical-sexp-null? sexp)
(> (canonical-sexp-length sexp) 0)))
(define (canonical-sexp-fold proc seed sexp)
"Fold PROC (as per SRFI-1) over SEXP, a canonical sexp."
(if (canonical-sexp-list? sexp)
(let ((len (canonical-sexp-length sexp)))
(let loop ((index 0)
(result seed))
(if (= index len)
result
(loop (+ 1 index)
;; XXX: Call 'nth-data' *before* 'nth' to work around
;; <https://bugs.g10code.com/gnupg/issue1594>, which
;; affects 1.6.0 and earlier versions.
(proc (or (canonical-sexp-nth-data sexp index)
(canonical-sexp-nth sexp index))
result)))))
(error "sexp is not a list" sexp)))
(define (canonical-sexp->sexp sexp)
"Return a Scheme sexp corresponding to SEXP. This is particularly useful to
compare sexps (since Libgcrypt does not provide an 'equal?' procedure), or to
use pattern matching."
(if (canonical-sexp-list? sexp)
(reverse
(canonical-sexp-fold (lambda (item result)
(cons (if (canonical-sexp? item)
(canonical-sexp->sexp item)
item)
result))
'()
sexp))
;; As of Libgcrypt 1.6.0, there's no function to extract the buffer of a
;; non-list sexp (!), so we first enlist SEXP, then get at its buffer.
(let ((sexp (string->canonical-sexp
(string-append "(" (canonical-sexp->string sexp)
")"))))
(or (canonical-sexp-nth-data sexp 0)
(canonical-sexp-nth sexp 0)))))
(define (sexp->canonical-sexp sexp)
"Return a canonical sexp equivalent to SEXP, a Scheme sexp as returned by
'canonical-sexp->sexp'."
;; XXX: This is inefficient, but the Libgcrypt API doesn't allow us to do
;; much better.
(string->canonical-sexp
(call-with-output-string
(lambda (port)
(define (write item)
(cond ((list? item)
(display "(" port)
(for-each write item)
(display ")" port))
((symbol? item)
(format port " ~a" item))
((bytevector? item)
(format port " #~a#"
(bytevector->base16-string item)))
(else
(error "unsupported sexp item type" item))))
(write sexp)))))
(define (gcrypt-error-printer port key args default-printer)
"Print the gcrypt error specified by ARGS."
(match args
((proc err)
(format port "In procedure ~a: ~a: ~a"
proc (error-source err) (error-string err)))))
(set-exception-printer! 'gcry-error gcrypt-error-printer)
;;; pk-crypto.scm ends here

View File

@ -18,7 +18,7 @@
(define-module (guix pki) (define-module (guix pki)
#:use-module (guix config) #:use-module (guix config)
#:use-module (guix pk-crypto) #:use-module (gcrypt pk-crypto)
#:use-module ((guix utils) #:select (with-atomic-file-output)) #:use-module ((guix utils) #:select (with-atomic-file-output))
#:use-module ((guix build utils) #:select (mkdir-p)) #:use-module ((guix build utils) #:select (mkdir-p))
#:use-module (ice-9 match) #:use-module (ice-9 match)

View File

@ -29,7 +29,7 @@
#:use-module (guix monads) #:use-module (guix monads)
#:use-module (guix ui) #:use-module (guix ui)
#:use-module (guix pki) #:use-module (guix pki)
#:use-module (guix pk-crypto) #:use-module (gcrypt pk-crypto)
#:use-module (guix scripts) #:use-module (guix scripts)
#:use-module (guix scripts build) #:use-module (guix scripts build)
#:use-module (gnu packages) #:use-module (gnu packages)

View File

@ -19,7 +19,7 @@
(define-module (guix scripts authenticate) (define-module (guix scripts authenticate)
#:use-module (guix config) #:use-module (guix config)
#:use-module (guix base16) #:use-module (guix base16)
#:use-module (guix pk-crypto) #:use-module (gcrypt pk-crypto)
#:use-module (guix pki) #:use-module (guix pki)
#:use-module (guix ui) #:use-module (guix ui)
#:use-module (ice-9 binary-ports) #:use-module (ice-9 binary-ports)

View File

@ -20,7 +20,7 @@
#:use-module (guix ui) #:use-module (guix ui)
#:use-module (guix scripts) #:use-module (guix scripts)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix hash) #:use-module (gcrypt hash)
#:use-module (guix base16) #:use-module (guix base16)
#:use-module (guix base32) #:use-module (guix base32)
#:use-module ((guix download) #:hide (url-fetch)) #:use-module ((guix download) #:hide (url-fetch))

View File

@ -20,7 +20,7 @@
(define-module (guix scripts hash) (define-module (guix scripts hash)
#:use-module (guix base32) #:use-module (guix base32)
#:use-module (guix hash) #:use-module (gcrypt hash)
#:use-module (guix serialization) #:use-module (guix serialization)
#:use-module (guix ui) #:use-module (guix ui)
#:use-module (guix scripts) #:use-module (guix scripts)
@ -44,7 +44,7 @@
`((format . ,bytevector->nix-base32-string))) `((format . ,bytevector->nix-base32-string)))
(define (show-help) (define (show-help)
(display (G_ "Usage: guix hash [OPTION] FILE (display (G_ "Usage: gcrypt hash [OPTION] FILE
Return the cryptographic hash of FILE. Return the cryptographic hash of FILE.
Supported formats: 'nix-base32' (default), 'base32', and 'base16' ('hex' Supported formats: 'nix-base32' (default), 'base32', and 'base16' ('hex'
@ -93,7 +93,7 @@ and 'hexadecimal' can be used as well).\n"))
(exit 0))) (exit 0)))
(option '(#\V "version") #f #f (option '(#\V "version") #f #f
(lambda args (lambda args
(show-version-and-exit "guix hash"))))) (show-version-and-exit "gcrypt hash")))))

View File

@ -41,7 +41,7 @@
#:use-module (gnu packages guile) #:use-module (gnu packages guile)
#:use-module (gnu packages base) #:use-module (gnu packages base)
#:autoload (gnu packages package-management) (guix) #:autoload (gnu packages package-management) (guix)
#:autoload (gnu packages gnupg) (libgcrypt) #:autoload (gnu packages gnupg) (guile-gcrypt)
#:autoload (gnu packages guile) (guile2.0-json guile-json) #:autoload (gnu packages guile) (guile2.0-json guile-json)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
@ -95,10 +95,12 @@ found."
(('gnu _ ...) #t) (('gnu _ ...) #t)
(_ #f))) (_ #f)))
(define guile-sqlite3&co (define gcrypt-sqlite3&co
;; Guile-SQLite3 and its propagated inputs. ;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs.
(cons guile-sqlite3 (append-map (lambda (package)
(package-transitive-propagated-inputs guile-sqlite3))) (cons package
(package-transitive-propagated-inputs package)))
(list guile-gcrypt guile-sqlite3)))
(define* (self-contained-tarball name profile (define* (self-contained-tarball name profile
#:key target #:key target
@ -124,16 +126,14 @@ added to the pack."
"guix/store/schema.sql")))) "guix/store/schema.sql"))))
(define build (define build
(with-imported-modules `(((guix config) (with-imported-modules `(((guix config) => ,(make-config.scm))
=> ,(make-config.scm
#:libgcrypt libgcrypt))
,@(source-module-closure ,@(source-module-closure
`((guix build utils) `((guix build utils)
(guix build union) (guix build union)
(guix build store-copy) (guix build store-copy)
(gnu build install)) (gnu build install))
#:select? not-config?)) #:select? not-config?))
(with-extensions guile-sqlite3&co (with-extensions gcrypt-sqlite3&co
#~(begin #~(begin
(use-modules (guix build utils) (use-modules (guix build utils)
((guix build union) #:select (relative-file-name)) ((guix build union) #:select (relative-file-name))
@ -251,22 +251,14 @@ points for virtual file systems (like procfs), and optional symlinks.
SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
added to the pack." added to the pack."
(define libgcrypt
;; XXX: Not strictly needed, but pulled by (guix store database).
(module-ref (resolve-interface '(gnu packages gnupg))
'libgcrypt))
(define build (define build
(with-imported-modules `(((guix config) (with-imported-modules `(((guix config) => ,(make-config.scm))
=> ,(make-config.scm
#:libgcrypt libgcrypt))
,@(source-module-closure ,@(source-module-closure
'((guix build utils) '((guix build utils)
(guix build store-copy) (guix build store-copy)
(gnu build install)) (gnu build install))
#:select? not-config?)) #:select? not-config?))
(with-extensions guile-sqlite3&co (with-extensions gcrypt-sqlite3&co
#~(begin #~(begin
(use-modules (guix build utils) (use-modules (guix build utils)
(gnu build install) (gnu build install)
@ -349,32 +341,12 @@ must a be a GNU triplet and it is used to derive the architecture metadata in
the image." the image."
(define defmod 'define-module) ;trick Geiser (define defmod 'define-module) ;trick Geiser
(define config
;; (guix config) module for consumption by (guix gcrypt).
(scheme-file "gcrypt-config.scm"
#~(begin
(#$defmod (guix config)
#:export (%libgcrypt))
;; XXX: Work around <http://bugs.gnu.org/15602>.
(eval-when (expand load eval)
(define %libgcrypt
#+(file-append libgcrypt "/lib/libgcrypt"))))))
(define json
;; Pick the guile-json package that corresponds to the Guile used to build
;; derivations.
(if (string-prefix? "2.0" (package-version (default-guile)))
guile2.0-json
guile-json))
(define build (define build
;; Guile-JSON is required by (guix docker). ;; Guile-JSON and Guile-Gcrypt are required by (guix docker).
(with-extensions (list json) (with-extensions (list guile-json guile-gcrypt)
(with-imported-modules `(,@(source-module-closure '((guix docker) (with-imported-modules (source-module-closure '((guix docker)
(guix build store-copy)) (guix build store-copy))
#:select? not-config?) #:select? not-config?)
((guix config) => ,config))
#~(begin #~(begin
(use-modules (guix docker) (srfi srfi-19) (guix build store-copy)) (use-modules (guix docker) (srfi srfi-19) (guix build store-copy))

View File

@ -44,9 +44,9 @@
#:use-module (guix base64) #:use-module (guix base64)
#:use-module (guix config) #:use-module (guix config)
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module (guix hash) #:use-module (gcrypt hash)
#:use-module (guix pki) #:use-module (guix pki)
#:use-module (guix pk-crypto) #:use-module (gcrypt pk-crypto)
#:use-module (guix workers) #:use-module (guix workers)
#:use-module (guix store) #:use-module (guix store)
#:use-module ((guix serialization) #:select (write-file)) #:use-module ((guix serialization) #:select (write-file))

View File

@ -23,7 +23,7 @@
(define-module (guix scripts refresh) (define-module (guix scripts refresh)
#:use-module (guix ui) #:use-module (guix ui)
#:use-module (guix hash) #:use-module (gcrypt hash)
#:use-module (guix scripts) #:use-module (guix scripts)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix utils) #:use-module (guix utils)

View File

@ -26,11 +26,11 @@
#:use-module (guix config) #:use-module (guix config)
#:use-module (guix records) #:use-module (guix records)
#:use-module ((guix serialization) #:select (restore-file)) #:use-module ((guix serialization) #:select (restore-file))
#:use-module (guix hash) #:use-module (gcrypt hash)
#:use-module (guix base32) #:use-module (guix base32)
#:use-module (guix base64) #:use-module (guix base64)
#:use-module (guix cache) #:use-module (guix cache)
#:use-module (guix pk-crypto) #:use-module (gcrypt pk-crypto)
#:use-module (guix pki) #:use-module (guix pki)
#:use-module ((guix build utils) #:select (mkdir-p dump-port)) #:use-module ((guix build utils) #:select (mkdir-p dump-port))
#:use-module ((guix build download) #:use-module ((guix build download)

View File

@ -83,8 +83,8 @@ GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches."
("guile-ssh" (ref '(gnu packages ssh) 'guile-ssh)) ("guile-ssh" (ref '(gnu packages ssh) 'guile-ssh))
("guile-git" (ref '(gnu packages guile) 'guile-git)) ("guile-git" (ref '(gnu packages guile) 'guile-git))
("guile-sqlite3" (ref '(gnu packages guile) 'guile-sqlite3)) ("guile-sqlite3" (ref '(gnu packages guile) 'guile-sqlite3))
("guile-gcrypt" (ref '(gnu packages gnupg) 'guile-gcrypt))
("gnutls" (ref '(gnu packages tls) 'gnutls)) ("gnutls" (ref '(gnu packages tls) 'gnutls))
("libgcrypt" (ref '(gnu packages gnupg) 'libgcrypt))
("zlib" (ref '(gnu packages compression) 'zlib)) ("zlib" (ref '(gnu packages compression) 'zlib))
("gzip" (ref '(gnu packages compression) 'gzip)) ("gzip" (ref '(gnu packages compression) 'gzip))
("bzip2" (ref '(gnu packages compression) 'bzip2)) ("bzip2" (ref '(gnu packages compression) 'bzip2))
@ -454,7 +454,6 @@ assumed to be part of MODULES."
(name (string-append "guix-" version)) (name (string-append "guix-" version))
(guile-version (effective-version)) (guile-version (effective-version))
(guile-for-build (guile-for-build guile-version)) (guile-for-build (guile-for-build guile-version))
(libgcrypt (specification->package "libgcrypt"))
(zlib (specification->package "zlib")) (zlib (specification->package "zlib"))
(gzip (specification->package "gzip")) (gzip (specification->package "gzip"))
(bzip2 (specification->package "bzip2")) (bzip2 (specification->package "bzip2"))
@ -481,6 +480,10 @@ assumed to be part of MODULES."
"guile-sqlite3" "guile-sqlite3"
"guile2.0-sqlite3")) "guile2.0-sqlite3"))
(define guile-gcrypt
(package-for-guile guile-version
"guile-gcrypt"))
(define gnutls (define gnutls
(package-for-guile guile-version (package-for-guile guile-version
"gnutls" "guile2.0-gnutls")) "gnutls" "guile2.0-gnutls"))
@ -489,7 +492,7 @@ assumed to be part of MODULES."
(match (append-map (lambda (package) (match (append-map (lambda (package)
(cons (list "x" package) (cons (list "x" package)
(package-transitive-propagated-inputs package))) (package-transitive-propagated-inputs package)))
(list gnutls guile-git guile-json (list guile-gcrypt gnutls guile-git guile-json
guile-ssh guile-sqlite3)) guile-ssh guile-sqlite3))
(((labels packages _ ...) ...) (((labels packages _ ...) ...)
packages))) packages)))
@ -513,10 +516,7 @@ assumed to be part of MODULES."
;; rebuilt when the version changes, which in turn means we ;; rebuilt when the version changes, which in turn means we
;; can have substitutes for it. ;; can have substitutes for it.
#:extra-modules #:extra-modules
`(((guix config) `(((guix config) => ,(make-config.scm)))
=> ,(make-config.scm #:libgcrypt
(specification->package
"libgcrypt"))))
;; (guix man-db) is needed at build-time by (guix profiles) ;; (guix man-db) is needed at build-time by (guix profiles)
;; but we don't need to compile it; not compiling it allows ;; but we don't need to compile it; not compiling it allows
@ -526,6 +526,7 @@ assumed to be part of MODULES."
("guix/store/schema.sql" ("guix/store/schema.sql"
,(local-file "../guix/store/schema.sql"))) ,(local-file "../guix/store/schema.sql")))
#:extensions (list guile-gcrypt)
#:guile-for-build guile-for-build)) #:guile-for-build guile-for-build))
(define *extra-modules* (define *extra-modules*
@ -600,8 +601,7 @@ assumed to be part of MODULES."
'() '()
#:extra-modules #:extra-modules
`(((guix config) `(((guix config)
=> ,(make-config.scm #:libgcrypt libgcrypt => ,(make-config.scm #:zlib zlib
#:zlib zlib
#:gzip gzip #:gzip gzip
#:bzip2 bzip2 #:bzip2 bzip2
#:xz xz #:xz xz
@ -684,7 +684,7 @@ assumed to be part of MODULES."
(define %dependency-variables (define %dependency-variables
;; (guix config) variables corresponding to dependencies. ;; (guix config) variables corresponding to dependencies.
'(%libgcrypt %libz %xz %gzip %bzip2)) '(%libz %xz %gzip %bzip2))
(define %persona-variables (define %persona-variables
;; (guix config) variables that define Guix's persona. ;; (guix config) variables that define Guix's persona.
@ -703,7 +703,7 @@ assumed to be part of MODULES."
(variables rest ...)))))) (variables rest ...))))))
(variables %localstatedir %storedir %sysconfdir %system))) (variables %localstatedir %storedir %sysconfdir %system)))
(define* (make-config.scm #:key libgcrypt zlib gzip xz bzip2 (define* (make-config.scm #:key zlib gzip xz bzip2
(package-name "GNU Guix") (package-name "GNU Guix")
(package-version "0") (package-version "0")
(bug-report-address "bug-guix@gnu.org") (bug-report-address "bug-guix@gnu.org")
@ -723,7 +723,6 @@ assumed to be part of MODULES."
%state-directory %state-directory
%store-database-directory %store-database-directory
%config-directory %config-directory
%libgcrypt
%libz %libz
%gzip %gzip
%bzip2 %bzip2
@ -766,9 +765,6 @@ assumed to be part of MODULES."
(define %xz (define %xz
#+(and xz (file-append xz "/bin/xz"))) #+(and xz (file-append xz "/bin/xz")))
(define %libgcrypt
#+(and libgcrypt
(file-append libgcrypt "/lib/libgcrypt")))
(define %libz (define %libz
#+(and zlib #+(and zlib
(file-append zlib "/lib/libz")))) (file-append zlib "/lib/libz"))))

View File

@ -25,7 +25,7 @@
#:use-module (guix monads) #:use-module (guix monads)
#:use-module (guix base16) #:use-module (guix base16)
#:use-module (guix base32) #:use-module (guix base32)
#:use-module (guix hash) #:use-module (gcrypt hash)
#:use-module (guix profiling) #:use-module (guix profiling)
#:autoload (guix build syscalls) (terminal-columns) #:autoload (guix build syscalls) (terminal-columns)
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)

View File

@ -21,7 +21,7 @@
;;; timestamps, deduplicating, etc. ;;; timestamps, deduplicating, etc.
(define-module (guix store deduplication) (define-module (guix store deduplication)
#:use-module (guix hash) #:use-module (gcrypt hash)
#:use-module (guix build utils) #:use-module (guix build utils)
#:use-module (guix base16) #:use-module (guix base16)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)

View File

@ -22,7 +22,7 @@
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix base32) #:use-module (guix base32)
#:use-module (guix serialization) #:use-module (guix serialization)
#:use-module (guix hash) #:use-module (gcrypt hash)
#:use-module (guix build-system gnu) #:use-module (guix build-system gnu)
#:use-module (gnu packages bootstrap) #:use-module (gnu packages bootstrap)
#:use-module (srfi srfi-34) #:use-module (srfi srfi-34)

View File

@ -18,24 +18,6 @@ dnl
dnl You should have received a copy of the GNU General Public License dnl You should have received a copy of the GNU General Public License
dnl along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. dnl along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
dnl GUIX_ASSERT_LIBGCRYPT_USABLE
dnl
dnl Assert that GNU libgcrypt is usable from Guile.
AC_DEFUN([GUIX_ASSERT_LIBGCRYPT_USABLE],
[AC_CACHE_CHECK([whether $LIBGCRYPT can be dynamically loaded],
[guix_cv_libgcrypt_usable_p],
[GUILE_CHECK([retval],
[(dynamic-func \"gcry_md_hash_buffer\" (dynamic-link \"$LIBGCRYPT\"))])
if test "$retval" = 0; then
guix_cv_libgcrypt_usable_p="yes"
else
guix_cv_libgcrypt_usable_p="no"
fi])
if test "x$guix_cv_libgcrypt_usable_p" != "xyes"; then
AC_MSG_ERROR([GNU libgcrypt does not appear to be usable; see `--with-libgcrypt-prefix' and `README'.])
fi])
dnl GUIX_SYSTEM_TYPE dnl GUIX_SYSTEM_TYPE
dnl dnl
dnl Determine the Guix host system type, and store it in the dnl Determine the Guix host system type, and store it in the

View File

@ -17,7 +17,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (test-base32) (define-module (test-base32)
#:use-module (guix hash) #:use-module (gcrypt hash)
#:use-module (guix base32) #:use-module (guix base32)
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)

View File

@ -25,7 +25,7 @@
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix base32) #:use-module (guix base32)
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module (guix hash) #:use-module (gcrypt hash)
#:use-module (guix tests) #:use-module (guix tests)
#:use-module ((guix packages) #:use-module ((guix packages)
#:select (package-derivation package-native-search-paths)) #:select (package-derivation package-native-search-paths))

View File

@ -18,7 +18,7 @@
(define-module (test-challenge) (define-module (test-challenge)
#:use-module (guix tests) #:use-module (guix tests)
#:use-module (guix hash) #:use-module (gcrypt hash)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix monads) #:use-module (guix monads)
#:use-module (guix derivations) #:use-module (guix derivations)

View File

@ -20,7 +20,7 @@
(define-module (test-cpan) (define-module (test-cpan)
#:use-module (guix import cpan) #:use-module (guix import cpan)
#:use-module (guix base32) #:use-module (guix base32)
#:use-module (guix hash) #:use-module (gcrypt hash)
#:use-module (guix tests) #:use-module (guix tests)
#:use-module (guix grafts) #:use-module (guix grafts)
#:use-module (srfi srfi-64) #:use-module (srfi srfi-64)

View File

@ -21,7 +21,7 @@
#:use-module (guix import crate) #:use-module (guix import crate)
#:use-module (guix base32) #:use-module (guix base32)
#:use-module (guix build-system cargo) #:use-module (guix build-system cargo)
#:use-module (guix hash) #:use-module (gcrypt hash)
#:use-module (guix tests) #:use-module (guix tests)
#:use-module (ice-9 iconv) #:use-module (ice-9 iconv)
#:use-module (ice-9 match) #:use-module (ice-9 match)

View File

@ -23,7 +23,7 @@
#:use-module (guix grafts) #:use-module (guix grafts)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix hash) #:use-module (gcrypt hash)
#:use-module (guix base32) #:use-module (guix base32)
#:use-module (guix tests) #:use-module (guix tests)
#:use-module (guix tests http) #:use-module (guix tests http)

View File

@ -21,7 +21,7 @@
(define-module (test-gem) (define-module (test-gem)
#:use-module (guix import gem) #:use-module (guix import gem)
#:use-module (guix base32) #:use-module (guix base32)
#:use-module (guix hash) #:use-module (gcrypt hash)
#:use-module (guix tests) #:use-module (guix tests)
#:use-module ((guix build utils) #:select (delete-file-recursively)) #:use-module ((guix build utils) #:select (delete-file-recursively))
#:use-module (srfi srfi-41) #:use-module (srfi srfi-41)

View File

@ -1,128 +0,0 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2017, 2018 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 (test-hash)
#:use-module (guix hash)
#:use-module (guix base16)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-64)
#:use-module (rnrs bytevectors)
#:use-module (rnrs io ports))
;; Test the (guix hash) module.
(define %empty-sha256
;; SHA256 hash of the empty string.
(base16-string->bytevector
"e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"))
(define %hello-sha256
;; SHA256 hash of "hello world"
(base16-string->bytevector
"b94d27b9934d3e08a52e52d7da7dabfac484efe37a5380ee9088f7ace2efcde9"))
(test-begin "hash")
(test-equal "sha1, empty"
(base16-string->bytevector "da39a3ee5e6b4b0d3255bfef95601890afd80709")
(sha1 #vu8()))
(test-equal "sha1, hello"
(base16-string->bytevector "2aae6c35c94fcfb415dbe95f408b9ce91ee846ed")
(sha1 (string->utf8 "hello world")))
(test-equal "sha256, empty"
%empty-sha256
(sha256 #vu8()))
(test-equal "sha256, hello"
%hello-sha256
(sha256 (string->utf8 "hello world")))
(test-equal "open-sha256-port, empty"
%empty-sha256
(let-values (((port get)
(open-sha256-port)))
(close-port port)
(get)))
(test-equal "open-sha256-port, hello"
(list %hello-sha256 (string-length "hello world"))
(let-values (((port get)
(open-sha256-port)))
(put-bytevector port (string->utf8 "hello world"))
(force-output port)
(list (get) (port-position port))))
(test-assert "port-sha256"
(let* ((file (search-path %load-path "ice-9/psyntax.scm"))
(size (stat:size (stat file)))
(contents (call-with-input-file file get-bytevector-all)))
(equal? (sha256 contents)
(call-with-input-file file port-sha256))))
(test-equal "open-sha256-input-port, empty"
`("" ,%empty-sha256)
(let-values (((port get)
(open-sha256-input-port (open-string-input-port ""))))
(let ((str (get-string-all port)))
(list str (get)))))
(test-equal "open-sha256-input-port, hello"
`("hello world" ,%hello-sha256)
(let-values (((port get)
(open-sha256-input-port
(open-bytevector-input-port
(string->utf8 "hello world")))))
(let ((str (get-string-all port)))
(list str (get)))))
(test-equal "open-sha256-input-port, hello, one two"
(list (string->utf8 "hel") (string->utf8 "lo")
(base16-string->bytevector ; echo -n hello | sha256sum
"2cf24dba5fb0a30e26e83b2ac5b9e29e1b161e5c1fa7425e73043362938b9824")
" world")
(let-values (((port get)
(open-sha256-input-port
(open-bytevector-input-port (string->utf8 "hello world")))))
(let* ((one (get-bytevector-n port 3))
(two (get-bytevector-n port 2))
(hash (get))
(three (get-string-all port)))
(list one two hash three))))
(test-equal "open-sha256-input-port, hello, read from wrapped port"
(list (string->utf8 "hello")
(base16-string->bytevector ; echo -n hello | sha256sum
"2cf24dba5fb0a30e26e83b2ac5b9e29e1b161e5c1fa7425e73043362938b9824")
" world")
(let*-values (((wrapped)
(open-bytevector-input-port (string->utf8 "hello world")))
((port get)
(open-sha256-input-port wrapped)))
(let* ((hello (get-bytevector-n port 5))
(hash (get))
;; Now read from WRAPPED to make sure its current position is
;; correct.
(world (get-string-all wrapped)))
(list hello hash world))))
(test-end)

View File

@ -21,7 +21,7 @@
#:use-module (guix nar) #:use-module (guix nar)
#:use-module (guix serialization) #:use-module (guix serialization)
#:use-module (guix store) #:use-module (guix store)
#:use-module ((guix hash) #:use-module ((gcrypt hash)
#:select (open-sha256-port open-sha256-input-port)) #:select (open-sha256-port open-sha256-input-port))
#:use-module ((guix packages) #:use-module ((guix packages)
#:select (base32)) #:select (base32))

View File

@ -19,7 +19,7 @@
(define-module (test-opam) (define-module (test-opam)
#:use-module (guix import opam) #:use-module (guix import opam)
#:use-module (guix base32) #:use-module (guix base32)
#:use-module (guix hash) #:use-module (gcrypt hash)
#:use-module (guix tests) #:use-module (guix tests)
#:use-module ((guix build utils) #:select (delete-file-recursively mkdir-p which)) #:use-module ((guix build utils) #:select (delete-file-recursively mkdir-p which))
#:use-module (srfi srfi-64) #:use-module (srfi srfi-64)

View File

@ -28,7 +28,7 @@
#:renamer (lambda (name) #:renamer (lambda (name)
(cond ((eq? name 'location) 'make-location) (cond ((eq? name 'location) 'make-location)
(else name)))) (else name))))
#:use-module (guix hash) #:use-module (gcrypt hash)
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix grafts) #:use-module (guix grafts)

View File

@ -1,290 +0,0 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2017 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 (test-pk-crypto)
#:use-module (guix pk-crypto)
#:use-module (guix utils)
#:use-module (guix base16)
#:use-module (guix hash)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-64)
#:use-module (rnrs bytevectors)
#:use-module (rnrs io ports)
#:use-module (ice-9 match))
;; Test the (guix pk-crypto) module.
(define %key-pair
;; RSA key pair that was generated with:
;; (generate-key (string->canonical-sexp "(genkey (rsa (nbits 4:1024)))"))
;; which takes a bit of time.
"(key-data
(public-key
(rsa
(n #00C1F764069F54FFE93A126B02328903E984E4AE3AF6DF402B5B6B3907911B88C385F1BA76A002EC9DEA109A5228EF0E62EE31A06D1A5861CAB474F6C857AC66EB65A1905F25BBA1869579E73A3B7FED13AF5A1667326F88CDFC2FF24B03C14FD1384AA7E73CA89572880B606E3A974E15347963FC7B6378574936A47580DBCB45#)
(e #010001#)))
(private-key
(rsa
(n #00C1F764069F54FFE93A126B02328903E984E4AE3AF6DF402B5B6B3907911B88C385F1BA76A002EC9DEA109A5228EF0E62EE31A06D1A5861CAB474F6C857AC66EB65A1905F25BBA1869579E73A3B7FED13AF5A1667326F88CDFC2FF24B03C14FD1384AA7E73CA89572880B606E3A974E15347963FC7B6378574936A47580DBCB45#)
(e #010001#)
(d #58CAD84653D0046A8EC3F9AA82D9C829B145422109FC3F12DA01A694B92FA296E70D366FB166454D30E632CEE3A033B4C41781BA10325F69FCDC0250CA19C8EEB352FA085992494098DB133E682ED38A931701F0DED1A1E508F4341A4FB446A04F019427C7CB3C44F251EEA9D386100DA80F125E0FD5CE1B0DFEC6D21516EACD#)
(p #00D47F185147EC39393CCDA4E7323FFC20FC8B8073E2A54DD63BA392A66975E4204CA48572496A9DFD7522436B852C07472A5AB25B7706F7C14E6F33FBC420FF3B#)
(q #00E9AD22F158060BC9AE3601DA623AFC60FFF3058795802CA92371C00097335CF9A23D7782DE353C9DBA93D7BB99E6A24A411107605E722481C5C191F80D7EB77F#)
(u #59B45B95AE01A7A7370FAFDB08FE73A4793CE37F228961B09B1B1E7DDAD9F8D3E28F5C5E8B4B067E6B8E0BBF3F690B42991A79E46108DDCDA2514323A66964DE#))))")
(define %ecc-key-pair
;; Ed25519 key pair generated with:
;; (generate-key (string->canonical-sexp "(genkey (ecdsa (curve Ed25519) (flags rfc6979 transient)))"))
"(key-data
(public-key
(ecc
(curve Ed25519)
(q #94869C1B9E69DB8DD910B7F7F4D6E56A63A964A59AE8F90F6703ACDDF6F50C81#)))
(private-key
(ecc
(curve Ed25519)
(q #94869C1B9E69DB8DD910B7F7F4D6E56A63A964A59AE8F90F6703ACDDF6F50C81#)
(d #6EFB32D0B4EC6B3237B523539F1979379B82726AAA605EB2FBA6775B2B777B78#))))")
(test-begin "pk-crypto")
(test-assert "version"
(gcrypt-version))
(let ((sexps '("(foo bar)"
;; In Libgcrypt 1.5.3 the following integer is rendered as
;; binary, whereas in 1.6.0 it's rendered as is (hexadecimal.)
;;"#C0FFEE#"
"(genkey \n (rsa \n (nbits \"1024\")\n )\n )")))
(test-equal "string->canonical-sexp->string"
sexps
(let ((sexps (map string->canonical-sexp sexps)))
(and (every canonical-sexp? sexps)
(map (compose string-trim-both canonical-sexp->string) sexps)))))
(gc) ; stress test!
(let ((sexps `(("(foo bar)" foo -> "(foo bar)")
("(foo (bar (baz 3:123)))" baz -> "(baz \"123\")")
("(foo (bar 3:123))" baz -> #f))))
(test-equal "find-sexp-token"
(map (match-lambda
((_ _ '-> expected)
expected))
sexps)
(map (match-lambda
((input token '-> _)
(let ((sexp (find-sexp-token (string->canonical-sexp input) token)))
(and sexp
(string-trim-both (canonical-sexp->string sexp))))))
sexps)))
(gc)
(test-equal "canonical-sexp-length"
'(0 1 2 4 0 0)
(map (compose canonical-sexp-length string->canonical-sexp)
'("()" "(a)" "(a b)" "(a #616263# b #C001#)" "a" "#123456#")))
(test-equal "canonical-sexp-list?"
'(#t #f #t #f)
(map (compose canonical-sexp-list? string->canonical-sexp)
'("()" "\"abc\"" "(a b c)" "#123456#")))
(gc)
(test-equal "canonical-sexp-car + cdr"
'("(b \n (c xyz)\n )")
(let ((lst (string->canonical-sexp "(a (b (c xyz)))")))
(map (lambda (sexp)
(and sexp (string-trim-both (canonical-sexp->string sexp))))
;; Note: 'car' returns #f when the first element is an atom.
(list (canonical-sexp-car (canonical-sexp-cdr lst))))))
(gc)
(test-equal "canonical-sexp-nth"
'("(b pqr)" "(c \"456\")" "(d xyz)" #f #f)
(let ((lst (string->canonical-sexp "(a (b 3:pqr) (c 3:456) (d 3:xyz))")))
;; XXX: In Libgcrypt 1.5.3, (canonical-sexp-nth lst 0) returns LST, whereas in
;; 1.6.0 it returns #f.
(map (lambda (sexp)
(and sexp (string-trim-both (canonical-sexp->string sexp))))
(unfold (cut > <> 5)
(cut canonical-sexp-nth lst <>)
1+
1))))
(gc)
(test-equal "canonical-sexp-nth-data"
`(Name Otto Meier #f ,(base16-string->bytevector "123456") #f)
(let ((lst (string->canonical-sexp
"(Name Otto Meier (address Burgplatz) #123456#)")))
(unfold (cut > <> 5)
(cut canonical-sexp-nth-data lst <>)
1+
0)))
(let ((bv (base16-string->bytevector
"5eff0b55c9c5f5e87b4e34cd60a2d5654ca1eb78c7b3c67c3179fed1cff07b4c")))
(test-equal "hash corrupt due to restrictive locale encoding"
bv
;; In Guix up to 0.6 included this test would fail because at some point
;; the hash value would be cropped to ASCII. In practice 'guix
;; authenticate' would produce invalid signatures that would fail
;; signature verification. See <http://bugs.gnu.org/17312>.
(let ((locale (setlocale LC_ALL)))
(dynamic-wind
(lambda ()
(setlocale LC_ALL "C"))
(lambda ()
(hash-data->bytevector
(string->canonical-sexp
(canonical-sexp->string
(bytevector->hash-data bv "sha256")))))
(lambda ()
(setlocale LC_ALL locale))))))
(gc)
;; XXX: The test below is typically too long as it needs to gather enough entropy.
;; (test-assert "generate-key"
;; (let ((key (generate-key (string->canonical-sexp
;; "(genkey (rsa (nbits 3:128)))"))))
;; (and (canonical-sexp? key)
;; (find-sexp-token key 'key-data)
;; (find-sexp-token key 'public-key)
;; (find-sexp-token key 'private-key))))
(test-assert "bytevector->hash-data->bytevector"
(let* ((bv (sha256 (string->utf8 "Hello, world.")))
(data (bytevector->hash-data bv "sha256")))
(and (canonical-sexp? data)
(let-values (((value algo) (hash-data->bytevector data)))
(and (string=? algo "sha256")
(bytevector=? value bv))))))
(test-equal "key-type"
'(rsa ecc)
(map (compose key-type
(cut find-sexp-token <> 'public-key)
string->canonical-sexp)
(list %key-pair %ecc-key-pair)))
(test-assert "sign + verify"
(let* ((pair (string->canonical-sexp %key-pair))
(secret (find-sexp-token pair 'private-key))
(public (find-sexp-token pair 'public-key))
(data (bytevector->hash-data
(sha256 (string->utf8 "Hello, world."))
#:key-type (key-type public)))
(sig (sign data secret)))
(and (verify sig data public)
(not (verify sig
(bytevector->hash-data
(sha256 (string->utf8 "Hi!"))
#:key-type (key-type public))
public)))))
;; Ed25519 appeared in libgcrypt 1.6.0.
(test-skip (if (version>? (gcrypt-version) "1.6.0") 0 1))
(test-assert "sign + verify, Ed25519"
(let* ((pair (string->canonical-sexp %ecc-key-pair))
(secret (find-sexp-token pair 'private-key))
(public (find-sexp-token pair 'public-key))
(data (bytevector->hash-data
(sha256 (string->utf8 "Hello, world."))))
(sig (sign data secret)))
(and (verify sig data public)
(not (verify sig
(bytevector->hash-data
(sha256 (string->utf8 "Hi!")))
public)))))
(gc)
(test-equal "canonical-sexp->sexp"
`((data
(flags pkcs1)
(hash sha256
,(base16-string->bytevector
"2749f0ea9f26c6c7be746a9cff8fa4c2f2a02b000070dba78429e9a11f87c6eb")))
(public-key
(rsa
(n ,(base16-string->bytevector
(string-downcase
"00C1F764069F54FFE93A126B02328903E984E4AE3AF6DF402B5B6B3907911B88C385F1BA76A002EC9DEA109A5228EF0E62EE31A06D1A5861CAB474F6C857AC66EB65A1905F25BBA1869579E73A3B7FED13AF5A1667326F88CDFC2FF24B03C14FD1384AA7E73CA89572880B606E3A974E15347963FC7B6378574936A47580DBCB45")))
(e ,(base16-string->bytevector
"010001")))))
(list (canonical-sexp->sexp
(string->canonical-sexp
"(data
(flags pkcs1)
(hash \"sha256\"
#2749f0ea9f26c6c7be746a9cff8fa4c2f2a02b000070dba78429e9a11f87c6eb#))"))
(canonical-sexp->sexp
(find-sexp-token (string->canonical-sexp %key-pair)
'public-key))))
(let ((lst
`((data
(flags pkcs1)
(hash sha256
,(base16-string->bytevector
"2749f0ea9f26c6c7be746a9cff8fa4c2f2a02b000070dba78429e9a11f87c6eb")))
(public-key
(rsa
(n ,(base16-string->bytevector
(string-downcase
"00C1F764069F54FFE93A126B02328903E984E4AE3AF6DF402B5B6B3907911B88C385F1BA76A002EC9DEA109A5228EF0E62EE31A06D1A5861CAB474F6C857AC66EB65A1905F25BBA1869579E73A3B7FED13AF5A1667326F88CDFC2FF24B03C14FD1384AA7E73CA89572880B606E3A974E15347963FC7B6378574936A47580DBCB45")))
(e ,(base16-string->bytevector
"010001"))))
,(base16-string->bytevector
"2749f0ea9f26c6c7be746a9cff8fa4c2f2a02b000070dba78429e9a11f87c6eb"))))
(test-equal "sexp->canonical-sexp->sexp"
lst
(map (compose canonical-sexp->sexp sexp->canonical-sexp)
lst)))
(let ((sexp `(signature
(public-key
(rsa
(n ,(make-bytevector 1024 1))
(e ,(base16-string->bytevector "010001")))))))
(test-equal "https://bugs.g10code.com/gnupg/issue1594"
;; The gcrypt bug above was primarily affecting our uses in
;; 'canonical-sexp->sexp', typically when applied to a signature sexp (in
;; 'guix authenticate -verify') with a "big" RSA key, such as 4096 bits.
sexp
(canonical-sexp->sexp (sexp->canonical-sexp sexp))))
(test-end)

View File

@ -18,8 +18,8 @@
(define-module (test-pki) (define-module (test-pki)
#:use-module (guix pki) #:use-module (guix pki)
#:use-module (guix pk-crypto) #:use-module (gcrypt pk-crypto)
#:use-module (guix hash) #:use-module (gcrypt hash)
#:use-module (rnrs io ports) #:use-module (rnrs io ports)
#:use-module (srfi srfi-64)) #:use-module (srfi srfi-64))

View File

@ -25,7 +25,7 @@
#:use-module (guix tests) #:use-module (guix tests)
#:use-module (guix config) #:use-module (guix config)
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix hash) #:use-module (gcrypt hash)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module (guix gexp) #:use-module (guix gexp)
@ -33,7 +33,7 @@
#:use-module (guix base64) #:use-module (guix base64)
#:use-module ((guix records) #:select (recutils->alist)) #:use-module ((guix records) #:select (recutils->alist))
#:use-module ((guix serialization) #:select (restore-file)) #:use-module ((guix serialization) #:select (restore-file))
#:use-module (guix pk-crypto) #:use-module (gcrypt pk-crypto)
#:use-module ((guix pki) #:select (%public-key-file %private-key-file)) #:use-module ((guix pki) #:select (%public-key-file %private-key-file))
#:use-module (guix zlib) #:use-module (guix zlib)
#:use-module (web uri) #:use-module (web uri)

View File

@ -20,7 +20,7 @@
(define-module (test-pypi) (define-module (test-pypi)
#:use-module (guix import pypi) #:use-module (guix import pypi)
#:use-module (guix base32) #:use-module (guix base32)
#:use-module (guix hash) #:use-module (gcrypt hash)
#:use-module (guix tests) #:use-module (guix tests)
#:use-module (guix build-system python) #:use-module (guix build-system python)
#:use-module ((guix build utils) #:select (delete-file-recursively which)) #:use-module ((guix build utils) #:select (delete-file-recursively which))

View File

@ -19,7 +19,7 @@
(define-module (test-store-deduplication) (define-module (test-store-deduplication)
#:use-module (guix tests) #:use-module (guix tests)
#:use-module (guix store deduplication) #:use-module (guix store deduplication)
#:use-module (guix hash) #:use-module (gcrypt hash)
#:use-module ((guix utils) #:select (call-with-temporary-directory)) #:use-module ((guix utils) #:select (call-with-temporary-directory))
#:use-module (guix build utils) #:use-module (guix build utils)
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)

View File

@ -21,7 +21,7 @@
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix monads) #:use-module (guix monads)
#:use-module (guix hash) #:use-module (gcrypt hash)
#:use-module (guix base32) #:use-module (guix base32)
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix derivations) #:use-module (guix derivations)

View File

@ -20,9 +20,9 @@
(define-module (test-substitute) (define-module (test-substitute)
#:use-module (guix scripts substitute) #:use-module (guix scripts substitute)
#:use-module (guix base64) #:use-module (guix base64)
#:use-module (guix hash) #:use-module (gcrypt hash)
#:use-module (guix serialization) #:use-module (guix serialization)
#:use-module (guix pk-crypto) #:use-module (gcrypt pk-crypto)
#:use-module (guix pki) #:use-module (guix pki)
#:use-module (guix config) #:use-module (guix config)
#:use-module (guix base32) #:use-module (guix base32)