1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
3 ;;; Copyright © 2014, 2015, 2017, 2018, 2019 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 (gcrypt hash)
24 #:use-module (guix serialization)
25 #:use-module (gcrypt 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 utils) #:select (call-with-compressed-output-port))
32 #:use-module ((guix lzlib) #:select (lzlib-available?))
33 #:use-module ((guix build utils)
34 #:select (mkdir-p delete-file-recursively dump-port))
35 #:use-module (guix tests http)
36 #:use-module (rnrs bytevectors)
37 #:use-module (rnrs io ports)
38 #:use-module (web uri)
39 #:use-module (ice-9 regex)
40 #:use-module (srfi srfi-26)
41 #:use-module (srfi srfi-34)
42 #:use-module (srfi srfi-35)
43 #:use-module ((srfi srfi-64) #:hide (test-error)))
45 (define-syntax-rule (test-quit name error-rx exp)
46 "Emit a test that passes when EXP throws to 'quit' with value 1, and when
47 it writes to GUIX-WARNING-PORT a messages that matches ERROR-RX."
50 (let ((error-output (open-output-string)))
51 (parameterize ((guix-warning-port error-output))
58 (let ((message (get-output-string error-output)))
59 (->bool (string-match error-rx message))))))))))
62 ;; This key is known to be in the ACL by default.
63 (call-with-input-file (string-append %config-directory "/signing-key.pub")
64 (compose string->canonical-sexp get-string-all)))
67 (call-with-input-file (string-append %config-directory "/signing-key.sec")
68 (compose string->canonical-sexp get-string-all)))
70 (define* (signature-body bv #:key (public-key %public-key))
71 "Return the signature of BV as the base64-encoded body of a narinfo's
75 (canonical-sexp->string
76 (signature-sexp (bytevector->hash-data (sha256 bv)
81 (define %wrong-public-key
82 (string->canonical-sexp "(public-key
84 (n #00E05873AC2B168760343145918E954EE9AB73C026355693B192E01EE835261AA689E9EF46642E895BCD65C648524059FC450E4BA77A68F4C52D0E39EF0CC9359709AB6AAB153B63782201871325B0FDA19CB401CD99FD0C31A91CA9000AA90A77E82B89E036FB63BC1D3961207469B3B12468977148D376F8012BB12A4B11A8F1#)
89 (define* (signature-field bv-or-str
90 #:key (version "1") (public-key %public-key))
91 "Return the 'Signature' field value of bytevector/string BV-OR-STR, using
92 PUBLIC-KEY as the signature's principal, and using VERSION as the signature
94 (string-append version ";example.gnu.org;"
95 (signature-body (if (string? bv-or-str)
96 (string->utf8 bv-or-str)
98 #:public-key public-key)))
102 (test-begin "substitute")
104 (test-quit "not a number"
106 (narinfo-signature->canonical-sexp
107 (signature-field "foo" #:version "not a number")))
109 (test-quit "wrong version number"
110 "unsupported.*version"
111 (narinfo-signature->canonical-sexp
112 (signature-field "foo" #:version "2")))
114 (test-assert "valid narinfo-signature->canonical-sexp"
115 (canonical-sexp? (narinfo-signature->canonical-sexp (signature-field "foo"))))
119 (define %main-substitute-directory
120 ;; The place where 'call-with-narinfo' stores its data by default.
121 (uri-path (string->uri (getenv "GUIX_BINARY_SUBSTITUTE_URL"))))
123 (define %alternate-substitute-directory
125 (string-append (dirname %main-substitute-directory)
126 "/substituter-alt-data"))
129 ;; Skeleton of the narinfo used below.
130 (string-append "StorePath: " (%store-prefix)
131 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
134 NarHash: sha256:" (bytevector->nix-base32-string
135 (sha256 (string->utf8 "Substitutable data."))) "
138 Deriver: " (%store-prefix) "/foo.drv
139 System: mips64el-linux\n"))
141 (define* (call-with-narinfo narinfo thunk
143 (narinfo-directory %main-substitute-directory))
144 "Call THUNK in a context where the directory at URL is populated with
146 (mkdir-p narinfo-directory)
147 (let ((cache-directory (string-append (getenv "XDG_CACHE_HOME")
148 "/guix/substitute/")))
151 (when (file-exists? cache-directory)
152 (delete-file-recursively cache-directory))
153 (call-with-output-file (string-append narinfo-directory
156 (format port "StoreDir: ~a\nWantMassQuery: 0\n"
158 (call-with-output-file (string-append narinfo-directory "/"
159 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
161 (cut display narinfo <>))
164 (call-with-output-file
165 (string-append narinfo-directory "/example.out")
166 (cut display "Substitutable data." <>))
167 (call-with-output-file
168 (string-append narinfo-directory "/example.nar")
170 (string-append narinfo-directory "/example.out") <>))
172 (%allow-unauthenticated-substitutes? #f))
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 with signature over nothing"
215 ;; The signature is computed over the empty string, not over the important
216 ;; parts, so the narinfo must be ignored.
219 (with-narinfo (string-append "Signature: " (signature-field "") "\n"
222 (with-output-to-string
224 (with-input-from-string (string-append "have " (%store-prefix)
225 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
227 (guix-substitute "--query"))))))))
229 (test-equal "query narinfo with signature over irrelevant bits"
230 ;; The signature is valid but it does not cover the
231 ;; StorePath/NarHash/References tuple and is thus irrelevant; the narinfo
235 (let ((prefix (string-append "StorePath: " (%store-prefix)
236 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
238 Compression: none\n")))
239 (with-narinfo (string-append prefix
240 "Signature: " (signature-field prefix) "
241 NarHash: sha256:aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
244 Deriver: " (%store-prefix) "/foo.drv
245 System: mips64el-linux\n")
247 (with-output-to-string
249 (with-input-from-string (string-append "have " (%store-prefix)
250 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
252 (guix-substitute "--query")))))))))
254 (test-equal "query narinfo signed with authorized key"
255 (string-append (%store-prefix) "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
257 (with-narinfo (string-append %narinfo "Signature: "
258 (signature-field %narinfo)
261 (with-output-to-string
263 (with-input-from-string (string-append "have " (%store-prefix)
264 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
266 (guix-substitute "--query"))))))))
268 (test-equal "query narinfo signed with unauthorized key"
269 "" ; not substitutable
271 (with-narinfo (string-append %narinfo "Signature: "
274 #:public-key %wrong-public-key)
277 (with-output-to-string
279 (with-input-from-string (string-append "have " (%store-prefix)
280 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
282 (guix-substitute "--query"))))))))
284 (test-quit "substitute, no signature"
285 "no valid substitute"
286 (with-narinfo %narinfo
287 (guix-substitute "--substitute"
288 (string-append (%store-prefix)
289 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
292 (test-quit "substitute, invalid hash"
293 "no valid substitute"
294 ;; The hash in the signature differs from the hash of %NARINFO.
295 (with-narinfo (string-append %narinfo "Signature: "
296 (signature-field "different body")
298 (guix-substitute "--substitute"
299 (string-append (%store-prefix)
300 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
303 (test-quit "substitute, unauthorized key"
304 "no valid substitute"
305 (with-narinfo (string-append %narinfo "Signature: "
308 #:public-key %wrong-public-key)
310 (guix-substitute "--substitute"
311 (string-append (%store-prefix)
312 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
315 (test-equal "substitute, authorized key"
316 "Substitutable data."
317 (with-narinfo (string-append %narinfo "Signature: "
318 (signature-field %narinfo))
322 (guix-substitute "--substitute"
323 (string-append (%store-prefix)
324 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
325 "substitute-retrieved")
326 (call-with-input-file "substitute-retrieved" get-string-all))
328 (false-if-exception (delete-file "substitute-retrieved"))))))
330 (test-equal "substitute, unauthorized narinfo comes first"
331 "Substitutable data."
333 (string-append %narinfo "Signature: "
336 #:public-key %wrong-public-key))
337 %alternate-substitute-directory
339 (with-narinfo* (string-append %narinfo "Signature: "
340 (signature-field %narinfo))
341 %main-substitute-directory
346 ;; Remove this file so that the substitute can only be retrieved
347 ;; from %ALTERNATE-SUBSTITUTE-DIRECTORY.
348 (delete-file (string-append %main-substitute-directory
351 (parameterize ((substitute-urls
352 (map (cut string-append "file://" <>)
353 (list %alternate-substitute-directory
354 %main-substitute-directory))))
355 (guix-substitute "--substitute"
356 (string-append (%store-prefix)
357 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
358 "substitute-retrieved"))
359 (call-with-input-file "substitute-retrieved" get-string-all))
361 (false-if-exception (delete-file "substitute-retrieved")))))))
363 (test-equal "substitute, unsigned narinfo comes first"
364 "Substitutable data."
365 (with-narinfo* %narinfo ;not signed!
366 %alternate-substitute-directory
368 (with-narinfo* (string-append %narinfo "Signature: "
369 (signature-field %narinfo))
370 %main-substitute-directory
375 ;; Remove this file so that the substitute can only be retrieved
376 ;; from %ALTERNATE-SUBSTITUTE-DIRECTORY.
377 (delete-file (string-append %main-substitute-directory
380 (parameterize ((substitute-urls
381 (map (cut string-append "file://" <>)
382 (list %alternate-substitute-directory
383 %main-substitute-directory))))
384 (guix-substitute "--substitute"
385 (string-append (%store-prefix)
386 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
387 "substitute-retrieved"))
388 (call-with-input-file "substitute-retrieved" get-string-all))
390 (false-if-exception (delete-file "substitute-retrieved")))))))
392 (test-equal "substitute, first narinfo is unsigned and has wrong hash"
393 "Substitutable data."
394 (with-narinfo* (regexp-substitute #f
395 (string-match "NarHash: [[:graph:]]+"
399 (bytevector->nix-base32-string
400 (make-bytevector 32))
402 %alternate-substitute-directory
404 (with-narinfo* (string-append %narinfo "Signature: "
405 (signature-field %narinfo))
406 %main-substitute-directory
411 ;; This time remove the file so that the substitute can only be
412 ;; retrieved from %MAIN-SUBSTITUTE-DIRECTORY.
413 (delete-file (string-append %alternate-substitute-directory
416 (parameterize ((substitute-urls
417 (map (cut string-append "file://" <>)
418 (list %alternate-substitute-directory
419 %main-substitute-directory))))
420 (guix-substitute "--substitute"
421 (string-append (%store-prefix)
422 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
423 "substitute-retrieved"))
424 (call-with-input-file "substitute-retrieved" get-string-all))
426 (false-if-exception (delete-file "substitute-retrieved")))))))
428 (test-equal "substitute, first narinfo is unsigned and has wrong refs"
429 "Substitutable data."
430 (with-narinfo* (regexp-substitute #f
431 (string-match "References: ([^\n]+)\n"
433 'pre "References: " 1
434 " wrong set of references\n"
436 %alternate-substitute-directory
438 (with-narinfo* (string-append %narinfo "Signature: "
439 (signature-field %narinfo))
440 %main-substitute-directory
445 ;; This time remove the file so that the substitute can only be
446 ;; retrieved from %MAIN-SUBSTITUTE-DIRECTORY.
447 (delete-file (string-append %alternate-substitute-directory
450 (parameterize ((substitute-urls
451 (map (cut string-append "file://" <>)
452 (list %alternate-substitute-directory
453 %main-substitute-directory))))
454 (guix-substitute "--substitute"
455 (string-append (%store-prefix)
456 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
457 "substitute-retrieved"))
458 (call-with-input-file "substitute-retrieved" get-string-all))
460 (false-if-exception (delete-file "substitute-retrieved")))))))
462 (test-quit "substitute, two invalid narinfos"
463 "no valid substitute"
464 (with-narinfo* %narinfo ;not signed
465 %alternate-substitute-directory
467 (with-narinfo* (string-append %narinfo "Signature: " ;unauthorized
470 #:public-key %wrong-public-key))
471 %main-substitute-directory
473 (guix-substitute "--substitute"
474 (string-append (%store-prefix)
475 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
476 "substitute-retrieved"))))
478 (test-equal "substitute, narinfo with several URLs"
479 "Substitutable data."
480 (let ((narinfo (string-append "StorePath: " (%store-prefix)
481 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
488 NarHash: sha256:" (bytevector->nix-base32-string
489 (sha256 (string->utf8 "Substitutable data."))) "
492 Deriver: " (%store-prefix) "/foo.drv
493 System: mips64el-linux\n")))
494 (with-narinfo (string-append narinfo "Signature: "
495 (signature-field narinfo))
499 (define (compress input output compression)
500 (call-with-output-file output
502 (call-with-compressed-output-port compression port
504 (call-with-input-file input
506 (dump-port input port))))))))
508 (let ((nar (string-append %main-substitute-directory
510 (compress nar (string-append nar ".gz") 'gzip)
511 (when (lzlib-available?)
512 (compress nar (string-append nar ".lz") 'lzip)))
514 (parameterize ((substitute-urls
515 (list (string-append "file://"
516 %main-substitute-directory))))
517 (guix-substitute "--substitute"
518 (string-append (%store-prefix)
519 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
520 "substitute-retrieved"))
521 (call-with-input-file "substitute-retrieved" get-string-all))
523 (false-if-exception (delete-file "substitute-retrieved")))))))
525 (test-end "substitute")
528 ;;; eval: (put 'with-narinfo 'scheme-indent-function 1)
529 ;;; eval: (put 'with-narinfo* 'scheme-indent-function 2)
530 ;;; eval: (put 'test-quit 'scheme-indent-function 2)