nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

substitute-binary: Support the Signature field of a narinfo file. 

* 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'.
This commit is contained in:
Nikita Karetnikov 2014-03-29 00:06:41 +01:00 committed by Ludovic Courtès
parent 24194b6b54
commit e9c6c58418
6 changed files with 598 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
Makefile.am
View File

@ -28,6 +28,7 @@ include gnu-system.am
MODULES = \ MODULES = \
guix/base32.scm \ guix/base32.scm \
guix/base64.scm \
guix/records.scm \ guix/records.scm \
guix/hash.scm \ guix/hash.scm \
guix/pk-crypto.scm \ guix/pk-crypto.scm \
@ -122,9 +123,11 @@ clean-go:
SCM_TESTS = \ SCM_TESTS = \
tests/base32.scm \ tests/base32.scm \
tests/base64.scm \
tests/hash.scm \ tests/hash.scm \
tests/pk-crypto.scm \ tests/pk-crypto.scm \
tests/pki.scm \ tests/pki.scm \
tests/substitute-binary.scm \
tests/builders.scm \ tests/builders.scm \
tests/derivations.scm \ tests/derivations.scm \
tests/ui.scm \ tests/ui.scm \

212
guix/base64.scm Normal file
View File

@ -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)))))

160
guix/scripts/substitute-binary.scm
View File

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -23,6 +24,10 @@
#:use-module (guix config) #:use-module (guix config)
#:use-module (guix records) #:use-module (guix records)
#:use-module (guix nar) #: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 utils) #:select (mkdir-p))
#:use-module ((guix build download) #:use-module ((guix build download)
#:select (progress-proc uri-abbreviation)) #:select (progress-proc uri-abbreviation))
@ -33,15 +38,21 @@
#:use-module (ice-9 format) #:use-module (ice-9 format)
#:use-module (ice-9 ftw) #:use-module (ice-9 ftw)
#:use-module (ice-9 binary-ports) #:use-module (ice-9 binary-ports)
#:use-module (rnrs io ports)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:use-module (srfi srfi-19) #:use-module (srfi srfi-19)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34) #:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (web uri) #:use-module (web uri)
#:use-module (guix http-client) #:use-module (guix http-client)
#:export (guix-substitute-binary)) #:export (narinfo-signature->canonical-sexp
read-narinfo
write-narinfo
guix-substitute-binary))
;;; Comment: ;;; Comment:
;;; ;;;
@ -60,6 +71,16 @@
(cut string-append <> "/guix/substitute-binary")) (cut string-append <> "/guix/substitute-binary"))
(string-append %state-directory "/substitute-binary/cache"))) (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 (define %narinfo-ttl
;; Number of seconds during which cached narinfo lookups are considered ;; Number of seconds during which cached narinfo lookups are considered
;; valid. ;; valid.
@ -194,7 +215,7 @@ failure."
(define-record-type <narinfo> (define-record-type <narinfo>
(%make-narinfo path uri compression file-hash file-size nar-hash nar-size (%make-narinfo path uri compression file-hash file-size nar-hash nar-size
references deriver system) references deriver system signature contents)
narinfo? narinfo?
(path narinfo-path) (path narinfo-path)
(uri narinfo-uri) (uri narinfo-uri)
@ -205,15 +226,38 @@ failure."
(nar-size narinfo-size) (nar-size narinfo-size)
(references narinfo-references) (references narinfo-references)
(deriver narinfo-deriver) (deriver narinfo-deriver)
(system narinfo-system)) (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-maker cache-url) (define (narinfo-signature->canonical-sexp str)
"Return a narinfo constructor for narinfos originating from CACHE-URL." "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 (lambda (path url compression file-hash file-size nar-hash nar-size
references deriver system) references deriver system signature)
"Return a new <narinfo> object." "Return a new <narinfo> object."
(%make-narinfo path (%make-narinfo path
;; Handle the case where URL is a relative URL. ;; Handle the case where URL is a relative URL.
(or (string->uri url) (or (string->uri url)
(string->uri (string-append cache-url "/" url))) (string->uri (string-append cache-url "/" url)))
@ -226,45 +270,81 @@ failure."
(match deriver (match deriver
((or #f "") #f) ((or #f "") #f)
(_ deriver)) (_ deriver))
system))) system
(narinfo-signature->canonical-sexp signature)
str)))
(define* (read-narinfo port #:optional url) ;;; XXX: The following function is nearly an exact copy of the one from
"Read a narinfo from PORT in its standard external form. If URL is true, it ;;; 'guix/nar.scm'. Factorize as soon as we know how to make the latter
must be a string used to build full URIs from relative URIs found while ;;; public (see <https://lists.gnu.org/archive/html/guix-devel/2014-03/msg00097.html>).
reading PORT." ;;; Keep this one private to avoid confusion.
(alist->record (fields->alist port) (define* (assert-valid-signature signature hash port
(narinfo-maker url) #: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" '("StorePath" "URL" "Compression"
"FileHash" "FileSize" "NarHash" "NarSize" "FileHash" "FileSize" "NarHash" "NarSize"
"References" "Deriver" "System"))) "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) (define (write-narinfo narinfo port)
"Write NARINFO to PORT." "Write NARINFO to PORT."
(define (empty-string-if-false x) (put-bytevector port (string->utf8 (narinfo-contents narinfo))))
(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))
(define (narinfo->string narinfo) (define (narinfo->string narinfo)
"Return the external representation of NARINFO." "Return the external representation of NARINFO."

5
test-env.in
View File

@ -58,12 +58,17 @@ then
rm -rf "$NIX_STATE_DIR/substituter-data" rm -rf "$NIX_STATE_DIR/substituter-data"
mkdir -p "$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. # Place for the substituter's cache.
XDG_CACHE_HOME="$NIX_STATE_DIR/cache-$$" XDG_CACHE_HOME="$NIX_STATE_DIR/cache-$$"
export NIX_IGNORE_SYMLINK_STORE NIX_STORE_DIR \ export NIX_IGNORE_SYMLINK_STORE NIX_STORE_DIR \
NIX_LOCALSTATE_DIR NIX_LOG_DIR NIX_STATE_DIR NIX_DB_DIR \ NIX_LOCALSTATE_DIR NIX_LOG_DIR NIX_STATE_DIR NIX_DB_DIR \
NIX_ROOT_FINDER NIX_SETUID_HELPER GUIX_BINARY_SUBSTITUTE_URL \ NIX_ROOT_FINDER NIX_SETUID_HELPER GUIX_BINARY_SUBSTITUTE_URL \
GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES \
NIX_CONF_DIR XDG_CACHE_HOME NIX_CONF_DIR XDG_CACHE_HOME
# Do that because store.scm calls `canonicalize-path' on it. # Do that because store.scm calls `canonicalize-path' on it.

59
tests/base64.scm Normal file
View File

@ -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")

197
tests/substitute-binary.scm Normal file
View File

@ -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))