1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
3 ;;; Copyright © 2014, 2015, 2017 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)
32 #:select (mkdir-p delete-file-recursively))
33 #:use-module (guix tests http)
34 #:use-module (rnrs bytevectors)
35 #:use-module (rnrs io ports)
36 #:use-module (web uri)
37 #:use-module (ice-9 regex)
38 #:use-module (srfi srfi-26)
39 #:use-module (srfi srfi-34)
40 #:use-module (srfi srfi-35)
41 #:use-module ((srfi srfi-64) #:hide (test-error)))
43 (define-syntax-rule (test-quit name error-rx exp)
44 "Emit a test that passes when EXP throws to 'quit' with value 1, and when
45 it writes to GUIX-WARNING-PORT a messages that matches ERROR-RX."
48 (let ((error-output (open-output-string)))
49 (parameterize ((guix-warning-port error-output))
56 (let ((message (get-output-string error-output)))
57 (->bool (string-match error-rx message))))))))))
60 ;; This key is known to be in the ACL by default.
61 (call-with-input-file (string-append %config-directory "/signing-key.pub")
62 (compose string->canonical-sexp get-string-all)))
65 (call-with-input-file (string-append %config-directory "/signing-key.sec")
66 (compose string->canonical-sexp get-string-all)))
68 (define* (signature-body bv #:key (public-key %public-key))
69 "Return the signature of BV as the base64-encoded body of a narinfo's
73 (canonical-sexp->string
74 (signature-sexp (bytevector->hash-data (sha256 bv)
79 (define %wrong-public-key
80 (string->canonical-sexp "(public-key
82 (n #00E05873AC2B168760343145918E954EE9AB73C026355693B192E01EE835261AA689E9EF46642E895BCD65C648524059FC450E4BA77A68F4C52D0E39EF0CC9359709AB6AAB153B63782201871325B0FDA19CB401CD99FD0C31A91CA9000AA90A77E82B89E036FB63BC1D3961207469B3B12468977148D376F8012BB12A4B11A8F1#)
87 (define* (signature-field bv-or-str
88 #:key (version "1") (public-key %public-key))
89 "Return the 'Signature' field value of bytevector/string BV-OR-STR, using
90 PUBLIC-KEY as the signature's principal, and using VERSION as the signature
92 (string-append version ";example.gnu.org;"
93 (signature-body (if (string? bv-or-str)
94 (string->utf8 bv-or-str)
96 #:public-key public-key)))
100 (test-begin "substitute")
102 (test-quit "not a number"
104 (narinfo-signature->canonical-sexp
105 (signature-field "foo" #:version "not a number")))
107 (test-quit "wrong version number"
108 "unsupported.*version"
109 (narinfo-signature->canonical-sexp
110 (signature-field "foo" #:version "2")))
112 (test-assert "valid narinfo-signature->canonical-sexp"
113 (canonical-sexp? (narinfo-signature->canonical-sexp (signature-field "foo"))))
117 (define %main-substitute-directory
118 ;; The place where 'call-with-narinfo' stores its data by default.
119 (uri-path (string->uri (getenv "GUIX_BINARY_SUBSTITUTE_URL"))))
121 (define %alternate-substitute-directory
123 (string-append (dirname %main-substitute-directory)
124 "/substituter-alt-data"))
127 ;; Skeleton of the narinfo used below.
128 (string-append "StorePath: " (%store-prefix)
129 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
132 NarHash: sha256:" (bytevector->nix-base32-string
133 (sha256 (string->utf8 "Substitutable data."))) "
136 Deriver: " (%store-prefix) "/foo.drv
137 System: mips64el-linux\n"))
139 (define* (call-with-narinfo narinfo thunk
141 (narinfo-directory %main-substitute-directory))
142 "Call THUNK in a context where the directory at URL is populated with
144 (mkdir-p narinfo-directory)
145 (let ((cache-directory (string-append (getenv "XDG_CACHE_HOME")
146 "/guix/substitute/")))
149 (when (file-exists? cache-directory)
150 (delete-file-recursively cache-directory))
151 (call-with-output-file (string-append narinfo-directory
154 (format port "StoreDir: ~a\nWantMassQuery: 0\n"
156 (call-with-output-file (string-append narinfo-directory "/"
157 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
159 (cut display narinfo <>))
162 (call-with-output-file
163 (string-append narinfo-directory "/example.out")
164 (cut display "Substitutable data." <>))
165 (call-with-output-file
166 (string-append narinfo-directory "/example.nar")
168 (string-append narinfo-directory "/example.out") <>))
170 (set! (@@ (guix scripts substitute)
171 %allow-unauthenticated-substitutes?)
175 (when (file-exists? cache-directory)
176 (delete-file-recursively cache-directory))))))
178 (define-syntax-rule (with-narinfo narinfo body ...)
179 (call-with-narinfo narinfo (lambda () body ...)))
181 (define-syntax-rule (with-narinfo* narinfo directory body ...)
182 (call-with-narinfo narinfo (lambda () body ...) directory))
184 ;; Transmit these options to 'guix substitute'.
185 (substitute-urls (list (getenv "GUIX_BINARY_SUBSTITUTE_URL")))
187 (test-equal "query narinfo without signature"
188 "" ; not substitutable
190 (with-narinfo %narinfo
192 (with-output-to-string
194 (with-input-from-string (string-append "have " (%store-prefix)
195 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
197 (guix-substitute "--query"))))))))
199 (test-equal "query narinfo with invalid hash"
200 ;; The hash in the signature differs from the hash of %NARINFO.
203 (with-narinfo (string-append %narinfo "Signature: "
204 (signature-field "different body")
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 authorized key"
215 (string-append (%store-prefix) "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
217 (with-narinfo (string-append %narinfo "Signature: "
218 (signature-field %narinfo)
221 (with-output-to-string
223 (with-input-from-string (string-append "have " (%store-prefix)
224 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
226 (guix-substitute "--query"))))))))
228 (test-equal "query narinfo signed with unauthorized key"
229 "" ; not substitutable
231 (with-narinfo (string-append %narinfo "Signature: "
234 #:public-key %wrong-public-key)
237 (with-output-to-string
239 (with-input-from-string (string-append "have " (%store-prefix)
240 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
242 (guix-substitute "--query"))))))))
244 (test-quit "substitute, no signature"
245 "no valid substitute"
246 (with-narinfo %narinfo
247 (guix-substitute "--substitute"
248 (string-append (%store-prefix)
249 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
252 (test-quit "substitute, invalid hash"
253 "no valid substitute"
254 ;; The hash in the signature differs from the hash of %NARINFO.
255 (with-narinfo (string-append %narinfo "Signature: "
256 (signature-field "different body")
258 (guix-substitute "--substitute"
259 (string-append (%store-prefix)
260 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
263 (test-quit "substitute, unauthorized key"
264 "no valid substitute"
265 (with-narinfo (string-append %narinfo "Signature: "
268 #:public-key %wrong-public-key)
270 (guix-substitute "--substitute"
271 (string-append (%store-prefix)
272 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
275 (test-equal "substitute, authorized key"
276 "Substitutable data."
277 (with-narinfo (string-append %narinfo "Signature: "
278 (signature-field %narinfo))
282 (guix-substitute "--substitute"
283 (string-append (%store-prefix)
284 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
285 "substitute-retrieved")
286 (call-with-input-file "substitute-retrieved" get-string-all))
288 (false-if-exception (delete-file "substitute-retrieved"))))))
290 (test-equal "substitute, unauthorized narinfo comes first"
291 "Substitutable data."
293 (string-append %narinfo "Signature: "
296 #:public-key %wrong-public-key))
297 %alternate-substitute-directory
299 (with-narinfo* (string-append %narinfo "Signature: "
300 (signature-field %narinfo))
301 %main-substitute-directory
306 ;; Remove this file so that the substitute can only be retrieved
307 ;; from %ALTERNATE-SUBSTITUTE-DIRECTORY.
308 (delete-file (string-append %main-substitute-directory
311 (parameterize ((substitute-urls
312 (map (cut string-append "file://" <>)
313 (list %alternate-substitute-directory
314 %main-substitute-directory))))
315 (guix-substitute "--substitute"
316 (string-append (%store-prefix)
317 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
318 "substitute-retrieved"))
319 (call-with-input-file "substitute-retrieved" get-string-all))
321 (false-if-exception (delete-file "substitute-retrieved")))))))
323 (test-equal "substitute, unsigned narinfo comes first"
324 "Substitutable data."
325 (with-narinfo* %narinfo ;not signed!
326 %alternate-substitute-directory
328 (with-narinfo* (string-append %narinfo "Signature: "
329 (signature-field %narinfo))
330 %main-substitute-directory
335 ;; Remove this file so that the substitute can only be retrieved
336 ;; from %ALTERNATE-SUBSTITUTE-DIRECTORY.
337 (delete-file (string-append %main-substitute-directory
340 (parameterize ((substitute-urls
341 (map (cut string-append "file://" <>)
342 (list %alternate-substitute-directory
343 %main-substitute-directory))))
344 (guix-substitute "--substitute"
345 (string-append (%store-prefix)
346 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
347 "substitute-retrieved"))
348 (call-with-input-file "substitute-retrieved" get-string-all))
350 (false-if-exception (delete-file "substitute-retrieved")))))))
352 (test-equal "substitute, first narinfo is unsigned and has wrong hash"
353 "Substitutable data."
354 (with-narinfo* (regexp-substitute #f
355 (string-match "NarHash: [[:graph:]]+"
359 (bytevector->nix-base32-string
360 (make-bytevector 32))
362 %alternate-substitute-directory
364 (with-narinfo* (string-append %narinfo "Signature: "
365 (signature-field %narinfo))
366 %main-substitute-directory
371 ;; This time remove the file so that the substitute can only be
372 ;; retrieved from %MAIN-SUBSTITUTE-DIRECTORY.
373 (delete-file (string-append %alternate-substitute-directory
376 (parameterize ((substitute-urls
377 (map (cut string-append "file://" <>)
378 (list %alternate-substitute-directory
379 %main-substitute-directory))))
380 (guix-substitute "--substitute"
381 (string-append (%store-prefix)
382 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
383 "substitute-retrieved"))
384 (call-with-input-file "substitute-retrieved" get-string-all))
386 (false-if-exception (delete-file "substitute-retrieved")))))))
388 (test-equal "substitute, first narinfo is unsigned and has wrong refs"
389 "Substitutable data."
390 (with-narinfo* (regexp-substitute #f
391 (string-match "References: ([^\n]+)\n"
393 'pre "References: " 1
394 " wrong set of references\n"
396 %alternate-substitute-directory
398 (with-narinfo* (string-append %narinfo "Signature: "
399 (signature-field %narinfo))
400 %main-substitute-directory
405 ;; This time remove the file so that the substitute can only be
406 ;; retrieved from %MAIN-SUBSTITUTE-DIRECTORY.
407 (delete-file (string-append %alternate-substitute-directory
410 (parameterize ((substitute-urls
411 (map (cut string-append "file://" <>)
412 (list %alternate-substitute-directory
413 %main-substitute-directory))))
414 (guix-substitute "--substitute"
415 (string-append (%store-prefix)
416 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
417 "substitute-retrieved"))
418 (call-with-input-file "substitute-retrieved" get-string-all))
420 (false-if-exception (delete-file "substitute-retrieved")))))))
422 (test-quit "substitute, two invalid narinfos"
423 "no valid substitute"
424 (with-narinfo* %narinfo ;not signed
425 %alternate-substitute-directory
427 (with-narinfo* (string-append %narinfo "Signature: " ;unauthorized
430 #:public-key %wrong-public-key))
431 %main-substitute-directory
433 (guix-substitute "--substitute"
434 (string-append (%store-prefix)
435 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
436 "substitute-retrieved"))))
438 (test-end "substitute")
441 ;;; eval: (put 'with-narinfo 'scheme-indent-function 1)
442 ;;; eval: (put 'with-narinfo* 'scheme-indent-function 2)
443 ;;; eval: (put 'test-quit 'scheme-indent-function 2)