1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
3 ;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
5 ;;; This file is part of GNU Guix.
7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
8 ;;; under the terms of the GNU General Public License as published by
9 ;;; the Free Software Foundation; either version 3 of the License, or (at
10 ;;; your option) any later version.
12 ;;; GNU Guix is distributed in the hope that it will be useful, but
13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;;; GNU General Public License for more details.
17 ;;; You should have received a copy of the GNU General Public License
18 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
20 (define-module (test-substitute)
21 #:use-module (guix scripts substitute)
22 #:use-module (guix base64)
23 #:use-module (guix hash)
24 #:use-module (guix serialization)
25 #:use-module (guix pk-crypto)
26 #:use-module (guix pki)
27 #:use-module (guix config)
28 #:use-module (guix base32)
29 #:use-module ((guix store) #:select (%store-prefix))
30 #:use-module ((guix ui) #:select (guix-warning-port))
31 #:use-module ((guix build utils) #:select (delete-file-recursively))
32 #:use-module (rnrs bytevectors)
33 #:use-module (rnrs io ports)
34 #:use-module (web uri)
35 #:use-module (ice-9 regex)
36 #:use-module (srfi srfi-26)
37 #:use-module (srfi srfi-34)
38 #:use-module (srfi srfi-35)
39 #:use-module ((srfi srfi-64) #:hide (test-error)))
41 (define-syntax-rule (test-quit name error-rx exp)
42 "Emit a test that passes when EXP throws to 'quit' with value 1, and when
43 it writes to GUIX-WARNING-PORT a messages that matches ERROR-RX."
46 (let ((error-output (open-output-string)))
47 (parameterize ((guix-warning-port error-output))
54 (let ((message (get-output-string error-output)))
55 (->bool (string-match error-rx message))))))))))
58 ;; This key is known to be in the ACL by default.
59 (call-with-input-file (string-append %config-directory "/signing-key.pub")
60 (compose string->canonical-sexp get-string-all)))
63 (call-with-input-file (string-append %config-directory "/signing-key.sec")
64 (compose string->canonical-sexp get-string-all)))
66 (define* (signature-body bv #:key (public-key %public-key))
67 "Return the signature of BV as the base64-encoded body of a narinfo's
71 (canonical-sexp->string
72 (signature-sexp (bytevector->hash-data (sha256 bv)
77 (define %wrong-public-key
78 (string->canonical-sexp "(public-key
80 (n #00E05873AC2B168760343145918E954EE9AB73C026355693B192E01EE835261AA689E9EF46642E895BCD65C648524059FC450E4BA77A68F4C52D0E39EF0CC9359709AB6AAB153B63782201871325B0FDA19CB401CD99FD0C31A91CA9000AA90A77E82B89E036FB63BC1D3961207469B3B12468977148D376F8012BB12A4B11A8F1#)
85 (define* (signature-field bv-or-str
86 #:key (version "1") (public-key %public-key))
87 "Return the 'Signature' field value of bytevector/string BV-OR-STR, using
88 PUBLIC-KEY as the signature's principal, and using VERSION as the signature
90 (string-append version ";example.gnu.org;"
91 (signature-body (if (string? bv-or-str)
92 (string->utf8 bv-or-str)
94 #:public-key public-key)))
98 (test-begin "substitute")
100 (test-quit "not a number"
102 (narinfo-signature->canonical-sexp
103 (signature-field "foo" #:version "not a number")))
105 (test-quit "wrong version number"
106 "unsupported.*version"
107 (narinfo-signature->canonical-sexp
108 (signature-field "foo" #:version "2")))
110 (test-assert "valid narinfo-signature->canonical-sexp"
111 (canonical-sexp? (narinfo-signature->canonical-sexp (signature-field "foo"))))
116 ;; Skeleton of the narinfo used below.
117 (string-append "StorePath: " (%store-prefix)
118 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
121 NarHash: sha256:" (bytevector->nix-base32-string
122 (sha256 (string->utf8 "Substitutable data."))) "
125 Deriver: " (%store-prefix) "/foo.drv
126 System: mips64el-linux\n"))
128 (define (call-with-narinfo narinfo thunk)
129 "Call THUNK in a context where $GUIX_BINARY_SUBSTITUTE_URL is populated with
131 (let ((narinfo-directory (and=> (string->uri (getenv
132 "GUIX_BINARY_SUBSTITUTE_URL"))
134 (cache-directory (string-append (getenv "XDG_CACHE_HOME")
135 "/guix/substitute-binary/")))
138 (when (file-exists? cache-directory)
139 (delete-file-recursively cache-directory))
140 (call-with-output-file (string-append narinfo-directory
143 (format port "StoreDir: ~a\nWantMassQuery: 0\n"
145 (call-with-output-file (string-append narinfo-directory "/"
146 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
148 (cut display narinfo <>))
151 (call-with-output-file
152 (string-append narinfo-directory "/example.out")
153 (cut display "Substitutable data." <>))
154 (call-with-output-file
155 (string-append narinfo-directory "/example.nar")
157 (string-append narinfo-directory "/example.out") <>))
159 (set! (@@ (guix scripts substitute)
160 %allow-unauthenticated-substitutes?)
164 (delete-file-recursively cache-directory)))))
166 (define-syntax-rule (with-narinfo narinfo body ...)
167 (call-with-narinfo narinfo (lambda () body ...)))
169 ;; Transmit these options to 'guix substitute'.
170 (set! (@@ (guix scripts substitute) %cache-url)
171 (getenv "GUIX_BINARY_SUBSTITUTE_URL"))
173 (test-equal "query narinfo without signature"
174 "" ; not substitutable
176 (with-narinfo %narinfo
178 (with-output-to-string
180 (with-input-from-string (string-append "have " (%store-prefix)
181 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
183 (guix-substitute "--query"))))))))
185 (test-equal "query narinfo with invalid hash"
186 ;; The hash in the signature differs from the hash of %NARINFO.
189 (with-narinfo (string-append %narinfo "Signature: "
190 (signature-field "different body")
193 (with-output-to-string
195 (with-input-from-string (string-append "have " (%store-prefix)
196 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
198 (guix-substitute "--query"))))))))
200 (test-equal "query narinfo signed with authorized key"
201 (string-append (%store-prefix) "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
203 (with-narinfo (string-append %narinfo "Signature: "
204 (signature-field %narinfo)
207 (with-output-to-string
209 (with-input-from-string (string-append "have " (%store-prefix)
210 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
212 (guix-substitute "--query"))))))))
214 (test-equal "query narinfo signed with unauthorized key"
215 "" ; not substitutable
217 (with-narinfo (string-append %narinfo "Signature: "
220 #:public-key %wrong-public-key)
223 (with-output-to-string
225 (with-input-from-string (string-append "have " (%store-prefix)
226 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
228 (guix-substitute "--query"))))))))
230 (test-quit "substitute, no signature"
232 (with-narinfo %narinfo
233 (guix-substitute "--substitute"
234 (string-append (%store-prefix)
235 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
238 (test-quit "substitute, invalid hash"
240 ;; The hash in the signature differs from the hash of %NARINFO.
241 (with-narinfo (string-append %narinfo "Signature: "
242 (signature-field "different body")
244 (guix-substitute "--substitute"
245 (string-append (%store-prefix)
246 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
249 (test-quit "substitute, unauthorized key"
251 (with-narinfo (string-append %narinfo "Signature: "
254 #:public-key %wrong-public-key)
256 (guix-substitute "--substitute"
257 (string-append (%store-prefix)
258 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
261 (test-equal "substitute, authorized key"
262 "Substitutable data."
263 (with-narinfo (string-append %narinfo "Signature: "
264 (signature-field %narinfo))
268 (guix-substitute "--substitute"
269 (string-append (%store-prefix)
270 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
271 "substitute-retrieved")
272 (call-with-input-file "substitute-retrieved" get-string-all))
274 (false-if-exception (delete-file "substitute-retrieved"))))))
276 (test-end "substitute")
279 (exit (= (test-runner-fail-count (test-runner-current)) 0))
282 ;;; eval: (put 'with-narinfo 'scheme-indent-function 1)
283 ;;; eval: (put 'test-quit 'scheme-indent-function 2)