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.gn-latest-20200428
@@ -63,9 +63,6 @@ MODULES = \ | |||
guix/base64.scm \ | |||
guix/cpio.scm \ | |||
guix/records.scm \ | |||
guix/gcrypt.scm \ | |||
guix/hash.scm \ | |||
guix/pk-crypto.scm \ | |||
guix/pki.scm \ | |||
guix/progress.scm \ | |||
guix/combinators.scm \ | |||
@@ -331,8 +328,6 @@ SCM_TESTS = \ | |||
tests/base32.scm \ | |||
tests/base64.scm \ | |||
tests/cpio.scm \ | |||
tests/hash.scm \ | |||
tests/pk-crypto.scm \ | |||
tests/pki.scm \ | |||
tests/print.scm \ | |||
tests/sets.scm \ | |||
@@ -21,7 +21,7 @@ Guix is based on the [[https://nixos.org/nix/][Nix]] package manager. | |||
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://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.gnutls.org][GnuTLS]] compiled with guile support enabled | |||
- [[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: | |||
- [[https://gnupg.org/][GNU libgcrypt]] | |||
- [[https://sqlite.org/][SQLite 3]] | |||
- [[https://gcc.gnu.org][GCC's g++]] | |||
- optionally [[http://www.bzip.org][libbz2]] | |||
@@ -22,6 +22,7 @@ | |||
#:use-module (guix ui) | |||
#:use-module (guix config) | |||
#:use-module (guix modules) | |||
#:use-module (guix build-system gnu) | |||
#:use-module (srfi srfi-1) | |||
#:use-module (srfi srfi-19) | |||
#:use-module (rnrs io ports) | |||
@@ -72,7 +73,7 @@ | |||
(variables rest ...)))))) | |||
(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-version "0") | |||
(bug-report-address "bug-guix@gnu.org") | |||
@@ -92,7 +93,6 @@ | |||
%state-directory | |||
%store-database-directory | |||
%config-directory | |||
%libgcrypt | |||
%libz | |||
%gzip | |||
%bzip2 | |||
@@ -137,9 +137,6 @@ | |||
(define %xz | |||
#+(and xz (file-append xz "/bin/xz"))) | |||
(define %libgcrypt | |||
#+(and libgcrypt | |||
(file-append libgcrypt "/lib/libgcrypt"))) | |||
(define %libz | |||
#+(and zlib | |||
(file-append zlib "/lib/libz"))))))) | |||
@@ -200,6 +197,44 @@ person's version identifier." | |||
;; XXX: Replace with a Git commit id. | |||
(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 | |||
#:optional (guile-version (effective-version)) | |||
#:key (pull-version 0)) | |||
@@ -212,10 +247,21 @@ person's version identifier." | |||
(('gnu _ ...) #t) | |||
(_ #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) | |||
=> ,(make-config.scm | |||
#:libgcrypt | |||
(specification->package "libgcrypt"))) | |||
=> ,(make-config.scm)) | |||
;; 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) | |||
(guix self) | |||
(guix derivations) | |||
@@ -237,13 +283,24 @@ person's version identifier." | |||
(match %load-path | |||
((front _ ...) | |||
(unless (string=? front source) ;already done? | |||
(set! %load-path (list source front))))))) | |||
;; Only load our own modules or those of Guile. | |||
(set! %load-path | |||
(list source | |||
(string-append #$guile-gcrypt | |||
"/share/guile/site/" | |||
(effective-version)) | |||
front))))))) | |||
;; Only load Guile-Gcrypt, our own modules, or those | |||
;; of Guile. | |||
(match %load-compiled-path | |||
((front _ ... sys1 sys2) | |||
(set! %load-compiled-path | |||
(list front sys1 sys2))))) | |||
(unless (string-prefix? #$guile-gcrypt front) | |||
(set! %load-compiled-path | |||
(list (string-append #$guile-gcrypt | |||
"/lib/guile/" | |||
(effective-version) | |||
"/site-ccache") | |||
front sys1 sys2)))))) | |||
(use-modules (guix store) | |||
(guix self) | |||
@@ -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.]) | |||
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. | |||
GUIX_ASSERT_GUILE_FEATURES([regex posix socket net-db threads]) | |||
@@ -213,16 +218,10 @@ AC_ARG_WITH([libgcrypt-libdir], | |||
esac]) | |||
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 | |||
xnono) | |||
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 | |||
@@ -620,7 +620,8 @@ GNU Guix depends on the following packages: | |||
@itemize | |||
@item @url{http://gnu.org/software/guile/, GNU Guile}, version 2.0.13 or | |||
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 | |||
@uref{http://gnutls.org/, GnuTLS}, specifically its Guile bindings | |||
(@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: | |||
@itemize | |||
@item @url{http://gnupg.org/, GNU libgcrypt}; | |||
@item @url{http://sqlite.org, SQLite 3}; | |||
@item @url{http://gcc.gnu.org, GCC's g++}, with support for the | |||
C++11 standard. | |||
@@ -36,7 +36,7 @@ | |||
#:use-module (guix store) | |||
#:use-module (guix build-system gnu) | |||
#:autoload (guix gnupg) (gnupg-verify*) | |||
#:autoload (guix hash) (port-sha256) | |||
#:autoload (gcrypt hash) (port-sha256) | |||
#:autoload (guix base32) (bytevector->nix-base32-string) | |||
#:use-module (srfi srfi-1) | |||
#:use-module (srfi srfi-26) | |||
@@ -213,6 +213,7 @@ | |||
;; Guile-JSON, and Guile-Git automatically. | |||
(let* ((out (assoc-ref outputs "out")) | |||
(guile (assoc-ref inputs "guile")) | |||
(gcrypt (assoc-ref inputs "guile-gcrypt")) | |||
(json (assoc-ref inputs "guile-json")) | |||
(sqlite (assoc-ref inputs "guile-sqlite3")) | |||
(git (assoc-ref inputs "guile-git")) | |||
@@ -220,7 +221,8 @@ | |||
"guile-bytestructures")) | |||
(ssh (assoc-ref inputs "guile-ssh")) | |||
(gnutls (assoc-ref inputs "gnutls")) | |||
(deps (list json sqlite gnutls git bs ssh)) | |||
(deps (list gcrypt json sqlite gnutls | |||
git bs ssh)) | |||
(effective | |||
(read-line | |||
(open-pipe* OPEN_READ | |||
@@ -279,6 +281,7 @@ | |||
'()))) | |||
(propagated-inputs | |||
`(("gnutls" ,gnutls) | |||
("guile-gcrypt" ,guile-gcrypt) | |||
("guile-json" ,guile-json) | |||
("guile-sqlite3" ,guile-sqlite3) | |||
("guile-ssh" ,guile-ssh) | |||
@@ -32,7 +32,7 @@ | |||
#:use-module (guix modules) | |||
#:use-module (guix scripts pack) | |||
#:use-module (guix utils) | |||
#:use-module (guix hash) | |||
#:use-module (gcrypt hash) | |||
#:use-module (guix base32) | |||
#:use-module ((guix self) #:select (make-config.scm)) | |||
@@ -43,7 +43,7 @@ | |||
#:use-module (gnu packages cdrom) | |||
#:use-module (gnu packages compression) | |||
#: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 bash) | |||
#:use-module (gnu packages less) | |||
@@ -124,10 +124,12 @@ | |||
(('gnu rest ...) #t) | |||
(rest #f))) | |||
(define guile-sqlite3&co | |||
;; Guile-SQLite3 and its propagated inputs. | |||
(cons guile-sqlite3 | |||
(package-transitive-propagated-inputs guile-sqlite3))) | |||
(define gcrypt-sqlite3&co | |||
;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs. | |||
(append-map (lambda (package) | |||
(cons package | |||
(package-transitive-propagated-inputs package))) | |||
(list guile-gcrypt guile-sqlite3))) | |||
(define* (expression->derivation-in-linux-vm name exp | |||
#: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 | |||
pairs, as for `derivation'. The files containing the reference graphs are | |||
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 | |||
(program-file "builder-in-linux-vm" exp)) | |||
@@ -195,12 +193,14 @@ made available under the /xchg CIFS share." | |||
(define builder | |||
;; Code that launches the VM that evaluates EXP. | |||
(with-extensions guile-sqlite3&co | |||
(with-extensions gcrypt-sqlite3&co | |||
(with-imported-modules `(,@(source-module-closure | |||
'((guix build utils) | |||
(gnu build vm)) | |||
#:select? not-config?) | |||
((guix config) => ,config)) | |||
;; For consumption by (gnu store database). | |||
((guix config) => ,(make-config.scm))) | |||
#~(begin | |||
(use-modules (guix build utils) | |||
(gnu build vm)) | |||
@@ -255,9 +255,6 @@ made available under the /xchg CIFS share." | |||
"Return a bootable, stand-alone iso9660 image. | |||
INPUTS is a list of inputs (as for packages)." | |||
(define config | |||
(make-config.scm #:libgcrypt libgcrypt)) | |||
(define schema | |||
(and register-closures? | |||
(local-file (search-path %load-path | |||
@@ -265,12 +262,12 @@ INPUTS is a list of inputs (as for packages)." | |||
(expression->derivation-in-linux-vm | |||
name | |||
(with-extensions guile-sqlite3&co | |||
(with-extensions gcrypt-sqlite3&co | |||
(with-imported-modules `(,@(source-module-closure '((gnu build vm) | |||
(guix store database) | |||
(guix build utils)) | |||
#:select? not-config?) | |||
((guix config) => ,config)) | |||
((guix config) => ,(make-config.scm))) | |||
#~(begin | |||
(use-modules (gnu build vm) | |||
(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, | |||
register INPUTS in the store database of the image so that Guix can be used in | |||
the image." | |||
(define config | |||
(make-config.scm #:libgcrypt libgcrypt)) | |||
(define schema | |||
(and register-closures? | |||
(local-file (search-path %load-path | |||
@@ -357,13 +351,13 @@ the image." | |||
(expression->derivation-in-linux-vm | |||
name | |||
(with-extensions guile-sqlite3&co | |||
(with-extensions gcrypt-sqlite3&co | |||
(with-imported-modules `(,@(source-module-closure '((gnu build vm) | |||
(gnu build bootloader) | |||
(guix store database) | |||
(guix build utils)) | |||
#:select? not-config?) | |||
((guix config) => ,config)) | |||
((guix config) => ,(make-config.scm))) | |||
#~(begin | |||
(use-modules (gnu build bootloader) | |||
(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 | |||
image just contains a web server that is started by the Shepherd), then you | |||
should set REGISTER-CLOSURES? to #f." | |||
(define config | |||
;; (guix config) module for consumption by (guix gcrypt). | |||
(make-config.scm #:libgcrypt libgcrypt)) | |||
(define schema | |||
(and register-closures? | |||
(local-file (search-path %load-path | |||
@@ -475,8 +465,8 @@ should set REGISTER-CLOSURES? to #f." | |||
(name -> (string-append name ".tar.gz")) | |||
(graph -> "system-graph")) | |||
(define build | |||
(with-extensions (cons guile-json ;for (guix docker) | |||
guile-sqlite3&co) ;for (guix store database) | |||
(with-extensions (cons guile-json ;for (guix docker) | |||
gcrypt-sqlite3&co) ;for (guix store database) | |||
(with-imported-modules `(,@(source-module-closure | |||
'((guix docker) | |||
(guix store database) | |||
@@ -484,7 +474,7 @@ should set REGISTER-CLOSURES? to #f." | |||
(guix build store-copy) | |||
(gnu build vm)) | |||
#:select? not-config?) | |||
((guix config) => ,config)) | |||
((guix config) => ,(make-config.scm))) | |||
#~(begin | |||
(use-modules (guix docker) | |||
(guix build utils) | |||
@@ -35,7 +35,7 @@ | |||
#:use-module (guix memoization) | |||
#:use-module (guix combinators) | |||
#:use-module (guix monads) | |||
#:use-module (guix hash) | |||
#:use-module (gcrypt hash) | |||
#:use-module (guix base32) | |||
#:use-module (guix records) | |||
#:use-module (guix sets) | |||
@@ -19,7 +19,7 @@ | |||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |||
(define-module (guix docker) | |||
#:use-module (guix hash) | |||
#:use-module (gcrypt hash) | |||
#:use-module (guix base16) | |||
#:use-module ((guix build utils) | |||
#:select (mkdir-p | |||
@@ -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 |
@@ -21,7 +21,7 @@ | |||
#:use-module (git) | |||
#:use-module (git object) | |||
#:use-module (guix base32) | |||
#:use-module (guix hash) | |||
#:use-module (gcrypt hash) | |||
#:use-module ((guix build utils) #:select (mkdir-p)) | |||
#:use-module (guix store) | |||
#:use-module (guix utils) | |||
@@ -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 |
@@ -34,7 +34,7 @@ | |||
#:use-module (guix ui) | |||
#:use-module (guix utils) | |||
#:use-module (guix base64) | |||
#:autoload (guix hash) (sha256) | |||
#:autoload (gcrypt hash) (sha256) | |||
#:use-module ((guix build utils) | |||
#:select (mkdir-p dump-port)) | |||
#:use-module ((guix build download) | |||
@@ -27,7 +27,7 @@ | |||
#:use-module (srfi srfi-1) | |||
#:use-module (srfi srfi-26) | |||
#:use-module (json) | |||
#:use-module (guix hash) | |||
#:use-module (gcrypt hash) | |||
#:use-module (guix store) | |||
#:use-module (guix utils) | |||
#:use-module (guix base32) | |||
@@ -29,7 +29,7 @@ | |||
#:use-module (web uri) | |||
#:use-module (guix memoization) | |||
#:use-module (guix http-client) | |||
#:use-module (guix hash) | |||
#:use-module (gcrypt hash) | |||
#:use-module (guix store) | |||
#:use-module (guix base32) | |||
#:use-module ((guix download) #:select (download-to-store)) | |||
@@ -20,7 +20,7 @@ | |||
#:use-module (guix base32) | |||
#:use-module (guix build-system cargo) | |||
#:use-module ((guix download) #:prefix download:) | |||
#:use-module (guix hash) | |||
#:use-module (gcrypt hash) | |||
#:use-module (guix http-client) | |||
#:use-module (guix import json) | |||
#:use-module (guix import utils) | |||
@@ -32,7 +32,7 @@ | |||
#:use-module (guix http-client) | |||
#:use-module (guix store) | |||
#:use-module (guix ui) | |||
#:use-module (guix hash) | |||
#:use-module (gcrypt hash) | |||
#:use-module (guix base32) | |||
#:use-module (guix upstream) | |||
#:use-module (guix packages) | |||
@@ -21,7 +21,7 @@ | |||
#:use-module (guix import utils) | |||
#:use-module (guix utils) | |||
#:use-module (guix store) | |||
#:use-module (guix hash) | |||
#:use-module (gcrypt hash) | |||
#:use-module (guix base32) | |||
#:use-module (guix upstream) | |||
#:use-module (srfi srfi-1) | |||
@@ -33,7 +33,7 @@ | |||
#:use-module ((guix import utils) #:select (factorize-uri recursive-import)) | |||
#:use-module (guix import cabal) | |||
#:use-module (guix store) | |||
#:use-module (guix hash) | |||
#:use-module (gcrypt hash) | |||
#:use-module (guix base32) | |||
#:use-module (guix memoization) | |||
#:use-module (guix upstream) | |||
@@ -26,7 +26,7 @@ | |||
#:use-module (srfi srfi-34) | |||
#:use-module (web uri) | |||
#:use-module (guix http-client) | |||
#:use-module (guix hash) | |||
#:use-module (gcrypt hash) | |||
#:use-module (guix memoization) | |||
#:use-module (guix store) | |||
#:use-module (guix base32) | |||
@@ -23,7 +23,7 @@ | |||
(define-module (guix import utils) | |||
#:use-module (guix base32) | |||
#:use-module ((guix build download) #:prefix build:) | |||
#:use-module (guix hash) | |||
#:use-module (gcrypt hash) | |||
#:use-module (guix http-client) | |||
#:use-module ((guix licenses) #:prefix license:) | |||
#:use-module (guix utils) | |||
@@ -25,9 +25,9 @@ | |||
#:use-module (guix store) | |||
#:use-module (guix store database) | |||
#:use-module (guix ui) ; for '_' | |||
#:use-module (guix hash) | |||
#:use-module (gcrypt hash) | |||
#:use-module (guix pki) | |||
#:use-module (guix pk-crypto) | |||
#:use-module (gcrypt pk-crypto) | |||
#:use-module (srfi srfi-1) | |||
#:use-module (srfi srfi-11) | |||
#:use-module (srfi srfi-26) | |||
@@ -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 |
@@ -18,7 +18,7 @@ | |||
(define-module (guix pki) | |||
#: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 build utils) #:select (mkdir-p)) | |||
#:use-module (ice-9 match) | |||
@@ -29,7 +29,7 @@ | |||
#:use-module (guix monads) | |||
#:use-module (guix ui) | |||
#:use-module (guix pki) | |||
#:use-module (guix pk-crypto) | |||
#:use-module (gcrypt pk-crypto) | |||
#:use-module (guix scripts) | |||
#:use-module (guix scripts build) | |||
#:use-module (gnu packages) | |||
@@ -19,7 +19,7 @@ | |||
(define-module (guix scripts authenticate) | |||
#:use-module (guix config) | |||
#:use-module (guix base16) | |||
#:use-module (guix pk-crypto) | |||
#:use-module (gcrypt pk-crypto) | |||
#:use-module (guix pki) | |||
#:use-module (guix ui) | |||
#:use-module (ice-9 binary-ports) | |||
@@ -20,7 +20,7 @@ | |||
#:use-module (guix ui) | |||
#:use-module (guix scripts) | |||
#:use-module (guix store) | |||
#:use-module (guix hash) | |||
#:use-module (gcrypt hash) | |||
#:use-module (guix base16) | |||
#:use-module (guix base32) | |||
#:use-module ((guix download) #:hide (url-fetch)) | |||
@@ -20,7 +20,7 @@ | |||
(define-module (guix scripts hash) | |||
#:use-module (guix base32) | |||
#:use-module (guix hash) | |||
#:use-module (gcrypt hash) | |||
#:use-module (guix serialization) | |||
#:use-module (guix ui) | |||
#:use-module (guix scripts) | |||
@@ -44,7 +44,7 @@ | |||
`((format . ,bytevector->nix-base32-string))) | |||
(define (show-help) | |||
(display (G_ "Usage: guix hash [OPTION] FILE | |||
(display (G_ "Usage: gcrypt hash [OPTION] FILE | |||
Return the cryptographic hash of FILE. | |||
Supported formats: 'nix-base32' (default), 'base32', and 'base16' ('hex' | |||
@@ -93,7 +93,7 @@ and 'hexadecimal' can be used as well).\n")) | |||
(exit 0))) | |||
(option '(#\V "version") #f #f | |||
(lambda args | |||
(show-version-and-exit "guix hash"))))) | |||
(show-version-and-exit "gcrypt hash"))))) | |||
@@ -41,7 +41,7 @@ | |||
#:use-module (gnu packages guile) | |||
#:use-module (gnu packages base) | |||
#: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) | |||
#:use-module (srfi srfi-1) | |||
#:use-module (srfi srfi-9) | |||
@@ -95,10 +95,12 @@ found." | |||
(('gnu _ ...) #t) | |||
(_ #f))) | |||
(define guile-sqlite3&co | |||
;; Guile-SQLite3 and its propagated inputs. | |||
(cons guile-sqlite3 | |||
(package-transitive-propagated-inputs guile-sqlite3))) | |||
(define gcrypt-sqlite3&co | |||
;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs. | |||
(append-map (lambda (package) | |||
(cons package | |||
(package-transitive-propagated-inputs package))) | |||
(list guile-gcrypt guile-sqlite3))) | |||
(define* (self-contained-tarball name profile | |||
#:key target | |||
@@ -124,16 +126,14 @@ added to the pack." | |||
"guix/store/schema.sql")))) | |||
(define build | |||
(with-imported-modules `(((guix config) | |||
=> ,(make-config.scm | |||
#:libgcrypt libgcrypt)) | |||
(with-imported-modules `(((guix config) => ,(make-config.scm)) | |||
,@(source-module-closure | |||
`((guix build utils) | |||
(guix build union) | |||
(guix build store-copy) | |||
(gnu build install)) | |||
#:select? not-config?)) | |||
(with-extensions guile-sqlite3&co | |||
(with-extensions gcrypt-sqlite3&co | |||
#~(begin | |||
(use-modules (guix build utils) | |||
((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 | |||
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 | |||
(with-imported-modules `(((guix config) | |||
=> ,(make-config.scm | |||
#:libgcrypt libgcrypt)) | |||
(with-imported-modules `(((guix config) => ,(make-config.scm)) | |||
,@(source-module-closure | |||
'((guix build utils) | |||
(guix build store-copy) | |||
(gnu build install)) | |||
#:select? not-config?)) | |||
(with-extensions guile-sqlite3&co | |||
(with-extensions gcrypt-sqlite3&co | |||
#~(begin | |||
(use-modules (guix build utils) | |||
(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." | |||
(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 | |||
;; Guile-JSON is required by (guix docker). | |||
(with-extensions (list json) | |||
(with-imported-modules `(,@(source-module-closure '((guix docker) | |||
(guix build store-copy)) | |||
#:select? not-config?) | |||
((guix config) => ,config)) | |||
;; Guile-JSON and Guile-Gcrypt are required by (guix docker). | |||
(with-extensions (list guile-json guile-gcrypt) | |||
(with-imported-modules (source-module-closure '((guix docker) | |||
(guix build store-copy)) | |||
#:select? not-config?) | |||
#~(begin | |||
(use-modules (guix docker) (srfi srfi-19) (guix build store-copy)) | |||
@@ -44,9 +44,9 @@ | |||
#:use-module (guix base64) | |||
#:use-module (guix config) | |||
#:use-module (guix derivations) | |||
#:use-module (guix hash) | |||
#:use-module (gcrypt hash) | |||
#:use-module (guix pki) | |||
#:use-module (guix pk-crypto) | |||
#:use-module (gcrypt pk-crypto) | |||
#:use-module (guix workers) | |||
#:use-module (guix store) | |||
#:use-module ((guix serialization) #:select (write-file)) | |||
@@ -23,7 +23,7 @@ | |||
(define-module (guix scripts refresh) | |||
#:use-module (guix ui) | |||
#:use-module (guix hash) | |||
#:use-module (gcrypt hash) | |||
#:use-module (guix scripts) | |||
#:use-module (guix store) | |||
#:use-module (guix utils) | |||
@@ -26,11 +26,11 @@ | |||
#:use-module (guix config) | |||
#:use-module (guix records) | |||
#:use-module ((guix serialization) #:select (restore-file)) | |||
#:use-module (guix hash) | |||
#:use-module (gcrypt hash) | |||
#:use-module (guix base32) | |||
#:use-module (guix base64) | |||
#:use-module (guix cache) | |||
#:use-module (guix pk-crypto) | |||
#:use-module (gcrypt pk-crypto) | |||
#:use-module (guix pki) | |||
#:use-module ((guix build utils) #:select (mkdir-p dump-port)) | |||
#:use-module ((guix build download) | |||
@@ -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-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) 'gnutls)) | |||
("libgcrypt" (ref '(gnu packages gnupg) 'libgcrypt)) | |||
("zlib" (ref '(gnu packages compression) 'zlib)) | |||
("gzip" (ref '(gnu packages compression) 'gzip)) | |||
("bzip2" (ref '(gnu packages compression) 'bzip2)) | |||
@@ -454,7 +454,6 @@ assumed to be part of MODULES." | |||
(name (string-append "guix-" version)) | |||
(guile-version (effective-version)) | |||
(guile-for-build (guile-for-build guile-version)) | |||
(libgcrypt (specification->package "libgcrypt")) | |||
(zlib (specification->package "zlib")) | |||
(gzip (specification->package "gzip")) | |||
(bzip2 (specification->package "bzip2")) | |||
@@ -481,6 +480,10 @@ assumed to be part of MODULES." | |||
"guile-sqlite3" | |||
"guile2.0-sqlite3")) | |||
(define guile-gcrypt | |||
(package-for-guile guile-version | |||
"guile-gcrypt")) | |||
(define gnutls | |||
(package-for-guile guile-version | |||
"gnutls" "guile2.0-gnutls")) | |||
@@ -489,7 +492,7 @@ assumed to be part of MODULES." | |||
(match (append-map (lambda (package) | |||
(cons (list "x" package) | |||
(package-transitive-propagated-inputs package))) | |||
(list gnutls guile-git guile-json | |||
(list guile-gcrypt gnutls guile-git guile-json | |||
guile-ssh guile-sqlite3)) | |||
(((labels packages _ ...) ...) | |||
packages))) | |||
@@ -513,10 +516,7 @@ assumed to be part of MODULES." | |||
;; rebuilt when the version changes, which in turn means we | |||
;; can have substitutes for it. | |||
#:extra-modules | |||
`(((guix config) | |||
=> ,(make-config.scm #:libgcrypt | |||
(specification->package | |||
"libgcrypt")))) | |||
`(((guix config) => ,(make-config.scm))) | |||
;; (guix man-db) is needed at build-time by (guix profiles) | |||
;; 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" | |||
,(local-file "../guix/store/schema.sql"))) | |||
#:extensions (list guile-gcrypt) | |||
#:guile-for-build guile-for-build)) | |||
(define *extra-modules* | |||
@@ -600,8 +601,7 @@ assumed to be part of MODULES." | |||
'() | |||
#:extra-modules | |||
`(((guix config) | |||
=> ,(make-config.scm #:libgcrypt libgcrypt | |||
#:zlib zlib | |||
=> ,(make-config.scm #:zlib zlib | |||
#:gzip gzip | |||
#:bzip2 bzip2 | |||
#:xz xz | |||
@@ -684,7 +684,7 @@ assumed to be part of MODULES." | |||
(define %dependency-variables | |||
;; (guix config) variables corresponding to dependencies. | |||
'(%libgcrypt %libz %xz %gzip %bzip2)) | |||
'(%libz %xz %gzip %bzip2)) | |||
(define %persona-variables | |||
;; (guix config) variables that define Guix's persona. | |||
@@ -703,7 +703,7 @@ assumed to be part of MODULES." | |||
(variables rest ...)))))) | |||
(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-version "0") | |||
(bug-report-address "bug-guix@gnu.org") | |||
@@ -723,7 +723,6 @@ assumed to be part of MODULES." | |||
%state-directory | |||
%store-database-directory | |||
%config-directory | |||
%libgcrypt | |||
%libz | |||
%gzip | |||
%bzip2 | |||
@@ -766,9 +765,6 @@ assumed to be part of MODULES." | |||
(define %xz | |||
#+(and xz (file-append xz "/bin/xz"))) | |||
(define %libgcrypt | |||
#+(and libgcrypt | |||
(file-append libgcrypt "/lib/libgcrypt"))) | |||
(define %libz | |||
#+(and zlib | |||
(file-append zlib "/lib/libz")))) | |||
@@ -25,7 +25,7 @@ | |||
#:use-module (guix monads) | |||
#:use-module (guix base16) | |||
#:use-module (guix base32) | |||
#:use-module (guix hash) | |||
#:use-module (gcrypt hash) | |||
#:use-module (guix profiling) | |||
#:autoload (guix build syscalls) (terminal-columns) | |||
#:use-module (rnrs bytevectors) | |||
@@ -21,7 +21,7 @@ | |||
;;; timestamps, deduplicating, etc. | |||
(define-module (guix store deduplication) | |||
#:use-module (guix hash) | |||
#:use-module (gcrypt hash) | |||
#:use-module (guix build utils) | |||
#:use-module (guix base16) | |||
#:use-module (srfi srfi-11) | |||
@@ -22,7 +22,7 @@ | |||
#:use-module (guix packages) | |||
#:use-module (guix base32) | |||
#:use-module (guix serialization) | |||
#:use-module (guix hash) | |||
#:use-module (gcrypt hash) | |||
#:use-module (guix build-system gnu) | |||
#:use-module (gnu packages bootstrap) | |||
#:use-module (srfi srfi-34) | |||
@@ -18,24 +18,6 @@ dnl | |||
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 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 | |||
dnl Determine the Guix host system type, and store it in the | |||
@@ -17,7 +17,7 @@ | |||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |||
(define-module (test-base32) | |||
#:use-module (guix hash) | |||
#:use-module (gcrypt hash) | |||
#:use-module (guix base32) | |||
#:use-module (guix utils) | |||
#:use-module (srfi srfi-1) | |||
@@ -25,7 +25,7 @@ | |||
#:use-module (guix utils) | |||
#:use-module (guix base32) | |||
#:use-module (guix derivations) | |||
#:use-module (guix hash) | |||
#:use-module (gcrypt hash) | |||
#:use-module (guix tests) | |||
#:use-module ((guix packages) | |||
#:select (package-derivation package-native-search-paths)) | |||
@@ -18,7 +18,7 @@ | |||
(define-module (test-challenge) | |||
#:use-module (guix tests) | |||
#:use-module (guix hash) | |||
#:use-module (gcrypt hash) | |||
#:use-module (guix store) | |||
#:use-module (guix monads) | |||
#:use-module (guix derivations) | |||
@@ -20,7 +20,7 @@ | |||
(define-module (test-cpan) | |||
#:use-module (guix import cpan) | |||
#:use-module (guix base32) | |||
#:use-module (guix hash) | |||
#:use-module (gcrypt hash) | |||
#:use-module (guix tests) | |||
#:use-module (guix grafts) | |||
#:use-module (srfi srfi-64) | |||
@@ -21,7 +21,7 @@ | |||
#:use-module (guix import crate) | |||
#:use-module (guix base32) | |||
#:use-module (guix build-system cargo) | |||
#:use-module (guix hash) | |||
#:use-module (gcrypt hash) | |||
#:use-module (guix tests) | |||
#:use-module (ice-9 iconv) | |||
#:use-module (ice-9 match) | |||
@@ -23,7 +23,7 @@ | |||
#:use-module (guix grafts) | |||
#:use-module (guix store) | |||
#:use-module (guix utils) | |||
#:use-module (guix hash) | |||
#:use-module (gcrypt hash) | |||
#:use-module (guix base32) | |||
#:use-module (guix tests) | |||
#:use-module (guix tests http) | |||
@@ -21,7 +21,7 @@ | |||
(define-module (test-gem) | |||
#:use-module (guix import gem) | |||
#:use-module (guix base32) | |||
#:use-module (guix hash) | |||
#:use-module (gcrypt hash) | |||
#:use-module (guix tests) | |||
#:use-module ((guix build utils) #:select (delete-file-recursively)) | |||
#:use-module (srfi srfi-41) | |||
@@ -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) |
@@ -21,7 +21,7 @@ | |||
#:use-module (guix nar) | |||
#:use-module (guix serialization) | |||
#:use-module (guix store) | |||
#:use-module ((guix hash) | |||
#:use-module ((gcrypt hash) | |||
#:select (open-sha256-port open-sha256-input-port)) | |||
#:use-module ((guix packages) | |||
#:select (base32)) | |||
@@ -19,7 +19,7 @@ | |||
(define-module (test-opam) | |||
#:use-module (guix import opam) | |||
#:use-module (guix base32) | |||
#:use-module (guix hash) | |||
#:use-module (gcrypt hash) | |||
#:use-module (guix tests) | |||
#:use-module ((guix build utils) #:select (delete-file-recursively mkdir-p which)) | |||
#:use-module (srfi srfi-64) | |||
@@ -28,7 +28,7 @@ | |||
#:renamer (lambda (name) | |||
(cond ((eq? name 'location) 'make-location) | |||
(else name)))) | |||
#:use-module (guix hash) | |||
#:use-module (gcrypt hash) | |||
#:use-module (guix derivations) | |||
#:use-module (guix packages) | |||
#:use-module (guix grafts) | |||
@@ -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)) | |||