tests/substitute.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
   3 ;;; Copyright © 2014, 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   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.
  11 ;;;
  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.
  16 ;;;
  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/>.
  19
  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 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)))
  42
  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."
  46   (test-equal name
  47     '(1 #t)
  48     (let ((error-output (open-output-string)))
  49       (parameterize ((guix-warning-port error-output))
  50         (catch 'quit
  51           (lambda ()
  52             exp
  53             #f)
  54           (lambda (key value)
  55             (list value
  56                   (let ((message (get-output-string error-output)))
  57                     (->bool (string-match error-rx message))))))))))
  58
  59 (define %public-key
  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)))
  63
  64 (define %private-key
  65   (call-with-input-file (string-append %config-directory "/signing-key.sec")
  66     (compose string->canonical-sexp get-string-all)))
  67
  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
  70 'Signature' field."
  71   (base64-encode
  72    (string->utf8
  73     (canonical-sexp->string
  74      (signature-sexp (bytevector->hash-data (sha256 bv)
  75                                             #:key-type 'rsa)
  76                      %private-key
  77                      public-key)))))
  78
  79 (define %wrong-public-key
  80   (string->canonical-sexp "(public-key
  81  (rsa
  82   (n #00E05873AC2B168760343145918E954EE9AB73C026355693B192E01EE835261AA689E9EF46642E895BCD65C648524059FC450E4BA77A68F4C52D0E39EF0CC9359709AB6AAB153B63782201871325B0FDA19CB401CD99FD0C31A91CA9000AA90A77E82B89E036FB63BC1D3961207469B3B12468977148D376F8012BB12A4B11A8F1#)
  83   (e #010001#)
  84   )
  85  )"))
  86
  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
  91 version identifier.."
  92   (string-append version ";example.gnu.org;"
  93                  (signature-body (if (string? bv-or-str)
  94                                      (string->utf8 bv-or-str)
  95                                      bv-or-str)
  96                                  #:public-key public-key)))
  97
  98
  99 \f
 100 (test-begin "substitute")
 101
 102 (test-quit "not a number"
 103     "signature version"
 104   (narinfo-signature->canonical-sexp
 105    (signature-field "foo" #:version "not a number")))
 106
 107 (test-quit "wrong version number"
 108     "unsupported.*version"
 109   (narinfo-signature->canonical-sexp
 110    (signature-field "foo" #:version "2")))
 111
 112 (test-assert "valid narinfo-signature->canonical-sexp"
 113   (canonical-sexp? (narinfo-signature->canonical-sexp (signature-field "foo"))))
 114
 115
 116 \f
 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"))))
 120
 121 (define %alternate-substitute-directory
 122   ;; Another place.
 123   (string-append (dirname %main-substitute-directory)
 124                  "/substituter-alt-data"))
 125
 126 (define %narinfo
 127   ;; Skeleton of the narinfo used below.
 128   (string-append "StorePath: " (%store-prefix)
 129                  "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
 130 URL: example.nar
 131 Compression: none
 132 NarHash: sha256:" (bytevector->nix-base32-string
 133                    (sha256 (string->utf8 "Substitutable data."))) "
 134 NarSize: 42
 135 References: bar baz
 136 Deriver: " (%store-prefix) "/foo.drv
 137 System: mips64el-linux\n"))
 138
 139 (define* (call-with-narinfo narinfo thunk
 140                             #:optional
 141                             (narinfo-directory %main-substitute-directory))
 142   "Call THUNK in a context where the directory at URL is populated with
 143 a file for NARINFO."
 144   (mkdir-p narinfo-directory)
 145   (let ((cache-directory (string-append (getenv "XDG_CACHE_HOME")
 146                                         "/guix/substitute/")))
 147     (dynamic-wind
 148       (lambda ()
 149         (when (file-exists? cache-directory)
 150           (delete-file-recursively cache-directory))
 151         (call-with-output-file (string-append narinfo-directory
 152                                               "/nix-cache-info")
 153           (lambda (port)
 154             (format port "StoreDir: ~a\nWantMassQuery: 0\n"
 155                     (%store-prefix))))
 156         (call-with-output-file (string-append narinfo-directory "/"
 157                                               "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
 158                                               ".narinfo")
 159           (cut display narinfo <>))
 160
 161         ;; Prepare the nar.
 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")
 167           (cute write-file
 168                 (string-append narinfo-directory "/example.out") <>))
 169
 170         (set! (@@ (guix scripts substitute)
 171                   %allow-unauthenticated-substitutes?)
 172               #f))
 173       thunk
 174       (lambda ()
 175         (when (file-exists? cache-directory)
 176           (delete-file-recursively cache-directory))))))
 177
 178 (define-syntax-rule (with-narinfo narinfo body ...)
 179   (call-with-narinfo narinfo (lambda () body ...)))
 180
 181 (define-syntax-rule (with-narinfo* narinfo directory body ...)
 182   (call-with-narinfo narinfo (lambda () body ...) directory))
 183
 184 ;; Transmit these options to 'guix substitute'.
 185 (substitute-urls (list (getenv "GUIX_BINARY_SUBSTITUTE_URL")))
 186
 187 (test-equal "query narinfo without signature"
 188   ""                                              ; not substitutable
 189
 190   (with-narinfo %narinfo
 191     (string-trim-both
 192      (with-output-to-string
 193        (lambda ()
 194          (with-input-from-string (string-append "have " (%store-prefix)
 195                                                 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 196            (lambda ()
 197              (guix-substitute "--query"))))))))
 198
 199 (test-equal "query narinfo with invalid hash"
 200   ;; The hash in the signature differs from the hash of %NARINFO.
 201   ""
 202
 203   (with-narinfo (string-append %narinfo "Signature: "
 204                                (signature-field "different body")
 205                                "\n")
 206     (string-trim-both
 207      (with-output-to-string
 208        (lambda ()
 209          (with-input-from-string (string-append "have " (%store-prefix)
 210                                                 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 211            (lambda ()
 212              (guix-substitute "--query"))))))))
 213
 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.
 217   ""
 218
 219   (with-narinfo (string-append "Signature: " (signature-field "") "\n"
 220                                 %narinfo "\n")
 221     (string-trim-both
 222      (with-output-to-string
 223        (lambda ()
 224          (with-input-from-string (string-append "have " (%store-prefix)
 225                                                 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 226            (lambda ()
 227              (guix-substitute "--query"))))))))
 228
 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
 232   ;; must be ignored.
 233   ""
 234
 235   (let ((prefix (string-append "StorePath: " (%store-prefix)
 236                                "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
 237 URL: example.nar
 238 Compression: none\n")))
 239     (with-narinfo (string-append prefix
 240                                  "Signature: " (signature-field prefix) "
 241 NarHash: sha256:aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
 242 NarSize: 42
 243 References: bar baz
 244 Deriver: " (%store-prefix) "/foo.drv
 245 System: mips64el-linux\n")
 246       (string-trim-both
 247        (with-output-to-string
 248          (lambda ()
 249            (with-input-from-string (string-append "have " (%store-prefix)
 250                                                   "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 251              (lambda ()
 252                (guix-substitute "--query")))))))))
 253
 254 (test-equal "query narinfo signed with authorized key"
 255   (string-append (%store-prefix) "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 256
 257   (with-narinfo (string-append %narinfo "Signature: "
 258                                (signature-field %narinfo)
 259                                "\n")
 260     (string-trim-both
 261      (with-output-to-string
 262        (lambda ()
 263          (with-input-from-string (string-append "have " (%store-prefix)
 264                                                 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 265            (lambda ()
 266              (guix-substitute "--query"))))))))
 267
 268 (test-equal "query narinfo signed with unauthorized key"
 269   ""                                              ; not substitutable
 270
 271   (with-narinfo (string-append %narinfo "Signature: "
 272                                (signature-field
 273                                 %narinfo
 274                                 #:public-key %wrong-public-key)
 275                                "\n")
 276     (string-trim-both
 277      (with-output-to-string
 278        (lambda ()
 279          (with-input-from-string (string-append "have " (%store-prefix)
 280                                                 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 281            (lambda ()
 282              (guix-substitute "--query"))))))))
 283
 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")
 290                      "foo")))
 291
 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")
 297                                "\n")
 298     (guix-substitute "--substitute"
 299                      (string-append (%store-prefix)
 300                                     "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 301                      "foo")))
 302
 303 (test-quit "substitute, unauthorized key"
 304     "no valid substitute"
 305   (with-narinfo (string-append %narinfo "Signature: "
 306                                (signature-field
 307                                 %narinfo
 308                                 #:public-key %wrong-public-key)
 309                                "\n")
 310     (guix-substitute "--substitute"
 311                      (string-append (%store-prefix)
 312                                     "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 313                      "foo")))
 314
 315 (test-equal "substitute, authorized key"
 316   "Substitutable data."
 317   (with-narinfo (string-append %narinfo "Signature: "
 318                                (signature-field %narinfo))
 319     (dynamic-wind
 320       (const #t)
 321       (lambda ()
 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))
 327       (lambda ()
 328         (false-if-exception (delete-file "substitute-retrieved"))))))
 329
 330 (test-equal "substitute, unauthorized narinfo comes first"
 331   "Substitutable data."
 332   (with-narinfo*
 333       (string-append %narinfo "Signature: "
 334                      (signature-field
 335                       %narinfo
 336                       #:public-key %wrong-public-key))
 337       %alternate-substitute-directory
 338
 339     (with-narinfo* (string-append %narinfo "Signature: "
 340                                   (signature-field %narinfo))
 341         %main-substitute-directory
 342
 343       (dynamic-wind
 344         (const #t)
 345         (lambda ()
 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
 349                                       "/example.nar"))
 350
 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))
 360         (lambda ()
 361           (false-if-exception (delete-file "substitute-retrieved")))))))
 362
 363 (test-equal "substitute, unsigned narinfo comes first"
 364   "Substitutable data."
 365   (with-narinfo* %narinfo                         ;not signed!
 366       %alternate-substitute-directory
 367
 368     (with-narinfo* (string-append %narinfo "Signature: "
 369                                   (signature-field %narinfo))
 370         %main-substitute-directory
 371
 372       (dynamic-wind
 373         (const #t)
 374         (lambda ()
 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
 378                                       "/example.nar"))
 379
 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))
 389         (lambda ()
 390           (false-if-exception (delete-file "substitute-retrieved")))))))
 391
 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:]]+"
 396                                                   %narinfo)
 397                                     'pre
 398                                     "NarHash: sha256:"
 399                                     (bytevector->nix-base32-string
 400                                      (make-bytevector 32))
 401                                     'post)
 402       %alternate-substitute-directory
 403
 404     (with-narinfo* (string-append %narinfo "Signature: "
 405                                   (signature-field %narinfo))
 406         %main-substitute-directory
 407
 408       (dynamic-wind
 409         (const #t)
 410         (lambda ()
 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
 414                                       "/example.nar"))
 415
 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))
 425         (lambda ()
 426           (false-if-exception (delete-file "substitute-retrieved")))))))
 427
 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"
 432                                                   %narinfo)
 433                                     'pre "References: " 1
 434                                     " wrong set of references\n"
 435                                     'post)
 436       %alternate-substitute-directory
 437
 438     (with-narinfo* (string-append %narinfo "Signature: "
 439                                   (signature-field %narinfo))
 440         %main-substitute-directory
 441
 442       (dynamic-wind
 443         (const #t)
 444         (lambda ()
 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
 448                                       "/example.nar"))
 449
 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))
 459         (lambda ()
 460           (false-if-exception (delete-file "substitute-retrieved")))))))
 461
 462 (test-quit "substitute, two invalid narinfos"
 463     "no valid substitute"
 464   (with-narinfo* %narinfo                         ;not signed
 465       %alternate-substitute-directory
 466
 467     (with-narinfo* (string-append %narinfo "Signature: " ;unauthorized
 468                                   (signature-field
 469                                    %narinfo
 470                                    #:public-key %wrong-public-key))
 471         %main-substitute-directory
 472
 473       (guix-substitute "--substitute"
 474                        (string-append (%store-prefix)
 475                                       "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 476                        "substitute-retrieved"))))
 477
 478 (test-end "substitute")
 479
 480 ;;; Local Variables:
 481 ;;; eval: (put 'with-narinfo 'scheme-indent-function 1)
 482 ;;; eval: (put 'with-narinfo* 'scheme-indent-function 2)
 483 ;;; eval: (put 'test-quit 'scheme-indent-function 2)
 484 ;;; End: