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