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 %narinfo
 141   ;; Skeleton of the narinfo used below.
 142   (string-append "StorePath: " (%store-prefix)
 143                  "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
 144 URL: example.nar
 145 Compression: none
 146 NarHash: sha256:" (bytevector->nix-base32-string
 147                    (sha256 (string->utf8 "Substitutable data."))) "
 148 NarSize: 42
 149 References: bar baz
 150 Deriver: " (%store-prefix) "/foo.drv
 151 System: mips64el-linux\n"))
 152
 153 (define* (call-with-narinfo narinfo thunk
 154                             #:optional
 155                             (narinfo-directory %main-substitute-directory))
 156   "Call THUNK in a context where the directory at URL is populated with
 157 a file for NARINFO."
 158   (mkdir-p narinfo-directory)
 159   (let ((cache-directory (string-append (getenv "XDG_CACHE_HOME")
 160                                         "/guix/substitute/")))
 161     (dynamic-wind
 162       (lambda ()
 163         (when (file-exists? cache-directory)
 164           (delete-file-recursively cache-directory))
 165         (call-with-output-file (string-append narinfo-directory
 166                                               "/nix-cache-info")
 167           (lambda (port)
 168             (format port "StoreDir: ~a\nWantMassQuery: 0\n"
 169                     (%store-prefix))))
 170         (call-with-output-file (string-append narinfo-directory "/"
 171                                               "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
 172                                               ".narinfo")
 173           (cut display narinfo <>))
 174
 175         ;; Prepare the nar.
 176         (call-with-output-file
 177             (string-append narinfo-directory "/example.out")
 178           (cut display "Substitutable data." <>))
 179         (call-with-output-file
 180             (string-append narinfo-directory "/example.nar")
 181           (cute write-file
 182                 (string-append narinfo-directory "/example.out") <>))
 183
 184         (%allow-unauthenticated-substitutes? #f))
 185       thunk
 186       (lambda ()
 187         (when (file-exists? cache-directory)
 188           (delete-file-recursively cache-directory))))))
 189
 190 (define-syntax-rule (with-narinfo narinfo body ...)
 191   (call-with-narinfo narinfo (lambda () body ...)))
 192
 193 (define-syntax-rule (with-narinfo* narinfo directory body ...)
 194   (call-with-narinfo narinfo (lambda () body ...) directory))
 195
 196 ;; Transmit these options to 'guix substitute'.
 197 (substitute-urls (list (getenv "GUIX_BINARY_SUBSTITUTE_URL")))
 198
 199 ;; Never use file descriptor 4, unlike what happens when invoked by the
 200 ;; daemon.
 201 (%reply-file-descriptor #f)
 202
 203 \f
 204 (test-equal "query narinfo without signature"
 205   ""                                              ; not substitutable
 206
 207   (with-narinfo %narinfo
 208     (string-trim-both
 209      (with-output-to-string
 210        (lambda ()
 211          (with-input-from-string (string-append "have " (%store-prefix)
 212                                                 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 213            (lambda ()
 214              (guix-substitute "--query"))))))))
 215
 216 (test-equal "query narinfo with invalid hash"
 217   ;; The hash in the signature differs from the hash of %NARINFO.
 218   ""
 219
 220   (with-narinfo (string-append %narinfo "Signature: "
 221                                (signature-field "different body")
 222                                "\n")
 223     (string-trim-both
 224      (with-output-to-string
 225        (lambda ()
 226          (with-input-from-string (string-append "have " (%store-prefix)
 227                                                 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 228            (lambda ()
 229              (guix-substitute "--query"))))))))
 230
 231 (test-equal "query narinfo with signature over nothing"
 232   ;; The signature is computed over the empty string, not over the important
 233   ;; parts, so the narinfo must be ignored.
 234   ""
 235
 236   (with-narinfo (string-append "Signature: " (signature-field "") "\n"
 237                                 %narinfo "\n")
 238     (string-trim-both
 239      (with-output-to-string
 240        (lambda ()
 241          (with-input-from-string (string-append "have " (%store-prefix)
 242                                                 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 243            (lambda ()
 244              (guix-substitute "--query"))))))))
 245
 246 (test-equal "query narinfo with signature over irrelevant bits"
 247   ;; The signature is valid but it does not cover the
 248   ;; StorePath/NarHash/References tuple and is thus irrelevant; the narinfo
 249   ;; must be ignored.
 250   ""
 251
 252   (let ((prefix (string-append "StorePath: " (%store-prefix)
 253                                "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
 254 URL: example.nar
 255 Compression: none\n")))
 256     (with-narinfo (string-append prefix
 257                                  "Signature: " (signature-field prefix) "
 258 NarHash: sha256:aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
 259 NarSize: 42
 260 References: bar baz
 261 Deriver: " (%store-prefix) "/foo.drv
 262 System: mips64el-linux\n")
 263       (string-trim-both
 264        (with-output-to-string
 265          (lambda ()
 266            (with-input-from-string (string-append "have " (%store-prefix)
 267                                                   "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 268              (lambda ()
 269                (guix-substitute "--query")))))))))
 270
 271 (test-equal "query narinfo with signature over relevant subset"
 272   ;; The signature covers the StorePath/NarHash/References tuple, so it is
 273   ;; valid; it does not cover non-normative fields, which is fine.
 274   (string-append (%store-prefix) "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 275
 276   (let ((prefix (string-append "StorePath: " (%store-prefix)
 277                                "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
 278 NarHash: sha256:aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
 279 References: bar baz\n")))
 280     (with-narinfo (string-append prefix
 281                                  "Signature: " (signature-field prefix) "
 282 URL: example.nar
 283 Compression: none
 284 NarSize: 42
 285 Deriver: " (%store-prefix) "/foo.drv")
 286       (string-trim-both
 287        (with-output-to-string
 288          (lambda ()
 289            (with-input-from-string (string-append "have " (%store-prefix)
 290                                                   "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 291              (lambda ()
 292                (guix-substitute "--query")))))))))
 293
 294 (test-equal "query narinfo signed with authorized key"
 295   (string-append (%store-prefix) "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 296
 297   (with-narinfo (string-append %narinfo "Signature: "
 298                                (signature-field %narinfo)
 299                                "\n")
 300     (string-trim-both
 301      (with-output-to-string
 302        (lambda ()
 303          (with-input-from-string (string-append "have " (%store-prefix)
 304                                                 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 305            (lambda ()
 306              (guix-substitute "--query"))))))))
 307
 308 (test-equal "query narinfo signed with unauthorized key"
 309   ""                                              ; not substitutable
 310
 311   (with-narinfo (string-append %narinfo "Signature: "
 312                                (signature-field
 313                                 %narinfo
 314                                 #:public-key %wrong-public-key)
 315                                "\n")
 316     (string-trim-both
 317      (with-output-to-string
 318        (lambda ()
 319          (with-input-from-string (string-append "have " (%store-prefix)
 320                                                 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 321            (lambda ()
 322              (guix-substitute "--query"))))))))
 323
 324 (test-quit "substitute, no signature"
 325     "no valid substitute"
 326   (with-narinfo %narinfo
 327     (with-input-from-string (string-append "substitute "
 328                                            (%store-prefix)
 329                                            "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo"
 330                                            " foo\n")
 331       (lambda ()
 332         (guix-substitute "--substitute")))))
 333
 334 (test-quit "substitute, invalid narinfo hash"
 335     "no valid substitute"
 336   ;; The hash in the signature differs from the hash of %NARINFO.
 337   (with-narinfo (string-append %narinfo "Signature: "
 338                                (signature-field "different body")
 339                                "\n")
 340     (with-input-from-string (string-append "substitute "
 341                                            (%store-prefix)
 342                                            "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo"
 343                                            " foo\n")
 344       (lambda ()
 345         (guix-substitute "--substitute")))))
 346
 347 (test-equal "substitute, invalid hash"
 348   (string-append "hash-mismatch sha256 "
 349                  (bytevector->nix-base32-string (sha256 #vu8())) " "
 350                  (let-values (((port get-hash)
 351                                (open-hash-port (hash-algorithm sha256)))
 352                               ((content)
 353                                "Substitutable data."))
 354                    (write-file-tree "foo" port
 355                                     #:file-type+size
 356                                     (lambda _
 357                                       (values 'regular
 358                                               (string-length content)))
 359                                     #:file-port
 360                                     (lambda _
 361                                       (open-input-string content)))
 362                    (close-port port)
 363                    (bytevector->nix-base32-string (get-hash)))
 364                  "\n")
 365
 366   ;; Arrange so the actual data hash does not match the 'NarHash' field in the
 367   ;; narinfo.
 368   (with-output-to-string
 369     (lambda ()
 370       (let ((narinfo (string-append "StorePath: " (%store-prefix)
 371                                     "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-wrong-hash
 372 URL: example.nar
 373 Compression: none
 374 NarHash: sha256:" (bytevector->nix-base32-string (sha256 #vu8())) "
 375 NarSize: 42
 376 References:
 377 Deriver: " (%store-prefix) "/foo.drv
 378 System: mips64el-linux\n")))
 379         (with-narinfo (string-append narinfo "Signature: "
 380                                      (signature-field narinfo) "\n")
 381           (call-with-temporary-directory
 382            (lambda (directory)
 383              (with-input-from-string (string-append
 384                                       "substitute " (%store-prefix)
 385                                       "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-wrong-hash "
 386                                       directory "/wrong-hash\n")
 387                (lambda ()
 388                  (guix-substitute "--substitute"))))))))))
 389
 390 (test-quit "substitute, unauthorized key"
 391     "no valid substitute"
 392   (with-narinfo (string-append %narinfo "Signature: "
 393                                (signature-field
 394                                 %narinfo
 395                                 #:public-key %wrong-public-key)
 396                                "\n")
 397     (with-input-from-string (string-append "substitute "
 398                                            (%store-prefix)
 399                                            "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo"
 400                                            " foo\n")
 401       (lambda ()
 402         (guix-substitute "--substitute")))))
 403
 404 (test-equal "substitute, authorized key"
 405   '("Substitutable data." 1 #o444)
 406   (with-narinfo (string-append %narinfo "Signature: "
 407                                (signature-field %narinfo))
 408     (dynamic-wind
 409       (const #t)
 410       (lambda ()
 411         (request-substitution (string-append (%store-prefix)
 412                                              "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 413                               "substitute-retrieved")
 414         (list (call-with-input-file "substitute-retrieved" get-string-all)
 415               (stat:mtime (lstat "substitute-retrieved"))
 416               (stat:perms (lstat "substitute-retrieved"))))
 417       (lambda ()
 418         (false-if-exception (delete-file "substitute-retrieved"))))))
 419
 420 (test-equal "substitute, unauthorized narinfo comes first"
 421   "Substitutable data."
 422   (with-narinfo*
 423       (string-append %narinfo "Signature: "
 424                      (signature-field
 425                       %narinfo
 426                       #:public-key %wrong-public-key))
 427       %alternate-substitute-directory
 428
 429     (with-narinfo* (string-append %narinfo "Signature: "
 430                                   (signature-field %narinfo))
 431         %main-substitute-directory
 432
 433       (dynamic-wind
 434         (const #t)
 435         (lambda ()
 436           ;; Remove this file so that the substitute can only be retrieved
 437           ;; from %ALTERNATE-SUBSTITUTE-DIRECTORY.
 438           (delete-file (string-append %main-substitute-directory
 439                                       "/example.nar"))
 440
 441           (parameterize ((substitute-urls
 442                           (map (cut string-append "file://" <>)
 443                                (list %alternate-substitute-directory
 444                                      %main-substitute-directory))))
 445             (request-substitution (string-append (%store-prefix)
 446                                                  "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 447                                   "substitute-retrieved"))
 448           (call-with-input-file "substitute-retrieved" get-string-all))
 449         (lambda ()
 450           (false-if-exception (delete-file "substitute-retrieved")))))))
 451
 452 (test-equal "substitute, unsigned narinfo comes first"
 453   "Substitutable data."
 454   (with-narinfo* %narinfo                         ;not signed!
 455       %alternate-substitute-directory
 456
 457     (with-narinfo* (string-append %narinfo "Signature: "
 458                                   (signature-field %narinfo))
 459         %main-substitute-directory
 460
 461       (dynamic-wind
 462         (const #t)
 463         (lambda ()
 464           ;; Remove this file so that the substitute can only be retrieved
 465           ;; from %ALTERNATE-SUBSTITUTE-DIRECTORY.
 466           (delete-file (string-append %main-substitute-directory
 467                                       "/example.nar"))
 468
 469           (parameterize ((substitute-urls
 470                           (map (cut string-append "file://" <>)
 471                                (list %alternate-substitute-directory
 472                                      %main-substitute-directory))))
 473             (request-substitution (string-append (%store-prefix)
 474                                                  "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 475                                   "substitute-retrieved"))
 476           (call-with-input-file "substitute-retrieved" get-string-all))
 477         (lambda ()
 478           (false-if-exception (delete-file "substitute-retrieved")))))))
 479
 480 (test-equal "substitute, first narinfo is unsigned and has wrong hash"
 481   "Substitutable data."
 482   (with-narinfo* (regexp-substitute #f
 483                                     (string-match "NarHash: [[:graph:]]+"
 484                                                   %narinfo)
 485                                     'pre
 486                                     "NarHash: sha256:"
 487                                     (bytevector->nix-base32-string
 488                                      (make-bytevector 32))
 489                                     'post)
 490       %alternate-substitute-directory
 491
 492     (with-narinfo* (string-append %narinfo "Signature: "
 493                                   (signature-field %narinfo))
 494         %main-substitute-directory
 495
 496       (dynamic-wind
 497         (const #t)
 498         (lambda ()
 499           ;; This time remove the file so that the substitute can only be
 500           ;; retrieved from %MAIN-SUBSTITUTE-DIRECTORY.
 501           (delete-file (string-append %alternate-substitute-directory
 502                                       "/example.nar"))
 503
 504           (parameterize ((substitute-urls
 505                           (map (cut string-append "file://" <>)
 506                                (list %alternate-substitute-directory
 507                                      %main-substitute-directory))))
 508             (request-substitution (string-append (%store-prefix)
 509                                                  "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 510                                   "substitute-retrieved"))
 511           (call-with-input-file "substitute-retrieved" get-string-all))
 512         (lambda ()
 513           (false-if-exception (delete-file "substitute-retrieved")))))))
 514
 515 (test-equal "substitute, first narinfo is unsigned and has wrong refs"
 516   "Substitutable data."
 517   (with-narinfo* (regexp-substitute #f
 518                                     (string-match "References: ([^\n]+)\n"
 519                                                   %narinfo)
 520                                     'pre "References: " 1
 521                                     " wrong set of references\n"
 522                                     'post)
 523       %alternate-substitute-directory
 524
 525     (with-narinfo* (string-append %narinfo "Signature: "
 526                                   (signature-field %narinfo))
 527         %main-substitute-directory
 528
 529       (dynamic-wind
 530         (const #t)
 531         (lambda ()
 532           ;; This time remove the file so that the substitute can only be
 533           ;; retrieved from %MAIN-SUBSTITUTE-DIRECTORY.
 534           (delete-file (string-append %alternate-substitute-directory
 535                                       "/example.nar"))
 536
 537           (parameterize ((substitute-urls
 538                           (map (cut string-append "file://" <>)
 539                                (list %alternate-substitute-directory
 540                                      %main-substitute-directory))))
 541             (request-substitution (string-append (%store-prefix)
 542                                                  "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 543                                   "substitute-retrieved"))
 544           (call-with-input-file "substitute-retrieved" get-string-all))
 545         (lambda ()
 546           (false-if-exception (delete-file "substitute-retrieved")))))))
 547
 548 (test-quit "substitute, two invalid narinfos"
 549     "no valid substitute"
 550   (with-narinfo* %narinfo                         ;not signed
 551       %alternate-substitute-directory
 552
 553     (with-narinfo* (string-append %narinfo "Signature: " ;unauthorized
 554                                   (signature-field
 555                                    %narinfo
 556                                    #:public-key %wrong-public-key))
 557         %main-substitute-directory
 558
 559       (with-input-from-string (string-append "substitute "
 560                                              (%store-prefix)
 561                                              "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo"
 562                                              " substitute-retrieved\n")
 563         (lambda ()
 564           (guix-substitute "--substitute"))))))
 565
 566 (test-equal "substitute, narinfo with several URLs"
 567   "Substitutable data."
 568   (let ((narinfo (string-append "StorePath: " (%store-prefix)
 569                                 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
 570 URL: example.nar.gz
 571 Compression: gzip
 572 URL: example.nar.lz
 573 Compression: lzip
 574 URL: example.nar
 575 Compression: none
 576 NarHash: sha256:" (bytevector->nix-base32-string
 577                    (sha256 (string->utf8 "Substitutable data."))) "
 578 NarSize: 42
 579 References: bar baz
 580 Deriver: " (%store-prefix) "/foo.drv
 581 System: mips64el-linux\n")))
 582     (with-narinfo (string-append narinfo "Signature: "
 583                                  (signature-field narinfo))
 584       (dynamic-wind
 585         (const #t)
 586         (lambda ()
 587           (define (compress input output compression)
 588             (call-with-output-file output
 589               (lambda (port)
 590                 (call-with-compressed-output-port compression port
 591                   (lambda (port)
 592                     (call-with-input-file input
 593                       (lambda (input)
 594                         (dump-port input port))))))))
 595
 596           (let ((nar (string-append %main-substitute-directory
 597                                     "/example.nar")))
 598             (compress nar (string-append nar ".gz") 'gzip)
 599             (compress nar (string-append nar ".lz") 'lzip))
 600
 601           (parameterize ((substitute-urls
 602                           (list (string-append "file://"
 603                                                %main-substitute-directory))))
 604             (request-substitution (string-append (%store-prefix)
 605                                                  "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 606                                   "substitute-retrieved"))
 607           (call-with-input-file "substitute-retrieved" get-string-all))
 608         (lambda ()
 609           (false-if-exception (delete-file "substitute-retrieved")))))))
 610
 611 (test-end "substitute")
 612
 613 ;;; Local Variables:
 614 ;;; eval: (put 'with-narinfo 'scheme-indent-function 1)
 615 ;;; eval: (put 'with-narinfo* 'scheme-indent-function 2)
 616 ;;; eval: (put 'test-quit 'scheme-indent-function 2)
 617 ;;; End: