tests/substitute.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
   3 ;;; Copyright © 2014-2015, 2017-2019, 2021-2022 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 narinfo)
  23   #:use-module (guix base64)
  24   #:use-module (gcrypt hash)
  25   #:use-module (guix serialization)
  26   #:use-module (gcrypt pk-crypto)
  27   #:use-module (guix pki)
  28   #:use-module (guix config)
  29   #:use-module (guix base32)
  30   #:use-module ((guix store) #:select (%store-prefix))
  31   #:use-module ((guix ui) #:select (guix-warning-port))
  32   #:use-module ((guix utils)
  33                 #:select (call-with-temporary-directory
  34                           call-with-compressed-output-port))
  35   #:use-module ((guix build utils)
  36                 #:select (mkdir-p delete-file-recursively dump-port))
  37   #:use-module (guix tests http)
  38   #:use-module (rnrs bytevectors)
  39   #:use-module (rnrs io ports)
  40   #:use-module (web uri)
  41   #:use-module (ice-9 regex)
  42   #:use-module (srfi srfi-11)
  43   #:use-module (srfi srfi-26)
  44   #:use-module (srfi srfi-34)
  45   #:use-module (srfi srfi-35)
  46   #:use-module ((srfi srfi-64) #:hide (test-error)))
  47
  48 (define-syntax-rule (test-quit name error-rx exp)
  49   "Emit a test that passes when EXP throws to 'quit' with value 1, and when
  50 it writes to GUIX-WARNING-PORT a messages that matches ERROR-RX."
  51   (test-equal name
  52     '(1 #t)
  53     (let ((error-output (open-output-string)))
  54       (parameterize ((current-error-port error-output)
  55                      (guix-warning-port error-output))
  56         (catch 'quit
  57           (lambda ()
  58             exp
  59             #f)
  60           (lambda (key value)
  61             (list value
  62                   (let ((message (get-output-string error-output)))
  63                     (->bool (string-match error-rx message))))))))))
  64
  65 (define (request-substitution item destination)
  66   "Run 'guix substitute --substitute' to fetch ITEM to DESTINATION."
  67   (parameterize ((guix-warning-port (current-error-port)))
  68     (with-input-from-string (string-append "substitute " item " "
  69                                            destination "\n")
  70       (lambda ()
  71         (guix-substitute "--substitute")))))
  72
  73 (define %public-key
  74   ;; This key is known to be in the ACL by default.
  75   (call-with-input-file (string-append %config-directory "/signing-key.pub")
  76     (compose string->canonical-sexp get-string-all)))
  77
  78 (define %private-key
  79   (call-with-input-file (string-append %config-directory "/signing-key.sec")
  80     (compose string->canonical-sexp get-string-all)))
  81
  82 (define* (signature-body bv #:key (public-key %public-key))
  83   "Return the signature of BV as the base64-encoded body of a narinfo's
  84 'Signature' field."
  85   (base64-encode
  86    (string->utf8
  87     (canonical-sexp->string
  88      (signature-sexp (bytevector->hash-data (sha256 bv)
  89                                             #:key-type 'rsa)
  90                      %private-key
  91                      public-key)))))
  92
  93 (define %wrong-public-key
  94   (string->canonical-sexp "(public-key
  95  (rsa
  96   (n #00E05873AC2B168760343145918E954EE9AB73C026355693B192E01EE835261AA689E9EF46642E895BCD65C648524059FC450E4BA77A68F4C52D0E39EF0CC9359709AB6AAB153B63782201871325B0FDA19CB401CD99FD0C31A91CA9000AA90A77E82B89E036FB63BC1D3961207469B3B12468977148D376F8012BB12A4B11A8F1#)
  97   (e #010001#)
  98   )
  99  )"))
 100
 101 (define* (signature-field bv-or-str
 102                           #:key (version "1") (public-key %public-key))
 103   "Return the 'Signature' field value of bytevector/string BV-OR-STR, using
 104 PUBLIC-KEY as the signature's principal, and using VERSION as the signature
 105 version identifier.."
 106   (string-append version ";example.gnu.org;"
 107                  (signature-body (if (string? bv-or-str)
 108                                      (string->utf8 bv-or-str)
 109                                      bv-or-str)
 110                                  #:public-key public-key)))
 111
 112
 113 \f
 114 (test-begin "substitute")
 115
 116 (test-quit "not a number"
 117     "signature version"
 118   (narinfo-signature->canonical-sexp
 119    (signature-field "foo" #:version "not a number")))
 120
 121 (test-quit "wrong version number"
 122     "unsupported.*version"
 123   (narinfo-signature->canonical-sexp
 124    (signature-field "foo" #:version "2")))
 125
 126 (test-assert "valid narinfo-signature->canonical-sexp"
 127   (canonical-sexp? (narinfo-signature->canonical-sexp (signature-field "foo"))))
 128
 129
 130 \f
 131 (define %main-substitute-directory
 132   ;; The place where 'call-with-narinfo' stores its data by default.
 133   (uri-path (string->uri (getenv "GUIX_BINARY_SUBSTITUTE_URL"))))
 134
 135 (define %alternate-substitute-directory
 136   ;; Another place.
 137   (string-append (dirname %main-substitute-directory)
 138                  "/substituter-alt-data"))
 139
 140 (define %unroutable-substitute-url
 141   ;; Substitute URL with an unroutable server address, as per
 142   ;; <https://www.rfc-editor.org/rfc/rfc5737>.
 143   "http://203.0.113.1")
 144
 145
 146 (define %narinfo
 147   ;; Skeleton of the narinfo used below.
 148   (string-append "StorePath: " (%store-prefix)
 149                  "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
 150 URL: example.nar
 151 Compression: none
 152 NarHash: sha256:" (bytevector->nix-base32-string
 153                    (sha256 (string->utf8 "Substitutable data."))) "
 154 NarSize: 42
 155 References: bar baz
 156 Deriver: " (%store-prefix) "/foo.drv
 157 System: mips64el-linux\n"))
 158
 159 (define* (call-with-narinfo narinfo thunk
 160                             #:optional
 161                             (narinfo-directory %main-substitute-directory))
 162   "Call THUNK in a context where the directory at URL is populated with
 163 a file for NARINFO."
 164   (mkdir-p narinfo-directory)
 165   (let ((cache-directory (string-append (getenv "XDG_CACHE_HOME")
 166                                         "/guix/substitute/")))
 167     (dynamic-wind
 168       (lambda ()
 169         (when (file-exists? cache-directory)
 170           (delete-file-recursively cache-directory))
 171         (call-with-output-file (string-append narinfo-directory
 172                                               "/nix-cache-info")
 173           (lambda (port)
 174             (format port "StoreDir: ~a\nWantMassQuery: 0\n"
 175                     (%store-prefix))))
 176         (call-with-output-file (string-append narinfo-directory "/"
 177                                               "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
 178                                               ".narinfo")
 179           (cut display narinfo <>))
 180
 181         ;; Prepare the nar.
 182         (call-with-output-file
 183             (string-append narinfo-directory "/example.out")
 184           (cut display "Substitutable data." <>))
 185         (call-with-output-file
 186             (string-append narinfo-directory "/example.nar")
 187           (cute write-file
 188                 (string-append narinfo-directory "/example.out") <>))
 189
 190         (%allow-unauthenticated-substitutes? #f))
 191       thunk
 192       (lambda ()
 193         (when (file-exists? cache-directory)
 194           (delete-file-recursively cache-directory))))))
 195
 196 (define-syntax-rule (with-narinfo narinfo body ...)
 197   (call-with-narinfo narinfo (lambda () body ...)))
 198
 199 (define-syntax-rule (with-narinfo* narinfo directory body ...)
 200   (call-with-narinfo narinfo (lambda () body ...) directory))
 201
 202 ;; Transmit these options to 'guix substitute'.
 203 (substitute-urls (list (getenv "GUIX_BINARY_SUBSTITUTE_URL")))
 204
 205 ;; Never use file descriptor 4, unlike what happens when invoked by the
 206 ;; daemon.
 207 (%reply-file-descriptor #f)
 208
 209 \f
 210 (test-equal "query narinfo without signature"
 211   ""                                              ; not substitutable
 212
 213   (with-narinfo %narinfo
 214     (string-trim-both
 215      (with-output-to-string
 216        (lambda ()
 217          (with-input-from-string (string-append "have " (%store-prefix)
 218                                                 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 219            (lambda ()
 220              (guix-substitute "--query"))))))))
 221
 222 (test-equal "query narinfo with invalid hash"
 223   ;; The hash in the signature differs from the hash of %NARINFO.
 224   ""
 225
 226   (with-narinfo (string-append %narinfo "Signature: "
 227                                (signature-field "different body")
 228                                "\n")
 229     (string-trim-both
 230      (with-output-to-string
 231        (lambda ()
 232          (with-input-from-string (string-append "have " (%store-prefix)
 233                                                 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 234            (lambda ()
 235              (guix-substitute "--query"))))))))
 236
 237 (test-equal "query narinfo with signature over nothing"
 238   ;; The signature is computed over the empty string, not over the important
 239   ;; parts, so the narinfo must be ignored.
 240   ""
 241
 242   (with-narinfo (string-append "Signature: " (signature-field "") "\n"
 243                                 %narinfo "\n")
 244     (string-trim-both
 245      (with-output-to-string
 246        (lambda ()
 247          (with-input-from-string (string-append "have " (%store-prefix)
 248                                                 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 249            (lambda ()
 250              (guix-substitute "--query"))))))))
 251
 252 (test-equal "query narinfo with signature over irrelevant bits"
 253   ;; The signature is valid but it does not cover the
 254   ;; StorePath/NarHash/References tuple and is thus irrelevant; the narinfo
 255   ;; must be ignored.
 256   ""
 257
 258   (let ((prefix (string-append "StorePath: " (%store-prefix)
 259                                "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
 260 URL: example.nar
 261 Compression: none\n")))
 262     (with-narinfo (string-append prefix
 263                                  "Signature: " (signature-field prefix) "
 264 NarHash: sha256:aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
 265 NarSize: 42
 266 References: bar baz
 267 Deriver: " (%store-prefix) "/foo.drv
 268 System: mips64el-linux\n")
 269       (string-trim-both
 270        (with-output-to-string
 271          (lambda ()
 272            (with-input-from-string (string-append "have " (%store-prefix)
 273                                                   "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 274              (lambda ()
 275                (guix-substitute "--query")))))))))
 276
 277 (test-equal "query narinfo with signature over relevant subset"
 278   ;; The signature covers the StorePath/NarHash/References tuple, so it is
 279   ;; valid; it does not cover non-normative fields, which is fine.
 280   (string-append (%store-prefix) "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 281
 282   (let ((prefix (string-append "StorePath: " (%store-prefix)
 283                                "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
 284 NarHash: sha256:aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
 285 References: bar baz\n")))
 286     (with-narinfo (string-append prefix
 287                                  "Signature: " (signature-field prefix) "
 288 URL: example.nar
 289 Compression: none
 290 NarSize: 42
 291 Deriver: " (%store-prefix) "/foo.drv")
 292       (string-trim-both
 293        (with-output-to-string
 294          (lambda ()
 295            (with-input-from-string (string-append "have " (%store-prefix)
 296                                                   "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 297              (lambda ()
 298                (guix-substitute "--query")))))))))
 299
 300 (test-equal "query narinfo signed with authorized key"
 301   (string-append (%store-prefix) "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 302
 303   (with-narinfo (string-append %narinfo "Signature: "
 304                                (signature-field %narinfo)
 305                                "\n")
 306     (string-trim-both
 307      (with-output-to-string
 308        (lambda ()
 309          (with-input-from-string (string-append "have " (%store-prefix)
 310                                                 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 311            (lambda ()
 312              (guix-substitute "--query"))))))))
 313
 314 (test-equal "query narinfo signed with authorized key, unroutable URL first"
 315   (string-append (%store-prefix) "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 316
 317   (with-narinfo (string-append %narinfo "Signature: "
 318                                (signature-field %narinfo)
 319                                "\n")
 320     (string-trim-both
 321      (with-output-to-string
 322        (lambda ()
 323          (with-input-from-string (string-append "have " (%store-prefix)
 324                                                 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 325            (lambda ()
 326              (parameterize ((substitute-urls
 327                              (list %unroutable-substitute-url
 328                                    (string-append "file://"
 329                                                   %main-substitute-directory))))
 330                (guix-substitute "--query")))))))))
 331
 332 (test-equal "query narinfo signed with unauthorized key"
 333   ""                                              ; not substitutable
 334
 335   (with-narinfo (string-append %narinfo "Signature: "
 336                                (signature-field
 337                                 %narinfo
 338                                 #:public-key %wrong-public-key)
 339                                "\n")
 340     (string-trim-both
 341      (with-output-to-string
 342        (lambda ()
 343          (with-input-from-string (string-append "have " (%store-prefix)
 344                                                 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 345            (lambda ()
 346              (guix-substitute "--query"))))))))
 347
 348 (test-quit "substitute, no signature"
 349     "no valid substitute"
 350   (with-narinfo %narinfo
 351     (with-input-from-string (string-append "substitute "
 352                                            (%store-prefix)
 353                                            "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo"
 354                                            " foo\n")
 355       (lambda ()
 356         (guix-substitute "--substitute")))))
 357
 358 (test-quit "substitute, invalid narinfo hash"
 359     "no valid substitute"
 360   ;; The hash in the signature differs from the hash of %NARINFO.
 361   (with-narinfo (string-append %narinfo "Signature: "
 362                                (signature-field "different body")
 363                                "\n")
 364     (with-input-from-string (string-append "substitute "
 365                                            (%store-prefix)
 366                                            "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo"
 367                                            " foo\n")
 368       (lambda ()
 369         (guix-substitute "--substitute")))))
 370
 371 (test-equal "substitute, invalid hash"
 372   (string-append "hash-mismatch sha256 "
 373                  (bytevector->nix-base32-string (sha256 #vu8())) " "
 374                  (let-values (((port get-hash)
 375                                (open-hash-port (hash-algorithm sha256)))
 376                               ((content)
 377                                "Substitutable data."))
 378                    (write-file-tree "foo" port
 379                                     #:file-type+size
 380                                     (lambda _
 381                                       (values 'regular
 382                                               (string-length content)))
 383                                     #:file-port
 384                                     (lambda _
 385                                       (open-input-string content)))
 386                    (close-port port)
 387                    (bytevector->nix-base32-string (get-hash)))
 388                  "\n")
 389
 390   ;; Arrange so the actual data hash does not match the 'NarHash' field in the
 391   ;; narinfo.
 392   (with-output-to-string
 393     (lambda ()
 394       (let ((narinfo (string-append "StorePath: " (%store-prefix)
 395                                     "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-wrong-hash
 396 URL: example.nar
 397 Compression: none
 398 NarHash: sha256:" (bytevector->nix-base32-string (sha256 #vu8())) "
 399 NarSize: 42
 400 References:
 401 Deriver: " (%store-prefix) "/foo.drv
 402 System: mips64el-linux\n")))
 403         (with-narinfo (string-append narinfo "Signature: "
 404                                      (signature-field narinfo) "\n")
 405           (call-with-temporary-directory
 406            (lambda (directory)
 407              (with-input-from-string (string-append
 408                                       "substitute " (%store-prefix)
 409                                       "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-wrong-hash "
 410                                       directory "/wrong-hash\n")
 411                (lambda ()
 412                  (guix-substitute "--substitute"))))))))))
 413
 414 (test-quit "substitute, unauthorized key"
 415     "no valid substitute"
 416   (with-narinfo (string-append %narinfo "Signature: "
 417                                (signature-field
 418                                 %narinfo
 419                                 #:public-key %wrong-public-key)
 420                                "\n")
 421     (with-input-from-string (string-append "substitute "
 422                                            (%store-prefix)
 423                                            "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo"
 424                                            " foo\n")
 425       (lambda ()
 426         (guix-substitute "--substitute")))))
 427
 428 (test-equal "substitute, authorized key"
 429   '("Substitutable data." 1 #o444)
 430   (with-narinfo (string-append %narinfo "Signature: "
 431                                (signature-field %narinfo))
 432     (dynamic-wind
 433       (const #t)
 434       (lambda ()
 435         (request-substitution (string-append (%store-prefix)
 436                                              "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 437                               "substitute-retrieved")
 438         (list (call-with-input-file "substitute-retrieved" get-string-all)
 439               (stat:mtime (lstat "substitute-retrieved"))
 440               (stat:perms (lstat "substitute-retrieved"))))
 441       (lambda ()
 442         (false-if-exception (delete-file "substitute-retrieved"))))))
 443
 444 (test-equal "substitute, authorized key, first substitute URL is unroutable"
 445   '("Substitutable data." 1 #o444)
 446   (with-narinfo (string-append %narinfo "Signature: "
 447                                (signature-field %narinfo))
 448     (dynamic-wind
 449       (const #t)
 450       (lambda ()
 451         ;; Pick an unroutable URL as the first one.  This shouldn't be a
 452         ;; problem.
 453         (parameterize ((substitute-urls
 454                         (list %unroutable-substitute-url
 455                               (string-append "file://"
 456                                              %main-substitute-directory))))
 457           (request-substitution (string-append (%store-prefix)
 458                                                "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 459                                 "substitute-retrieved")
 460           (list (call-with-input-file "substitute-retrieved" get-string-all)
 461                 (stat:mtime (lstat "substitute-retrieved"))
 462                 (stat:perms (lstat "substitute-retrieved")))))
 463       (lambda ()
 464         (false-if-exception (delete-file "substitute-retrieved"))))))
 465
 466 (test-equal "substitute, unauthorized narinfo comes first"
 467   "Substitutable data."
 468   (with-narinfo*
 469       (string-append %narinfo "Signature: "
 470                      (signature-field
 471                       %narinfo
 472                       #:public-key %wrong-public-key))
 473       %alternate-substitute-directory
 474
 475     (with-narinfo* (string-append %narinfo "Signature: "
 476                                   (signature-field %narinfo))
 477         %main-substitute-directory
 478
 479       (dynamic-wind
 480         (const #t)
 481         (lambda ()
 482           ;; Remove this file so that the substitute can only be retrieved
 483           ;; from %ALTERNATE-SUBSTITUTE-DIRECTORY.
 484           (delete-file (string-append %main-substitute-directory
 485                                       "/example.nar"))
 486
 487           (parameterize ((substitute-urls
 488                           (map (cut string-append "file://" <>)
 489                                (list %alternate-substitute-directory
 490                                      %main-substitute-directory))))
 491             (request-substitution (string-append (%store-prefix)
 492                                                  "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 493                                   "substitute-retrieved"))
 494           (call-with-input-file "substitute-retrieved" get-string-all))
 495         (lambda ()
 496           (false-if-exception (delete-file "substitute-retrieved")))))))
 497
 498 (test-equal "substitute, unsigned narinfo comes first"
 499   "Substitutable data."
 500   (with-narinfo* %narinfo                         ;not signed!
 501       %alternate-substitute-directory
 502
 503     (with-narinfo* (string-append %narinfo "Signature: "
 504                                   (signature-field %narinfo))
 505         %main-substitute-directory
 506
 507       (dynamic-wind
 508         (const #t)
 509         (lambda ()
 510           ;; Remove this file so that the substitute can only be retrieved
 511           ;; from %ALTERNATE-SUBSTITUTE-DIRECTORY.
 512           (delete-file (string-append %main-substitute-directory
 513                                       "/example.nar"))
 514
 515           (parameterize ((substitute-urls
 516                           (map (cut string-append "file://" <>)
 517                                (list %alternate-substitute-directory
 518                                      %main-substitute-directory))))
 519             (request-substitution (string-append (%store-prefix)
 520                                                  "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 521                                   "substitute-retrieved"))
 522           (call-with-input-file "substitute-retrieved" get-string-all))
 523         (lambda ()
 524           (false-if-exception (delete-file "substitute-retrieved")))))))
 525
 526 (test-equal "substitute, first URL has narinfo but lacks nar, second URL unauthorized"
 527   "Substitutable data."
 528   (with-narinfo*
 529       (string-append %narinfo "Signature: "
 530                      (signature-field
 531                       %narinfo
 532                       #:public-key %wrong-public-key))
 533       %alternate-substitute-directory
 534
 535     (with-narinfo* (string-append %narinfo "Signature: "
 536                                   (signature-field %narinfo))
 537         %main-substitute-directory
 538
 539       (dynamic-wind
 540         (const #t)
 541         (lambda ()
 542           ;; Remove this file so that the substitute can only be retrieved
 543           ;; from %ALTERNATE-SUBSTITUTE-DIRECTORY.
 544           (delete-file (string-append %main-substitute-directory
 545                                       "/example.nar"))
 546
 547           (parameterize ((substitute-urls
 548                           (map (cut string-append "file://" <>)
 549                                (list %main-substitute-directory
 550                                      %alternate-substitute-directory))))
 551             (request-substitution (string-append (%store-prefix)
 552                                                  "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 553                                   "substitute-retrieved"))
 554           (call-with-input-file "substitute-retrieved" get-string-all))
 555         (lambda ()
 556           (false-if-exception (delete-file "substitute-retrieved")))))))
 557
 558 (test-equal "substitute, first URL has narinfo but nar is 404, both URLs authorized"
 559   "Substitutable data."
 560   (with-narinfo*
 561       (string-append %narinfo "Signature: "
 562                      (signature-field %narinfo))
 563       %main-substitute-directory
 564
 565     (with-http-server `((200 ,(string-append %narinfo "Signature: "
 566                                              (signature-field %narinfo)))
 567                         (404 "Sorry, nar is missing!"))
 568       (dynamic-wind
 569         (const #t)
 570         (lambda ()
 571           (parameterize ((substitute-urls
 572                           (list (%local-url)
 573                                 (string-append "file://"
 574                                                %main-substitute-directory))))
 575             (request-substitution (string-append (%store-prefix)
 576                                                  "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 577                                   "substitute-retrieved"))
 578           (call-with-input-file "substitute-retrieved" get-string-all))
 579         (lambda ()
 580           (false-if-exception (delete-file "substitute-retrieved")))))))
 581
 582 (test-equal "substitute, first URL has narinfo but nar is 404, one URL authorized"
 583   "Substitutable data."
 584   (with-narinfo*
 585       (string-append %narinfo "Signature: "
 586                      (signature-field
 587                       %narinfo
 588                       #:public-key %wrong-public-key))
 589       %main-substitute-directory
 590
 591     (with-http-server `((200 ,(string-append %narinfo "Signature: "
 592                                              (signature-field
 593                                               %narinfo
 594                                               #:public-key %wrong-public-key)))
 595                         (404 "Sorry, nar is missing!"))
 596       (let ((url1 (%local-url)))
 597         (parameterize ((%http-server-port 0))
 598           (with-http-server `((200 ,(string-append %narinfo "Signature: "
 599                                                    (signature-field %narinfo)))
 600                               (404 "Sorry, nar is missing!"))
 601             (let ((url2 (%local-url)))
 602               (dynamic-wind
 603                 (const #t)
 604                 (lambda ()
 605                   (parameterize ((substitute-urls
 606                                   (list url1 url2
 607                                         (string-append "file://"
 608                                                        %main-substitute-directory))))
 609                     (request-substitution (string-append (%store-prefix)
 610                                                          "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 611                                           "substitute-retrieved"))
 612                   (call-with-input-file "substitute-retrieved" get-string-all))
 613                 (lambda ()
 614                   (false-if-exception (delete-file "substitute-retrieved")))))))))))
 615
 616 (test-quit "substitute, narinfo is available but nar is missing"
 617     "failed to find alternative substitute"
 618   (with-narinfo*
 619       (string-append %narinfo "Signature: "
 620                      (signature-field
 621                       %narinfo
 622                       #:public-key %wrong-public-key))
 623       %main-substitute-directory
 624
 625     (with-http-server `((200 ,(string-append %narinfo "Signature: "
 626                                              (signature-field %narinfo)))
 627                         (404 "Sorry, nar is missing!"))
 628       (parameterize ((substitute-urls
 629                       (list (%local-url)
 630                             (string-append "file://"
 631                                            %main-substitute-directory))))
 632         (delete-file (string-append %main-substitute-directory
 633                                     "/example.nar"))
 634         (request-substitution (string-append (%store-prefix)
 635                                              "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 636                               "substitute-retrieved")
 637         (not (file-exists? "substitute-retrieved"))))))
 638
 639 (test-equal "substitute, first narinfo is unsigned and has wrong hash"
 640   "Substitutable data."
 641   (with-narinfo* (regexp-substitute #f
 642                                     (string-match "NarHash: [[:graph:]]+"
 643                                                   %narinfo)
 644                                     'pre
 645                                     "NarHash: sha256:"
 646                                     (bytevector->nix-base32-string
 647                                      (make-bytevector 32))
 648                                     'post)
 649       %alternate-substitute-directory
 650
 651     (with-narinfo* (string-append %narinfo "Signature: "
 652                                   (signature-field %narinfo))
 653         %main-substitute-directory
 654
 655       (dynamic-wind
 656         (const #t)
 657         (lambda ()
 658           ;; This time remove the file so that the substitute can only be
 659           ;; retrieved from %MAIN-SUBSTITUTE-DIRECTORY.
 660           (delete-file (string-append %alternate-substitute-directory
 661                                       "/example.nar"))
 662
 663           (parameterize ((substitute-urls
 664                           (map (cut string-append "file://" <>)
 665                                (list %alternate-substitute-directory
 666                                      %main-substitute-directory))))
 667             (request-substitution (string-append (%store-prefix)
 668                                                  "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 669                                   "substitute-retrieved"))
 670           (call-with-input-file "substitute-retrieved" get-string-all))
 671         (lambda ()
 672           (false-if-exception (delete-file "substitute-retrieved")))))))
 673
 674 (test-equal "substitute, first narinfo is unsigned and has wrong refs"
 675   "Substitutable data."
 676   (with-narinfo* (regexp-substitute #f
 677                                     (string-match "References: ([^\n]+)\n"
 678                                                   %narinfo)
 679                                     'pre "References: " 1
 680                                     " wrong set of references\n"
 681                                     'post)
 682       %alternate-substitute-directory
 683
 684     (with-narinfo* (string-append %narinfo "Signature: "
 685                                   (signature-field %narinfo))
 686         %main-substitute-directory
 687
 688       (dynamic-wind
 689         (const #t)
 690         (lambda ()
 691           ;; This time remove the file so that the substitute can only be
 692           ;; retrieved from %MAIN-SUBSTITUTE-DIRECTORY.
 693           (delete-file (string-append %alternate-substitute-directory
 694                                       "/example.nar"))
 695
 696           (parameterize ((substitute-urls
 697                           (map (cut string-append "file://" <>)
 698                                (list %alternate-substitute-directory
 699                                      %main-substitute-directory))))
 700             (request-substitution (string-append (%store-prefix)
 701                                                  "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 702                                   "substitute-retrieved"))
 703           (call-with-input-file "substitute-retrieved" get-string-all))
 704         (lambda ()
 705           (false-if-exception (delete-file "substitute-retrieved")))))))
 706
 707 (test-quit "substitute, two invalid narinfos"
 708     "no valid substitute"
 709   (with-narinfo* %narinfo                         ;not signed
 710       %alternate-substitute-directory
 711
 712     (with-narinfo* (string-append %narinfo "Signature: " ;unauthorized
 713                                   (signature-field
 714                                    %narinfo
 715                                    #:public-key %wrong-public-key))
 716         %main-substitute-directory
 717
 718       (with-input-from-string (string-append "substitute "
 719                                              (%store-prefix)
 720                                              "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo"
 721                                              " substitute-retrieved\n")
 722         (lambda ()
 723           (guix-substitute "--substitute"))))))
 724
 725 (test-equal "substitute, narinfo with several URLs"
 726   "Substitutable data."
 727   (let ((narinfo (string-append "StorePath: " (%store-prefix)
 728                                 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
 729 URL: example.nar.gz
 730 Compression: gzip
 731 URL: example.nar.lz
 732 Compression: lzip
 733 URL: example.nar
 734 Compression: none
 735 NarHash: sha256:" (bytevector->nix-base32-string
 736                    (sha256 (string->utf8 "Substitutable data."))) "
 737 NarSize: 42
 738 References: bar baz
 739 Deriver: " (%store-prefix) "/foo.drv
 740 System: mips64el-linux\n")))
 741     (with-narinfo (string-append narinfo "Signature: "
 742                                  (signature-field narinfo))
 743       (dynamic-wind
 744         (const #t)
 745         (lambda ()
 746           (define (compress input output compression)
 747             (call-with-output-file output
 748               (lambda (port)
 749                 (call-with-compressed-output-port compression port
 750                   (lambda (port)
 751                     (call-with-input-file input
 752                       (lambda (input)
 753                         (dump-port input port))))))))
 754
 755           (let ((nar (string-append %main-substitute-directory
 756                                     "/example.nar")))
 757             (compress nar (string-append nar ".gz") 'gzip)
 758             (compress nar (string-append nar ".lz") 'lzip))
 759
 760           (parameterize ((substitute-urls
 761                           (list (string-append "file://"
 762                                                %main-substitute-directory))))
 763             (request-substitution (string-append (%store-prefix)
 764                                                  "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 765                                   "substitute-retrieved"))
 766           (call-with-input-file "substitute-retrieved" get-string-all))
 767         (lambda ()
 768           (false-if-exception (delete-file "substitute-retrieved")))))))
 769
 770 (test-end "substitute")
 771
 772 ;;; Local Variables:
 773 ;;; eval: (put 'with-narinfo 'scheme-indent-function 1)
 774 ;;; eval: (put 'with-narinfo* 'scheme-indent-function 2)
 775 ;;; eval: (put 'test-quit 'scheme-indent-function 2)
 776 ;;; End: