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, 2019 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 utils) #:select (call-with-compressed-output-port))
  32   #:use-module ((guix build utils)
  33                 #:select (mkdir-p delete-file-recursively dump-port))
  34   #:use-module (guix tests http)
  35   #:use-module (rnrs bytevectors)
  36   #:use-module (rnrs io ports)
  37   #:use-module (web uri)
  38   #:use-module (ice-9 regex)
  39   #:use-module (srfi srfi-26)
  40   #:use-module (srfi srfi-34)
  41   #:use-module (srfi srfi-35)
  42   #:use-module ((srfi srfi-64) #:hide (test-error)))
  43
  44 (define-syntax-rule (test-quit name error-rx exp)
  45   "Emit a test that passes when EXP throws to 'quit' with value 1, and when
  46 it writes to GUIX-WARNING-PORT a messages that matches ERROR-RX."
  47   (test-equal name
  48     '(1 #t)
  49     (let ((error-output (open-output-string)))
  50       (parameterize ((guix-warning-port error-output))
  51         (catch 'quit
  52           (lambda ()
  53             exp
  54             #f)
  55           (lambda (key value)
  56             (list value
  57                   (let ((message (get-output-string error-output)))
  58                     (->bool (string-match error-rx message))))))))))
  59
  60 (define %public-key
  61   ;; This key is known to be in the ACL by default.
  62   (call-with-input-file (string-append %config-directory "/signing-key.pub")
  63     (compose string->canonical-sexp get-string-all)))
  64
  65 (define %private-key
  66   (call-with-input-file (string-append %config-directory "/signing-key.sec")
  67     (compose string->canonical-sexp get-string-all)))
  68
  69 (define* (signature-body bv #:key (public-key %public-key))
  70   "Return the signature of BV as the base64-encoded body of a narinfo's
  71 'Signature' field."
  72   (base64-encode
  73    (string->utf8
  74     (canonical-sexp->string
  75      (signature-sexp (bytevector->hash-data (sha256 bv)
  76                                             #:key-type 'rsa)
  77                      %private-key
  78                      public-key)))))
  79
  80 (define %wrong-public-key
  81   (string->canonical-sexp "(public-key
  82  (rsa
  83   (n #00E05873AC2B168760343145918E954EE9AB73C026355693B192E01EE835261AA689E9EF46642E895BCD65C648524059FC450E4BA77A68F4C52D0E39EF0CC9359709AB6AAB153B63782201871325B0FDA19CB401CD99FD0C31A91CA9000AA90A77E82B89E036FB63BC1D3961207469B3B12468977148D376F8012BB12A4B11A8F1#)
  84   (e #010001#)
  85   )
  86  )"))
  87
  88 (define* (signature-field bv-or-str
  89                           #:key (version "1") (public-key %public-key))
  90   "Return the 'Signature' field value of bytevector/string BV-OR-STR, using
  91 PUBLIC-KEY as the signature's principal, and using VERSION as the signature
  92 version identifier.."
  93   (string-append version ";example.gnu.org;"
  94                  (signature-body (if (string? bv-or-str)
  95                                      (string->utf8 bv-or-str)
  96                                      bv-or-str)
  97                                  #:public-key public-key)))
  98
  99
 100 \f
 101 (test-begin "substitute")
 102
 103 (test-quit "not a number"
 104     "signature version"
 105   (narinfo-signature->canonical-sexp
 106    (signature-field "foo" #:version "not a number")))
 107
 108 (test-quit "wrong version number"
 109     "unsupported.*version"
 110   (narinfo-signature->canonical-sexp
 111    (signature-field "foo" #:version "2")))
 112
 113 (test-assert "valid narinfo-signature->canonical-sexp"
 114   (canonical-sexp? (narinfo-signature->canonical-sexp (signature-field "foo"))))
 115
 116
 117 \f
 118 (define %main-substitute-directory
 119   ;; The place where 'call-with-narinfo' stores its data by default.
 120   (uri-path (string->uri (getenv "GUIX_BINARY_SUBSTITUTE_URL"))))
 121
 122 (define %alternate-substitute-directory
 123   ;; Another place.
 124   (string-append (dirname %main-substitute-directory)
 125                  "/substituter-alt-data"))
 126
 127 (define %narinfo
 128   ;; Skeleton of the narinfo used below.
 129   (string-append "StorePath: " (%store-prefix)
 130                  "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
 131 URL: example.nar
 132 Compression: none
 133 NarHash: sha256:" (bytevector->nix-base32-string
 134                    (sha256 (string->utf8 "Substitutable data."))) "
 135 NarSize: 42
 136 References: bar baz
 137 Deriver: " (%store-prefix) "/foo.drv
 138 System: mips64el-linux\n"))
 139
 140 (define* (call-with-narinfo narinfo thunk
 141                             #:optional
 142                             (narinfo-directory %main-substitute-directory))
 143   "Call THUNK in a context where the directory at URL is populated with
 144 a file for NARINFO."
 145   (mkdir-p narinfo-directory)
 146   (let ((cache-directory (string-append (getenv "XDG_CACHE_HOME")
 147                                         "/guix/substitute/")))
 148     (dynamic-wind
 149       (lambda ()
 150         (when (file-exists? cache-directory)
 151           (delete-file-recursively cache-directory))
 152         (call-with-output-file (string-append narinfo-directory
 153                                               "/nix-cache-info")
 154           (lambda (port)
 155             (format port "StoreDir: ~a\nWantMassQuery: 0\n"
 156                     (%store-prefix))))
 157         (call-with-output-file (string-append narinfo-directory "/"
 158                                               "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
 159                                               ".narinfo")
 160           (cut display narinfo <>))
 161
 162         ;; Prepare the nar.
 163         (call-with-output-file
 164             (string-append narinfo-directory "/example.out")
 165           (cut display "Substitutable data." <>))
 166         (call-with-output-file
 167             (string-append narinfo-directory "/example.nar")
 168           (cute write-file
 169                 (string-append narinfo-directory "/example.out") <>))
 170
 171         (%allow-unauthenticated-substitutes? #f))
 172       thunk
 173       (lambda ()
 174         (when (file-exists? cache-directory)
 175           (delete-file-recursively cache-directory))))))
 176
 177 (define-syntax-rule (with-narinfo narinfo body ...)
 178   (call-with-narinfo narinfo (lambda () body ...)))
 179
 180 (define-syntax-rule (with-narinfo* narinfo directory body ...)
 181   (call-with-narinfo narinfo (lambda () body ...) directory))
 182
 183 ;; Transmit these options to 'guix substitute'.
 184 (substitute-urls (list (getenv "GUIX_BINARY_SUBSTITUTE_URL")))
 185
 186 (test-equal "query narinfo without signature"
 187   ""                                              ; not substitutable
 188
 189   (with-narinfo %narinfo
 190     (string-trim-both
 191      (with-output-to-string
 192        (lambda ()
 193          (with-input-from-string (string-append "have " (%store-prefix)
 194                                                 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 195            (lambda ()
 196              (guix-substitute "--query"))))))))
 197
 198 (test-equal "query narinfo with invalid hash"
 199   ;; The hash in the signature differs from the hash of %NARINFO.
 200   ""
 201
 202   (with-narinfo (string-append %narinfo "Signature: "
 203                                (signature-field "different body")
 204                                "\n")
 205     (string-trim-both
 206      (with-output-to-string
 207        (lambda ()
 208          (with-input-from-string (string-append "have " (%store-prefix)
 209                                                 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 210            (lambda ()
 211              (guix-substitute "--query"))))))))
 212
 213 (test-equal "query narinfo with signature over nothing"
 214   ;; The signature is computed over the empty string, not over the important
 215   ;; parts, so the narinfo must be ignored.
 216   ""
 217
 218   (with-narinfo (string-append "Signature: " (signature-field "") "\n"
 219                                 %narinfo "\n")
 220     (string-trim-both
 221      (with-output-to-string
 222        (lambda ()
 223          (with-input-from-string (string-append "have " (%store-prefix)
 224                                                 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 225            (lambda ()
 226              (guix-substitute "--query"))))))))
 227
 228 (test-equal "query narinfo with signature over irrelevant bits"
 229   ;; The signature is valid but it does not cover the
 230   ;; StorePath/NarHash/References tuple and is thus irrelevant; the narinfo
 231   ;; must be ignored.
 232   ""
 233
 234   (let ((prefix (string-append "StorePath: " (%store-prefix)
 235                                "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
 236 URL: example.nar
 237 Compression: none\n")))
 238     (with-narinfo (string-append prefix
 239                                  "Signature: " (signature-field prefix) "
 240 NarHash: sha256:aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
 241 NarSize: 42
 242 References: bar baz
 243 Deriver: " (%store-prefix) "/foo.drv
 244 System: mips64el-linux\n")
 245       (string-trim-both
 246        (with-output-to-string
 247          (lambda ()
 248            (with-input-from-string (string-append "have " (%store-prefix)
 249                                                   "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 250              (lambda ()
 251                (guix-substitute "--query")))))))))
 252
 253 (test-equal "query narinfo signed with authorized key"
 254   (string-append (%store-prefix) "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 255
 256   (with-narinfo (string-append %narinfo "Signature: "
 257                                (signature-field %narinfo)
 258                                "\n")
 259     (string-trim-both
 260      (with-output-to-string
 261        (lambda ()
 262          (with-input-from-string (string-append "have " (%store-prefix)
 263                                                 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 264            (lambda ()
 265              (guix-substitute "--query"))))))))
 266
 267 (test-equal "query narinfo signed with unauthorized key"
 268   ""                                              ; not substitutable
 269
 270   (with-narinfo (string-append %narinfo "Signature: "
 271                                (signature-field
 272                                 %narinfo
 273                                 #:public-key %wrong-public-key)
 274                                "\n")
 275     (string-trim-both
 276      (with-output-to-string
 277        (lambda ()
 278          (with-input-from-string (string-append "have " (%store-prefix)
 279                                                 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 280            (lambda ()
 281              (guix-substitute "--query"))))))))
 282
 283 (test-quit "substitute, no signature"
 284     "no valid substitute"
 285   (with-narinfo %narinfo
 286     (guix-substitute "--substitute"
 287                      (string-append (%store-prefix)
 288                                     "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 289                      "foo")))
 290
 291 (test-quit "substitute, invalid hash"
 292     "no valid substitute"
 293   ;; The hash in the signature differs from the hash of %NARINFO.
 294   (with-narinfo (string-append %narinfo "Signature: "
 295                                (signature-field "different body")
 296                                "\n")
 297     (guix-substitute "--substitute"
 298                      (string-append (%store-prefix)
 299                                     "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 300                      "foo")))
 301
 302 (test-quit "substitute, unauthorized key"
 303     "no valid substitute"
 304   (with-narinfo (string-append %narinfo "Signature: "
 305                                (signature-field
 306                                 %narinfo
 307                                 #:public-key %wrong-public-key)
 308                                "\n")
 309     (guix-substitute "--substitute"
 310                      (string-append (%store-prefix)
 311                                     "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 312                      "foo")))
 313
 314 (test-equal "substitute, authorized key"
 315   "Substitutable data."
 316   (with-narinfo (string-append %narinfo "Signature: "
 317                                (signature-field %narinfo))
 318     (dynamic-wind
 319       (const #t)
 320       (lambda ()
 321         (guix-substitute "--substitute"
 322                          (string-append (%store-prefix)
 323                                         "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 324                          "substitute-retrieved")
 325         (call-with-input-file "substitute-retrieved" get-string-all))
 326       (lambda ()
 327         (false-if-exception (delete-file "substitute-retrieved"))))))
 328
 329 (test-equal "substitute, unauthorized narinfo comes first"
 330   "Substitutable data."
 331   (with-narinfo*
 332       (string-append %narinfo "Signature: "
 333                      (signature-field
 334                       %narinfo
 335                       #:public-key %wrong-public-key))
 336       %alternate-substitute-directory
 337
 338     (with-narinfo* (string-append %narinfo "Signature: "
 339                                   (signature-field %narinfo))
 340         %main-substitute-directory
 341
 342       (dynamic-wind
 343         (const #t)
 344         (lambda ()
 345           ;; Remove this file so that the substitute can only be retrieved
 346           ;; from %ALTERNATE-SUBSTITUTE-DIRECTORY.
 347           (delete-file (string-append %main-substitute-directory
 348                                       "/example.nar"))
 349
 350           (parameterize ((substitute-urls
 351                           (map (cut string-append "file://" <>)
 352                                (list %alternate-substitute-directory
 353                                      %main-substitute-directory))))
 354             (guix-substitute "--substitute"
 355                              (string-append (%store-prefix)
 356                                             "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 357                              "substitute-retrieved"))
 358           (call-with-input-file "substitute-retrieved" get-string-all))
 359         (lambda ()
 360           (false-if-exception (delete-file "substitute-retrieved")))))))
 361
 362 (test-equal "substitute, unsigned narinfo comes first"
 363   "Substitutable data."
 364   (with-narinfo* %narinfo                         ;not signed!
 365       %alternate-substitute-directory
 366
 367     (with-narinfo* (string-append %narinfo "Signature: "
 368                                   (signature-field %narinfo))
 369         %main-substitute-directory
 370
 371       (dynamic-wind
 372         (const #t)
 373         (lambda ()
 374           ;; Remove this file so that the substitute can only be retrieved
 375           ;; from %ALTERNATE-SUBSTITUTE-DIRECTORY.
 376           (delete-file (string-append %main-substitute-directory
 377                                       "/example.nar"))
 378
 379           (parameterize ((substitute-urls
 380                           (map (cut string-append "file://" <>)
 381                                (list %alternate-substitute-directory
 382                                      %main-substitute-directory))))
 383             (guix-substitute "--substitute"
 384                              (string-append (%store-prefix)
 385                                             "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 386                              "substitute-retrieved"))
 387           (call-with-input-file "substitute-retrieved" get-string-all))
 388         (lambda ()
 389           (false-if-exception (delete-file "substitute-retrieved")))))))
 390
 391 (test-equal "substitute, first narinfo is unsigned and has wrong hash"
 392   "Substitutable data."
 393   (with-narinfo* (regexp-substitute #f
 394                                     (string-match "NarHash: [[:graph:]]+"
 395                                                   %narinfo)
 396                                     'pre
 397                                     "NarHash: sha256:"
 398                                     (bytevector->nix-base32-string
 399                                      (make-bytevector 32))
 400                                     'post)
 401       %alternate-substitute-directory
 402
 403     (with-narinfo* (string-append %narinfo "Signature: "
 404                                   (signature-field %narinfo))
 405         %main-substitute-directory
 406
 407       (dynamic-wind
 408         (const #t)
 409         (lambda ()
 410           ;; This time remove the file so that the substitute can only be
 411           ;; retrieved from %MAIN-SUBSTITUTE-DIRECTORY.
 412           (delete-file (string-append %alternate-substitute-directory
 413                                       "/example.nar"))
 414
 415           (parameterize ((substitute-urls
 416                           (map (cut string-append "file://" <>)
 417                                (list %alternate-substitute-directory
 418                                      %main-substitute-directory))))
 419             (guix-substitute "--substitute"
 420                              (string-append (%store-prefix)
 421                                             "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 422                              "substitute-retrieved"))
 423           (call-with-input-file "substitute-retrieved" get-string-all))
 424         (lambda ()
 425           (false-if-exception (delete-file "substitute-retrieved")))))))
 426
 427 (test-equal "substitute, first narinfo is unsigned and has wrong refs"
 428   "Substitutable data."
 429   (with-narinfo* (regexp-substitute #f
 430                                     (string-match "References: ([^\n]+)\n"
 431                                                   %narinfo)
 432                                     'pre "References: " 1
 433                                     " wrong set of references\n"
 434                                     'post)
 435       %alternate-substitute-directory
 436
 437     (with-narinfo* (string-append %narinfo "Signature: "
 438                                   (signature-field %narinfo))
 439         %main-substitute-directory
 440
 441       (dynamic-wind
 442         (const #t)
 443         (lambda ()
 444           ;; This time remove the file so that the substitute can only be
 445           ;; retrieved from %MAIN-SUBSTITUTE-DIRECTORY.
 446           (delete-file (string-append %alternate-substitute-directory
 447                                       "/example.nar"))
 448
 449           (parameterize ((substitute-urls
 450                           (map (cut string-append "file://" <>)
 451                                (list %alternate-substitute-directory
 452                                      %main-substitute-directory))))
 453             (guix-substitute "--substitute"
 454                              (string-append (%store-prefix)
 455                                             "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 456                              "substitute-retrieved"))
 457           (call-with-input-file "substitute-retrieved" get-string-all))
 458         (lambda ()
 459           (false-if-exception (delete-file "substitute-retrieved")))))))
 460
 461 (test-quit "substitute, two invalid narinfos"
 462     "no valid substitute"
 463   (with-narinfo* %narinfo                         ;not signed
 464       %alternate-substitute-directory
 465
 466     (with-narinfo* (string-append %narinfo "Signature: " ;unauthorized
 467                                   (signature-field
 468                                    %narinfo
 469                                    #:public-key %wrong-public-key))
 470         %main-substitute-directory
 471
 472       (guix-substitute "--substitute"
 473                        (string-append (%store-prefix)
 474                                       "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 475                        "substitute-retrieved"))))
 476
 477 (test-equal "substitute, narinfo with several URLs"
 478   "Substitutable data."
 479   (let ((narinfo (string-append "StorePath: " (%store-prefix)
 480                                 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
 481 URL: example.nar.gz
 482 Compression: gzip
 483 URL: example.nar.lz
 484 Compression: lzip
 485 URL: example.nar
 486 Compression: none
 487 NarHash: sha256:" (bytevector->nix-base32-string
 488                    (sha256 (string->utf8 "Substitutable data."))) "
 489 NarSize: 42
 490 References: bar baz
 491 Deriver: " (%store-prefix) "/foo.drv
 492 System: mips64el-linux\n")))
 493     (with-narinfo (string-append narinfo "Signature: "
 494                                  (signature-field narinfo))
 495       (dynamic-wind
 496         (const #t)
 497         (lambda ()
 498           (define (compress input output compression)
 499             (call-with-output-file output
 500               (lambda (port)
 501                 (call-with-compressed-output-port compression port
 502                   (lambda (port)
 503                     (call-with-input-file input
 504                       (lambda (input)
 505                         (dump-port input port))))))))
 506
 507           (let ((nar (string-append %main-substitute-directory
 508                                     "/example.nar")))
 509             (compress nar (string-append nar ".gz") 'gzip)
 510             (compress nar (string-append nar ".lz") 'lzip))
 511
 512           (parameterize ((substitute-urls
 513                           (list (string-append "file://"
 514                                                %main-substitute-directory))))
 515             (guix-substitute "--substitute"
 516                              (string-append (%store-prefix)
 517                                             "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 518                              "substitute-retrieved"))
 519           (call-with-input-file "substitute-retrieved" get-string-all))
 520         (lambda ()
 521           (false-if-exception (delete-file "substitute-retrieved")))))))
 522
 523 (test-end "substitute")
 524
 525 ;;; Local Variables:
 526 ;;; eval: (put 'with-narinfo 'scheme-indent-function 1)
 527 ;;; eval: (put 'with-narinfo* 'scheme-indent-function 2)
 528 ;;; eval: (put 'test-quit 'scheme-indent-function 2)
 529 ;;; End: