* guix/scripts/substitute-binary.scm (<narinfo>): Add the 'signature' and 'contents' fields. (narinfo-signature->canonical-sexp): New function. (narinfo-maker): Add the 'signature' argument and use it. (assert-valid-signature): New function. (read-narinfo): Support the Signature field. (write-narinfo): Use 'narinfo-contents'. (%allow-unauthenticated-substitutes?): New variable. * guix/base64.scm, tests/base64.scm, tests/substitute-binary.scm: New files. * Makefile.am (SCM_TESTS): Add tests/base64.scm and tests/substitute-binary.scm. (MODULES): Add guix/base64.scm. * test-env.in: Set 'GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES'.gn-latest-20200428
@@ -28,6 +28,7 @@ include gnu-system.am | |||
MODULES = \ | |||
guix/base32.scm \ | |||
guix/base64.scm \ | |||
guix/records.scm \ | |||
guix/hash.scm \ | |||
guix/pk-crypto.scm \ | |||
@@ -122,9 +123,11 @@ clean-go: | |||
SCM_TESTS = \ | |||
tests/base32.scm \ | |||
tests/base64.scm \ | |||
tests/hash.scm \ | |||
tests/pk-crypto.scm \ | |||
tests/pki.scm \ | |||
tests/substitute-binary.scm \ | |||
tests/builders.scm \ | |||
tests/derivations.scm \ | |||
tests/ui.scm \ | |||
@@ -0,0 +1,212 @@ | |||
;; -*- mode: scheme; coding: utf-8 -*- | |||
;; | |||
;; This module was renamed from (weinholt text base64 (1 0 20100612)) to | |||
;; (guix base64) by Nikita Karetnikov <nikita@karetnikov.org> on | |||
;; February 12, 2014. | |||
;; | |||
;; Copyright © 2009, 2010 Göran Weinholt <goran@weinholt.se> | |||
;; | |||
;; This program 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. | |||
;; | |||
;; This program 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 this program. If not, see <http://www.gnu.org/licenses/>. | |||
#!r6rs | |||
;; RFC 4648 Base-N Encodings | |||
(library (guix base64) | |||
(export base64-encode | |||
base64-decode | |||
base64-alphabet | |||
base64url-alphabet | |||
get-delimited-base64 | |||
put-delimited-base64) | |||
(import (rnrs) | |||
(only (srfi :13 strings) | |||
string-index | |||
string-prefix? string-suffix? | |||
string-concatenate string-trim-both)) | |||
(define base64-alphabet | |||
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/") | |||
(define base64url-alphabet | |||
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_") | |||
(define base64-encode | |||
(case-lambda | |||
;; Simple interface. Returns a string containing the canonical | |||
;; base64 representation of the given bytevector. | |||
((bv) | |||
(base64-encode bv 0 (bytevector-length bv) #f #f base64-alphabet #f)) | |||
((bv start) | |||
(base64-encode bv start (bytevector-length bv) #f #f base64-alphabet #f)) | |||
((bv start end) | |||
(base64-encode bv start end #f #f base64-alphabet #f)) | |||
((bv start end line-length) | |||
(base64-encode bv start end line-length #f base64-alphabet #f)) | |||
((bv start end line-length no-padding) | |||
(base64-encode bv start end line-length no-padding base64-alphabet #f)) | |||
((bv start end line-length no-padding alphabet) | |||
(base64-encode bv start end line-length no-padding alphabet #f)) | |||
;; Base64 encodes the bytes [start,end[ in the given bytevector. | |||
;; Lines are limited to line-length characters (unless #f), | |||
;; which must be a multiple of four. To omit the padding | |||
;; characters (#\=) set no-padding to a true value. If port is | |||
;; #f, returns a string. | |||
((bv start end line-length no-padding alphabet port) | |||
(assert (or (not line-length) (zero? (mod line-length 4)))) | |||
(let-values (((p extract) (if port | |||
(values port (lambda () (values))) | |||
(open-string-output-port)))) | |||
(letrec ((put (if line-length | |||
(let ((chars 0)) | |||
(lambda (p c) | |||
(when (fx=? chars line-length) | |||
(set! chars 0) | |||
(put-char p #\linefeed)) | |||
(set! chars (fx+ chars 1)) | |||
(put-char p c))) | |||
put-char))) | |||
(let lp ((i start)) | |||
(cond ((= i end)) | |||
((<= (+ i 3) end) | |||
(let ((x (bytevector-uint-ref bv i (endianness big) 3))) | |||
(put p (string-ref alphabet (fxbit-field x 18 24))) | |||
(put p (string-ref alphabet (fxbit-field x 12 18))) | |||
(put p (string-ref alphabet (fxbit-field x 6 12))) | |||
(put p (string-ref alphabet (fxbit-field x 0 6))) | |||
(lp (+ i 3)))) | |||
((<= (+ i 2) end) | |||
(let ((x (fxarithmetic-shift-left (bytevector-u16-ref bv i (endianness big)) 8))) | |||
(put p (string-ref alphabet (fxbit-field x 18 24))) | |||
(put p (string-ref alphabet (fxbit-field x 12 18))) | |||
(put p (string-ref alphabet (fxbit-field x 6 12))) | |||
(unless no-padding | |||
(put p #\=)))) | |||
(else | |||
(let ((x (fxarithmetic-shift-left (bytevector-u8-ref bv i) 16))) | |||
(put p (string-ref alphabet (fxbit-field x 18 24))) | |||
(put p (string-ref alphabet (fxbit-field x 12 18))) | |||
(unless no-padding | |||
(put p #\=) | |||
(put p #\=))))))) | |||
(extract))))) | |||
;; Decodes a base64 string. The string must contain only pure | |||
;; unpadded base64 data. | |||
(define base64-decode | |||
(case-lambda | |||
((str) | |||
(base64-decode str base64-alphabet #f)) | |||
((str alphabet) | |||
(base64-decode str alphabet #f)) | |||
((str alphabet port) | |||
(unless (zero? (mod (string-length str) 4)) | |||
(error 'base64-decode | |||
"input string must be a multiple of four characters")) | |||
(let-values (((p extract) (if port | |||
(values port (lambda () (values))) | |||
(open-bytevector-output-port)))) | |||
(do ((i 0 (+ i 4))) | |||
((= i (string-length str)) | |||
(extract)) | |||
(let ((c1 (string-ref str i)) | |||
(c2 (string-ref str (+ i 1))) | |||
(c3 (string-ref str (+ i 2))) | |||
(c4 (string-ref str (+ i 3)))) | |||
;; TODO: be more clever than string-index | |||
(let ((i1 (string-index alphabet c1)) | |||
(i2 (string-index alphabet c2)) | |||
(i3 (string-index alphabet c3)) | |||
(i4 (string-index alphabet c4))) | |||
(cond ((and i1 i2 i3 i4) | |||
(let ((x (fxior (fxarithmetic-shift-left i1 18) | |||
(fxarithmetic-shift-left i2 12) | |||
(fxarithmetic-shift-left i3 6) | |||
i4))) | |||
(put-u8 p (fxbit-field x 16 24)) | |||
(put-u8 p (fxbit-field x 8 16)) | |||
(put-u8 p (fxbit-field x 0 8)))) | |||
((and i1 i2 i3 (char=? c4 #\=) | |||
(= i (- (string-length str) 4))) | |||
(let ((x (fxior (fxarithmetic-shift-left i1 18) | |||
(fxarithmetic-shift-left i2 12) | |||
(fxarithmetic-shift-left i3 6)))) | |||
(put-u8 p (fxbit-field x 16 24)) | |||
(put-u8 p (fxbit-field x 8 16)))) | |||
((and i1 i2 (char=? c3 #\=) (char=? c4 #\=) | |||
(= i (- (string-length str) 4))) | |||
(let ((x (fxior (fxarithmetic-shift-left i1 18) | |||
(fxarithmetic-shift-left i2 12)))) | |||
(put-u8 p (fxbit-field x 16 24)))) | |||
(else | |||
(error 'base64-decode "invalid input" | |||
(list c1 c2 c3 c4))))))))))) | |||
(define (get-line-comp f port) | |||
(if (port-eof? port) | |||
(eof-object) | |||
(f (get-line port)))) | |||
;; Reads the common -----BEGIN/END type----- delimited format from | |||
;; the given port. Returns two values: a string with the type and a | |||
;; bytevector containing the base64 decoded data. The second value | |||
;; is the eof object if there is an eof before the BEGIN delimiter. | |||
(define (get-delimited-base64 port) | |||
(define (get-first-data-line port) | |||
;; Some MIME data has header fields in the same format as mail | |||
;; or http. These are ignored. | |||
(let ((line (get-line-comp string-trim-both port))) | |||
(cond ((eof-object? line) line) | |||
((string-index line #\:) | |||
(let lp () ;read until empty line | |||
(let ((line (get-line-comp string-trim-both port))) | |||
(if (string=? line "") | |||
(get-line-comp string-trim-both port) | |||
(lp))))) | |||
(else line)))) | |||
(let ((line (get-line-comp string-trim-both port))) | |||
(cond ((eof-object? line) | |||
(values "" (eof-object))) | |||
((string=? line "") | |||
(get-delimited-base64 port)) | |||
((and (string-prefix? "-----BEGIN " line) | |||
(string-suffix? "-----" line)) | |||
(let* ((type (substring line 11 (- (string-length line) 5))) | |||
(endline (string-append "-----END " type "-----"))) | |||
(let-values (((outp extract) (open-bytevector-output-port))) | |||
(let lp ((line (get-first-data-line port))) | |||
(cond ((eof-object? line) | |||
(error 'get-delimited-base64 | |||
"unexpected end of file")) | |||
((string-prefix? "-" line) | |||
(unless (string=? line endline) | |||
(error 'get-delimited-base64 | |||
"bad end delimiter" type line)) | |||
(values type (extract))) | |||
(else | |||
(unless (and (= (string-length line) 5) | |||
(string-prefix? "=" line)) ;Skip Radix-64 checksum | |||
(base64-decode line base64-alphabet outp)) | |||
(lp (get-line-comp string-trim-both port)))))))) | |||
(else ;skip garbage (like in openssl x509 -in foo -text output). | |||
(get-delimited-base64 port))))) | |||
(define put-delimited-base64 | |||
(case-lambda | |||
((port type bv line-length) | |||
(display (string-append "-----BEGIN " type "-----\n") port) | |||
(base64-encode bv 0 (bytevector-length bv) | |||
line-length #f base64-alphabet port) | |||
(display (string-append "\n-----END " type "-----\n") port)) | |||
((port type bv) | |||
(put-delimited-base64 port type bv 76))))) |
@@ -1,5 +1,6 @@ | |||
;;; GNU Guix --- Functional package management for GNU | |||
;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> | |||
;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org> | |||
;;; | |||
;;; This file is part of GNU Guix. | |||
;;; | |||
@@ -23,6 +24,10 @@ | |||
#:use-module (guix config) | |||
#:use-module (guix records) | |||
#:use-module (guix nar) | |||
#:use-module (guix hash) | |||
#:use-module (guix base64) | |||
#:use-module (guix pk-crypto) | |||
#:use-module (guix pki) | |||
#:use-module ((guix build utils) #:select (mkdir-p)) | |||
#:use-module ((guix build download) | |||
#:select (progress-proc uri-abbreviation)) | |||
@@ -33,15 +38,21 @@ | |||
#:use-module (ice-9 format) | |||
#:use-module (ice-9 ftw) | |||
#:use-module (ice-9 binary-ports) | |||
#:use-module (rnrs io ports) | |||
#:use-module (rnrs bytevectors) | |||
#:use-module (srfi srfi-1) | |||
#:use-module (srfi srfi-9) | |||
#:use-module (srfi srfi-11) | |||
#:use-module (srfi srfi-19) | |||
#:use-module (srfi srfi-26) | |||
#:use-module (srfi srfi-34) | |||
#:use-module (srfi srfi-35) | |||
#:use-module (web uri) | |||
#:use-module (guix http-client) | |||
#:export (guix-substitute-binary)) | |||
#:export (narinfo-signature->canonical-sexp | |||
read-narinfo | |||
write-narinfo | |||
guix-substitute-binary)) | |||
;;; Comment: | |||
;;; | |||
@@ -60,6 +71,16 @@ | |||
(cut string-append <> "/guix/substitute-binary")) | |||
(string-append %state-directory "/substitute-binary/cache"))) | |||
(define %allow-unauthenticated-substitutes? | |||
;; Whether to allow unchecked substitutes. This is useful for testing | |||
;; purposes, and should be avoided otherwise. | |||
(and (and=> (getenv "GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES") | |||
(cut string-ci=? <> "yes")) | |||
(begin | |||
(warning (_ "authentication and authorization of substitutes \ | |||
disabled!~%")) | |||
#t))) | |||
(define %narinfo-ttl | |||
;; Number of seconds during which cached narinfo lookups are considered | |||
;; valid. | |||
@@ -194,7 +215,7 @@ failure." | |||
(define-record-type <narinfo> | |||
(%make-narinfo path uri compression file-hash file-size nar-hash nar-size | |||
references deriver system) | |||
references deriver system signature contents) | |||
narinfo? | |||
(path narinfo-path) | |||
(uri narinfo-uri) | |||
@@ -205,15 +226,38 @@ failure." | |||
(nar-size narinfo-size) | |||
(references narinfo-references) | |||
(deriver narinfo-deriver) | |||
(system narinfo-system)) | |||
(define (narinfo-maker cache-url) | |||
"Return a narinfo constructor for narinfos originating from CACHE-URL." | |||
(system narinfo-system) | |||
(signature narinfo-signature) ; canonical sexp | |||
;; The original contents of a narinfo file. This field is needed because we | |||
;; want to preserve the exact textual representation for verification purposes. | |||
;; See <https://lists.gnu.org/archive/html/guix-devel/2014-02/msg00340.html> | |||
;; for more information. | |||
(contents narinfo-contents)) | |||
(define (narinfo-signature->canonical-sexp str) | |||
"Return the value of a narinfo's 'Signature' field as a canonical sexp." | |||
(match (string-split str #\;) | |||
((version _ sig) | |||
(let ((maybe-number (string->number version))) | |||
(cond ((not (number? maybe-number)) | |||
(leave (_ "signature version must be a number: ~a~%") | |||
version)) | |||
;; Currently, there are no other versions. | |||
((not (= 1 maybe-number)) | |||
(leave (_ "unsupported signature version: ~a~%") | |||
maybe-number)) | |||
(else (string->canonical-sexp | |||
(utf8->string (base64-decode sig))))))) | |||
(x | |||
(leave (_ "invalid format of the signature field: ~a~%") x)))) | |||
(define (narinfo-maker str cache-url) | |||
"Return a narinfo constructor for narinfos originating from CACHE-URL. STR | |||
must contain the original contents of a narinfo file." | |||
(lambda (path url compression file-hash file-size nar-hash nar-size | |||
references deriver system) | |||
references deriver system signature) | |||
"Return a new <narinfo> object." | |||
(%make-narinfo path | |||
;; Handle the case where URL is a relative URL. | |||
(or (string->uri url) | |||
(string->uri (string-append cache-url "/" url))) | |||
@@ -226,45 +270,81 @@ failure." | |||
(match deriver | |||
((or #f "") #f) | |||
(_ deriver)) | |||
system))) | |||
(define* (read-narinfo port #:optional url) | |||
"Read a narinfo from PORT in its standard external form. If URL is true, it | |||
must be a string used to build full URIs from relative URIs found while | |||
reading PORT." | |||
(alist->record (fields->alist port) | |||
(narinfo-maker url) | |||
'("StorePath" "URL" "Compression" | |||
"FileHash" "FileSize" "NarHash" "NarSize" | |||
"References" "Deriver" "System"))) | |||
system | |||
(narinfo-signature->canonical-sexp signature) | |||
str))) | |||
;;; XXX: The following function is nearly an exact copy of the one from | |||
;;; 'guix/nar.scm'. Factorize as soon as we know how to make the latter | |||
;;; public (see <https://lists.gnu.org/archive/html/guix-devel/2014-03/msg00097.html>). | |||
;;; Keep this one private to avoid confusion. | |||
(define* (assert-valid-signature signature hash port | |||
#:optional (acl (current-acl))) | |||
"Bail out if SIGNATURE, a string (as produced by 'canonical-sexp->string'), | |||
doesn't match HASH, a bytevector containing the expected hash for FILE." | |||
(let* ((&nar-signature-error (@@ (guix nar) &nar-signature-error)) | |||
(&nar-invalid-hash-error (@@ (guix nar) &nar-invalid-hash-error)) | |||
;; XXX: This is just to keep the errors happy; get a sensible | |||
;; filename. | |||
(file #f) | |||
(signature (catch 'gcry-error | |||
(lambda () | |||
(string->canonical-sexp signature)) | |||
(lambda (err . _) | |||
(raise (condition | |||
(&message | |||
(message "signature is not a valid \ | |||
s-expression")) | |||
(&nar-signature-error | |||
(file file) | |||
(signature signature) (port port))))))) | |||
(subject (signature-subject signature)) | |||
(data (signature-signed-data signature))) | |||
(if (and data subject) | |||
(if (authorized-key? subject acl) | |||
(if (equal? (hash-data->bytevector data) hash) | |||
(unless (valid-signature? signature) | |||
(raise (condition | |||
(&message (message "invalid signature")) | |||
(&nar-signature-error | |||
(file file) (signature signature) (port port))))) | |||
(raise (condition (&message (message "invalid hash")) | |||
(&nar-invalid-hash-error | |||
(port port) (file file) | |||
(signature signature) | |||
(expected (hash-data->bytevector data)) | |||
(actual hash))))) | |||
(raise (condition (&message (message "unauthorized public key")) | |||
(&nar-signature-error | |||
(signature signature) (file file) (port port))))) | |||
(raise (condition | |||
(&message (message "corrupt signature data")) | |||
(&nar-signature-error | |||
(signature signature) (file file) (port port))))))) | |||
(define* (read-narinfo port #:optional url (acl (current-acl))) | |||
"Read a narinfo from PORT. If URL is true, it must be a string used to | |||
build full URIs from relative URIs found while reading PORT." | |||
(let* ((str (utf8->string (get-bytevector-all port))) | |||
(rx (make-regexp "(.+)^[[:blank:]]*Signature:[[:blank:]].+$")) | |||
(res (or (regexp-exec rx str) | |||
(leave (_ "cannot find the Signature line: ~a~%") | |||
str))) | |||
(hash (sha256 (string->utf8 (match:substring res 1)))) | |||
(narinfo (alist->record (fields->alist (open-input-string str)) | |||
(narinfo-maker str url) | |||
'("StorePath" "URL" "Compression" | |||
"FileHash" "FileSize" "NarHash" "NarSize" | |||
"References" "Deriver" "System" | |||
"Signature"))) | |||
(signature (canonical-sexp->string (narinfo-signature narinfo)))) | |||
(unless %allow-unauthenticated-substitutes? | |||
(assert-valid-signature signature hash port acl)) | |||
narinfo)) | |||
(define (write-narinfo narinfo port) | |||
"Write NARINFO to PORT." | |||
(define (empty-string-if-false x) | |||
(or x "")) | |||
(define (number-or-empty-string x) | |||
(if (number? x) | |||
(number->string x) | |||
"")) | |||
(object->fields narinfo | |||
`(("StorePath" . ,narinfo-path) | |||
("URL" . ,(compose uri->string narinfo-uri)) | |||
("Compression" . ,narinfo-compression) | |||
("FileHash" . ,(compose empty-string-if-false | |||
narinfo-file-hash)) | |||
("FileSize" . ,(compose number-or-empty-string | |||
narinfo-file-size)) | |||
("NarHash" . ,(compose empty-string-if-false | |||
narinfo-hash)) | |||
("NarSize" . ,(compose number-or-empty-string | |||
narinfo-size)) | |||
("References" . ,(compose string-join narinfo-references)) | |||
("Deriver" . ,(compose empty-string-if-false | |||
narinfo-deriver)) | |||
("System" . ,narinfo-system)) | |||
port)) | |||
(put-bytevector port (string->utf8 (narinfo-contents narinfo)))) | |||
(define (narinfo->string narinfo) | |||
"Return the external representation of NARINFO." | |||
@@ -58,12 +58,17 @@ then | |||
rm -rf "$NIX_STATE_DIR/substituter-data" | |||
mkdir -p "$NIX_STATE_DIR/substituter-data" | |||
# For a number of tests, we want to allow unsigned narinfos, for | |||
# simplicity. | |||
GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES=yes | |||
# Place for the substituter's cache. | |||
XDG_CACHE_HOME="$NIX_STATE_DIR/cache-$$" | |||
export NIX_IGNORE_SYMLINK_STORE NIX_STORE_DIR \ | |||
NIX_LOCALSTATE_DIR NIX_LOG_DIR NIX_STATE_DIR NIX_DB_DIR \ | |||
NIX_ROOT_FINDER NIX_SETUID_HELPER GUIX_BINARY_SUBSTITUTE_URL \ | |||
GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES \ | |||
NIX_CONF_DIR XDG_CACHE_HOME | |||
# Do that because store.scm calls `canonicalize-path' on it. | |||
@@ -0,0 +1,59 @@ | |||
;;; GNU Guix --- Functional package management for GNU | |||
;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.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-base64) | |||
#:use-module (guix base64) | |||
#:use-module (rnrs bytevectors) | |||
#:use-module (srfi srfi-64)) | |||
(define (string->base64 str) | |||
(base64-encode (string->utf8 str))) | |||
;;; Test vectors from <https://tools.ietf.org/rfc/rfc4648.txt>. | |||
(test-begin "base64") | |||
(test-equal "empty string" | |||
(string->base64 "") | |||
"") | |||
(test-equal "f" | |||
(string->base64 "f") | |||
"Zg==") | |||
(test-equal "fo" | |||
(string->base64 "fo") | |||
"Zm8=") | |||
(test-equal "foo" | |||
(string->base64 "foo") | |||
"Zm9v") | |||
(test-equal "foob" | |||
(string->base64 "foob") | |||
"Zm9vYg==") | |||
(test-equal "fooba" | |||
(string->base64 "fooba") | |||
"Zm9vYmE=") | |||
(test-equal "foobar" | |||
(string->base64 "foobar") | |||
"Zm9vYmFy") | |||
(test-end "base64") |
@@ -0,0 +1,197 @@ | |||
;;; GNU Guix --- Functional package management for GNU | |||
;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org> | |||
;;; Copyright © 2014 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-substitute-binary) | |||
#:use-module (guix scripts substitute-binary) | |||
#:use-module (guix base64) | |||
#:use-module (guix hash) | |||
#:use-module (guix nar) | |||
#:use-module (guix pk-crypto) | |||
#:use-module (guix pki) | |||
#:use-module (rnrs bytevectors) | |||
#:use-module (srfi srfi-34) | |||
#:use-module ((srfi srfi-64) #:hide (test-error))) | |||
(define assert-valid-signature | |||
;; (guix scripts substitute-binary) does not export this function in order to | |||
;; avoid misuse. | |||
(@@ (guix scripts substitute-binary) assert-valid-signature)) | |||
;;; XXX: Replace with 'test-error' from SRFI-64 as soon as it allow us to | |||
;;; catch specific exceptions. | |||
(define-syntax-rule (test-error* name exp) | |||
(test-assert name | |||
(catch 'quit | |||
(lambda () | |||
exp | |||
#f) | |||
(const #t)))) | |||
(define %keypair | |||
;; (display (canonical-sexp->string | |||
;; (generate-key "(genkey (rsa (nbits 4:1024)))"))) | |||
(string->canonical-sexp | |||
"(key-data | |||
(public-key | |||
(rsa | |||
(n #00D74A00F16DD109A8E773291856A4EF9EE2C2D975E0BC207EA24245C9CFE39E32D8BA5442A2720A57E3A9D9E55E596A8B19CB2EF844E5E859362593914BD626433C887FB798AE87E1DA95D372DFC81E220B8802B04CEC818D9B6B4E2108817755AEBAC23D2FD2B0AB82A52FD785194F3C2D7B9327212588DB74D464EEE5DC9F5B#) | |||
(e #010001#) | |||
) | |||
) | |||
(private-key | |||
(rsa | |||
(n #00D74A00F16DD109A8E773291856A4EF9EE2C2D975E0BC207EA24245C9CFE39E32D8BA5442A2720A57E3A9D9E55E596A8B19CB2EF844E5E859362593914BD626433C887FB798AE87E1DA95D372DFC81E220B8802B04CEC818D9B6B4E2108817755AEBAC23D2FD2B0AB82A52FD785194F3C2D7B9327212588DB74D464EEE5DC9F5B#) | |||
(e #010001#) | |||
(d #40E6D963EF143E9241BC10DE7A785C988C89EB1EC33253A5796AFB38FCC804D015500EC8CBCA0F5E318EE9D660DC19E7774E2E89BFD38379297EA87EFBDAC24BA32EE5339215382B2C89F5A817FD9131CA8E8A0A70D58E26E847AD0C447053671A6B2D7746087DE058A02B17701752B8A36EB414435921615AE7CAA8AC48E451#) | |||
(p #00EA88C0C19FE83C09285EF49FF88A1159357FD870031C20F15EF5103FBEB10925299BCA197F7143D6792A1BA7044EDA572EC94FA6B00889F9857216CF5B984403#) | |||
(q #00EAFE541EE9E0531255A85CADBEF64D5F679766D7209F521ADD131CF4B7DA9DF5414901342A146EE84FAA1E35EE0D0F6CE3F5F25989C0D1E9FA5B678D78C113C9#) | |||
(u #59C80FA2C48181F6855691C9D443619BA46C7648056E081697C370D8096E8EF165122D5E55F8FD6A2DCC404FA8BDCDC1FD20B4D76A433F25E8FD6901EC2DBDAD#) | |||
) | |||
) | |||
)")) | |||
(define %public-key | |||
(find-sexp-token %keypair 'public-key)) | |||
(define %private-key | |||
(find-sexp-token %keypair 'private-key)) | |||
(define (signature-body str) | |||
(base64-encode | |||
(string->utf8 | |||
(canonical-sexp->string | |||
(signature-sexp (bytevector->hash-data (sha256 (string->utf8 str)) | |||
#:key-type 'rsa) | |||
%private-key | |||
%public-key))))) | |||
(define %signature-body | |||
(signature-body "secret")) | |||
(define %wrong-public-key | |||
(string->canonical-sexp "(public-key | |||
(rsa | |||
(n #00E05873AC2B168760343145918E954EE9AB73C026355693B192E01EE835261AA689E9EF46642E895BCD65C648524059FC450E4BA77A68F4C52D0E39EF0CC9359709AB6AAB153B63782201871325B0FDA19CB401CD99FD0C31A91CA9000AA90A77E82B89E036FB63BC1D3961207469B3B12468977148D376F8012BB12A4B11A8F1#) | |||
(e #010001#) | |||
) | |||
)")) | |||
(define %wrong-signature | |||
(let* ((body (string->canonical-sexp | |||
(utf8->string | |||
(base64-decode %signature-body)))) | |||
(data (canonical-sexp->string (find-sexp-token body 'data))) | |||
(sig-val (canonical-sexp->string (find-sexp-token body 'sig-val))) | |||
(public-key (canonical-sexp->string %wrong-public-key)) | |||
(body* (base64-encode | |||
(string->utf8 | |||
(string-append "(signature \n" data sig-val | |||
public-key " )\n"))))) | |||
(string-append "1;irrelevant;" body*))) | |||
(define* (signature str #:optional (body %signature-body)) | |||
(string-append str ";irrelevant;" body)) | |||
(define %signature | |||
(signature "1" %signature-body)) | |||
(define %acl | |||
(public-keys->acl (list %public-key))) | |||
(test-begin "substitute-binary") | |||
(test-error* "not a number" | |||
(narinfo-signature->canonical-sexp (signature "not a number"))) | |||
(test-error* "wrong version number" | |||
(narinfo-signature->canonical-sexp (signature "2"))) | |||
(test-assert "valid narinfo-signature->canonical-sexp" | |||
(canonical-sexp? (narinfo-signature->canonical-sexp %signature))) | |||
(define-syntax-rule (test-error-condition name pred exp) | |||
(test-assert name | |||
(guard (condition ((pred condition) (pk 'true condition #t)) | |||
(else #f)) | |||
exp | |||
#f))) | |||
;;; XXX: Do we need a better predicate hierarchy for these tests? | |||
(test-error-condition "corrupt signature data" | |||
nar-signature-error? | |||
(assert-valid-signature "invalid sexp" "irrelevant" | |||
(open-input-string "irrelevant") | |||
%acl)) | |||
(test-error-condition "unauthorized public key" | |||
nar-signature-error? | |||
(assert-valid-signature (canonical-sexp->string | |||
(narinfo-signature->canonical-sexp %signature)) | |||
"irrelevant" | |||
(open-input-string "irrelevant") | |||
(public-keys->acl '()))) | |||
(test-error-condition "invalid signature" | |||
nar-signature-error? | |||
(assert-valid-signature (canonical-sexp->string | |||
(narinfo-signature->canonical-sexp | |||
%wrong-signature)) | |||
(sha256 (string->utf8 "secret")) | |||
(open-input-string "irrelevant") | |||
(public-keys->acl (list %wrong-public-key)))) | |||
(define %narinfo | |||
"StorePath: /nix/store/foo | |||
URL: nar/foo | |||
Compression: bzip2 | |||
NarHash: sha256:7 | |||
NarSize: 42 | |||
References: bar baz | |||
Deriver: foo.drv | |||
System: mips64el-linux\n") | |||
(define (narinfo sig) | |||
(format #f "~aSignature: ~a~%" %narinfo sig)) | |||
(define %signed-narinfo | |||
(narinfo (signature "1" (signature-body %narinfo)))) | |||
(test-error-condition "invalid hash" | |||
;; The hash of '%signature' is computed over the word "secret", not | |||
;; '%narinfo'. | |||
nar-invalid-hash-error? | |||
(read-narinfo (open-input-string (narinfo %signature)) | |||
"https://example.com" %acl)) | |||
(test-assert "valid read-narinfo" | |||
(read-narinfo (open-input-string %signed-narinfo) | |||
"https://example.com" %acl)) | |||
(test-equal "valid write-narinfo" | |||
%signed-narinfo | |||
(call-with-output-string | |||
(lambda (port) | |||
(write-narinfo (read-narinfo (open-input-string %signed-narinfo) | |||
"https://example.com" %acl) | |||
port)))) | |||
(test-end "substitute-binary") | |||
(exit (= (test-runner-fail-count (test-runner-current)) 0)) |