tests/substitute.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
   3 ;;; Copyright © 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (test-substitute)
  21   #:use-module (guix scripts substitute)
  22   #:use-module (guix base64)
  23   #:use-module (gcrypt hash)
  24   #:use-module (guix serialization)
  25   #:use-module (gcrypt pk-crypto)
  26   #:use-module (guix pki)
  27   #:use-module (guix config)
  28   #:use-module (guix base32)
  29   #:use-module ((guix store) #:select (%store-prefix))
  30   #:use-module ((guix ui) #:select (guix-warning-port))
  31   #:use-module ((guix build utils)
  32                 #:select (mkdir-p delete-file-recursively))
  33   #:use-module (guix tests http)
  34   #:use-module (rnrs bytevectors)
  35   #:use-module (rnrs io ports)
  36   #:use-module (web uri)
  37   #:use-module (ice-9 regex)
  38   #:use-module (srfi srfi-26)
  39   #:use-module (srfi srfi-34)
  40   #:use-module (srfi srfi-35)
  41   #:use-module ((srfi srfi-64) #:hide (test-error)))
  42
  43 (define-syntax-rule (test-quit name error-rx exp)
  44   "Emit a test that passes when EXP throws to 'quit' with value 1, and when
  45 it writes to GUIX-WARNING-PORT a messages that matches ERROR-RX."
  46   (test-equal name
  47     '(1 #t)
  48     (let ((error-output (open-output-string)))
  49       (parameterize ((guix-warning-port error-output))
  50         (catch 'quit
  51           (lambda ()
  52             exp
  53             #f)
  54           (lambda (key value)
  55             (list value
  56                   (let ((message (get-output-string error-output)))
  57                     (->bool (string-match error-rx message))))))))))
  58
  59 (define %public-key
  60   ;; This key is known to be in the ACL by default.
  61   (call-with-input-file (string-append %config-directory "/signing-key.pub")
  62     (compose string->canonical-sexp get-string-all)))
  63
  64 (define %private-key
  65   (call-with-input-file (string-append %config-directory "/signing-key.sec")
  66     (compose string->canonical-sexp get-string-all)))
  67
  68 (define* (signature-body bv #:key (public-key %public-key))
  69   "Return the signature of BV as the base64-encoded body of a narinfo's
  70 'Signature' field."
  71   (base64-encode
  72    (string->utf8
  73     (canonical-sexp->string
  74      (signature-sexp (bytevector->hash-data (sha256 bv)
  75                                             #:key-type 'rsa)
  76                      %private-key
  77                      public-key)))))
  78
  79 (define %wrong-public-key
  80   (string->canonical-sexp "(public-key
  81  (rsa
  82   (n #00E05873AC2B168760343145918E954EE9AB73C026355693B192E01EE835261AA689E9EF46642E895BCD65C648524059FC450E4BA77A68F4C52D0E39EF0CC9359709AB6AAB153B63782201871325B0FDA19CB401CD99FD0C31A91CA9000AA90A77E82B89E036FB63BC1D3961207469B3B12468977148D376F8012BB12A4B11A8F1#)
  83   (e #010001#)
  84   )
  85  )"))
  86
  87 (define* (signature-field bv-or-str
  88                           #:key (version "1") (public-key %public-key))
  89   "Return the 'Signature' field value of bytevector/string BV-OR-STR, using
  90 PUBLIC-KEY as the signature's principal, and using VERSION as the signature
  91 version identifier.."
  92   (string-append version ";example.gnu.org;"
  93                  (signature-body (if (string? bv-or-str)
  94                                      (string->utf8 bv-or-str)
  95                                      bv-or-str)
  96                                  #:public-key public-key)))
  97
  98
  99 \f
 100 (test-begin "substitute")
 101
 102 (test-quit "not a number"
 103     "signature version"
 104   (narinfo-signature->canonical-sexp
 105    (signature-field "foo" #:version "not a number")))
 106
 107 (test-quit "wrong version number"
 108     "unsupported.*version"
 109   (narinfo-signature->canonical-sexp
 110    (signature-field "foo" #:version "2")))
 111
 112 (test-assert "valid narinfo-signature->canonical-sexp"
 113   (canonical-sexp? (narinfo-signature->canonical-sexp (signature-field "foo"))))
 114
 115
 116 \f
 117 (define %main-substitute-directory
 118   ;; The place where 'call-with-narinfo' stores its data by default.
 119   (uri-path (string->uri (getenv "GUIX_BINARY_SUBSTITUTE_URL"))))
 120
 121 (define %alternate-substitute-directory
 122   ;; Another place.
 123   (string-append (dirname %main-substitute-directory)
 124                  "/substituter-alt-data"))
 125
 126 (define %narinfo
 127   ;; Skeleton of the narinfo used below.
 128   (string-append "StorePath: " (%store-prefix)
 129                  "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
 130 URL: example.nar
 131 Compression: none
 132 NarHash: sha256:" (bytevector->nix-base32-string
 133                    (sha256 (string->utf8 "Substitutable data."))) "
 134 NarSize: 42
 135 References: bar baz
 136 Deriver: " (%store-prefix) "/foo.drv
 137 System: mips64el-linux\n"))
 138
 139 (define* (call-with-narinfo narinfo thunk
 140                             #:optional
 141                             (narinfo-directory %main-substitute-directory))
 142   "Call THUNK in a context where the directory at URL is populated with
 143 a file for NARINFO."
 144   (mkdir-p narinfo-directory)
 145   (let ((cache-directory (string-append (getenv "XDG_CACHE_HOME")
 146                                         "/guix/substitute/")))
 147     (dynamic-wind
 148       (lambda ()
 149         (when (file-exists? cache-directory)
 150           (delete-file-recursively cache-directory))
 151         (call-with-output-file (string-append narinfo-directory
 152                                               "/nix-cache-info")
 153           (lambda (port)
 154             (format port "StoreDir: ~a\nWantMassQuery: 0\n"
 155                     (%store-prefix))))
 156         (call-with-output-file (string-append narinfo-directory "/"
 157                                               "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
 158                                               ".narinfo")
 159           (cut display narinfo <>))
 160
 161         ;; Prepare the nar.
 162         (call-with-output-file
 163             (string-append narinfo-directory "/example.out")
 164           (cut display "Substitutable data." <>))
 165         (call-with-output-file
 166             (string-append narinfo-directory "/example.nar")
 167           (cute write-file
 168                 (string-append narinfo-directory "/example.out") <>))
 169
 170         (set! (@@ (guix scripts substitute)
 171                   %allow-unauthenticated-substitutes?)
 172               #f))
 173       thunk
 174       (lambda ()
 175         (when (file-exists? cache-directory)
 176           (delete-file-recursively cache-directory))))))
 177
 178 (define-syntax-rule (with-narinfo narinfo body ...)
 179   (call-with-narinfo narinfo (lambda () body ...)))
 180
 181 (define-syntax-rule (with-narinfo* narinfo directory body ...)
 182   (call-with-narinfo narinfo (lambda () body ...) directory))
 183
 184 ;; Transmit these options to 'guix substitute'.
 185 (substitute-urls (list (getenv "GUIX_BINARY_SUBSTITUTE_URL")))
 186
 187 (test-equal "query narinfo without signature"
 188   ""                                              ; not substitutable
 189
 190   (with-narinfo %narinfo
 191     (string-trim-both
 192      (with-output-to-string
 193        (lambda ()
 194          (with-input-from-string (string-append "have " (%store-prefix)
 195                                                 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 196            (lambda ()
 197              (guix-substitute "--query"))))))))
 198
 199 (test-equal "query narinfo with invalid hash"
 200   ;; The hash in the signature differs from the hash of %NARINFO.
 201   ""
 202
 203   (with-narinfo (string-append %narinfo "Signature: "
 204                                (signature-field "different body")
 205                                "\n")
 206     (string-trim-both
 207      (with-output-to-string
 208        (lambda ()
 209          (with-input-from-string (string-append "have " (%store-prefix)
 210                                                 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 211            (lambda ()
 212              (guix-substitute "--query"))))))))
 213
 214 (test-equal "query narinfo signed with authorized key"
 215   (string-append (%store-prefix) "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 216
 217   (with-narinfo (string-append %narinfo "Signature: "
 218                                (signature-field %narinfo)
 219                                "\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 signed with unauthorized key"
 229   ""                                              ; not substitutable
 230
 231   (with-narinfo (string-append %narinfo "Signature: "
 232                                (signature-field
 233                                 %narinfo
 234                                 #:public-key %wrong-public-key)
 235                                "\n")
 236     (string-trim-both
 237      (with-output-to-string
 238        (lambda ()
 239          (with-input-from-string (string-append "have " (%store-prefix)
 240                                                 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 241            (lambda ()
 242              (guix-substitute "--query"))))))))
 243
 244 (test-quit "substitute, no signature"
 245     "no valid substitute"
 246   (with-narinfo %narinfo
 247     (guix-substitute "--substitute"
 248                      (string-append (%store-prefix)
 249                                     "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 250                      "foo")))
 251
 252 (test-quit "substitute, invalid hash"
 253     "no valid substitute"
 254   ;; The hash in the signature differs from the hash of %NARINFO.
 255   (with-narinfo (string-append %narinfo "Signature: "
 256                                (signature-field "different body")
 257                                "\n")
 258     (guix-substitute "--substitute"
 259                      (string-append (%store-prefix)
 260                                     "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 261                      "foo")))
 262
 263 (test-quit "substitute, unauthorized key"
 264     "no valid substitute"
 265   (with-narinfo (string-append %narinfo "Signature: "
 266                                (signature-field
 267                                 %narinfo
 268                                 #:public-key %wrong-public-key)
 269                                "\n")
 270     (guix-substitute "--substitute"
 271                      (string-append (%store-prefix)
 272                                     "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 273                      "foo")))
 274
 275 (test-equal "substitute, authorized key"
 276   "Substitutable data."
 277   (with-narinfo (string-append %narinfo "Signature: "
 278                                (signature-field %narinfo))
 279     (dynamic-wind
 280       (const #t)
 281       (lambda ()
 282         (guix-substitute "--substitute"
 283                          (string-append (%store-prefix)
 284                                         "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 285                          "substitute-retrieved")
 286         (call-with-input-file "substitute-retrieved" get-string-all))
 287       (lambda ()
 288         (false-if-exception (delete-file "substitute-retrieved"))))))
 289
 290 (test-equal "substitute, unauthorized narinfo comes first"
 291   "Substitutable data."
 292   (with-narinfo*
 293       (string-append %narinfo "Signature: "
 294                      (signature-field
 295                       %narinfo
 296                       #:public-key %wrong-public-key))
 297       %alternate-substitute-directory
 298
 299     (with-narinfo* (string-append %narinfo "Signature: "
 300                                   (signature-field %narinfo))
 301         %main-substitute-directory
 302
 303       (dynamic-wind
 304         (const #t)
 305         (lambda ()
 306           ;; Remove this file so that the substitute can only be retrieved
 307           ;; from %ALTERNATE-SUBSTITUTE-DIRECTORY.
 308           (delete-file (string-append %main-substitute-directory
 309                                       "/example.nar"))
 310
 311           (parameterize ((substitute-urls
 312                           (map (cut string-append "file://" <>)
 313                                (list %alternate-substitute-directory
 314                                      %main-substitute-directory))))
 315             (guix-substitute "--substitute"
 316                              (string-append (%store-prefix)
 317                                             "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 318                              "substitute-retrieved"))
 319           (call-with-input-file "substitute-retrieved" get-string-all))
 320         (lambda ()
 321           (false-if-exception (delete-file "substitute-retrieved")))))))
 322
 323 (test-equal "substitute, unsigned narinfo comes first"
 324   "Substitutable data."
 325   (with-narinfo* %narinfo                         ;not signed!
 326       %alternate-substitute-directory
 327
 328     (with-narinfo* (string-append %narinfo "Signature: "
 329                                   (signature-field %narinfo))
 330         %main-substitute-directory
 331
 332       (dynamic-wind
 333         (const #t)
 334         (lambda ()
 335           ;; Remove this file so that the substitute can only be retrieved
 336           ;; from %ALTERNATE-SUBSTITUTE-DIRECTORY.
 337           (delete-file (string-append %main-substitute-directory
 338                                       "/example.nar"))
 339
 340           (parameterize ((substitute-urls
 341                           (map (cut string-append "file://" <>)
 342                                (list %alternate-substitute-directory
 343                                      %main-substitute-directory))))
 344             (guix-substitute "--substitute"
 345                              (string-append (%store-prefix)
 346                                             "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 347                              "substitute-retrieved"))
 348           (call-with-input-file "substitute-retrieved" get-string-all))
 349         (lambda ()
 350           (false-if-exception (delete-file "substitute-retrieved")))))))
 351
 352 (test-equal "substitute, first narinfo is unsigned and has wrong hash"
 353   "Substitutable data."
 354   (with-narinfo* (regexp-substitute #f
 355                                     (string-match "NarHash: [[:graph:]]+"
 356                                                   %narinfo)
 357                                     'pre
 358                                     "NarHash: sha256:"
 359                                     (bytevector->nix-base32-string
 360                                      (make-bytevector 32))
 361                                     'post)
 362       %alternate-substitute-directory
 363
 364     (with-narinfo* (string-append %narinfo "Signature: "
 365                                   (signature-field %narinfo))
 366         %main-substitute-directory
 367
 368       (dynamic-wind
 369         (const #t)
 370         (lambda ()
 371           ;; This time remove the file so that the substitute can only be
 372           ;; retrieved from %MAIN-SUBSTITUTE-DIRECTORY.
 373           (delete-file (string-append %alternate-substitute-directory
 374                                       "/example.nar"))
 375
 376           (parameterize ((substitute-urls
 377                           (map (cut string-append "file://" <>)
 378                                (list %alternate-substitute-directory
 379                                      %main-substitute-directory))))
 380             (guix-substitute "--substitute"
 381                              (string-append (%store-prefix)
 382                                             "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 383                              "substitute-retrieved"))
 384           (call-with-input-file "substitute-retrieved" get-string-all))
 385         (lambda ()
 386           (false-if-exception (delete-file "substitute-retrieved")))))))
 387
 388 (test-equal "substitute, first narinfo is unsigned and has wrong refs"
 389   "Substitutable data."
 390   (with-narinfo* (regexp-substitute #f
 391                                     (string-match "References: ([^\n]+)\n"
 392                                                   %narinfo)
 393                                     'pre "References: " 1
 394                                     " wrong set of references\n"
 395                                     'post)
 396       %alternate-substitute-directory
 397
 398     (with-narinfo* (string-append %narinfo "Signature: "
 399                                   (signature-field %narinfo))
 400         %main-substitute-directory
 401
 402       (dynamic-wind
 403         (const #t)
 404         (lambda ()
 405           ;; This time remove the file so that the substitute can only be
 406           ;; retrieved from %MAIN-SUBSTITUTE-DIRECTORY.
 407           (delete-file (string-append %alternate-substitute-directory
 408                                       "/example.nar"))
 409
 410           (parameterize ((substitute-urls
 411                           (map (cut string-append "file://" <>)
 412                                (list %alternate-substitute-directory
 413                                      %main-substitute-directory))))
 414             (guix-substitute "--substitute"
 415                              (string-append (%store-prefix)
 416                                             "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 417                              "substitute-retrieved"))
 418           (call-with-input-file "substitute-retrieved" get-string-all))
 419         (lambda ()
 420           (false-if-exception (delete-file "substitute-retrieved")))))))
 421
 422 (test-quit "substitute, two invalid narinfos"
 423     "no valid substitute"
 424   (with-narinfo* %narinfo                         ;not signed
 425       %alternate-substitute-directory
 426
 427     (with-narinfo* (string-append %narinfo "Signature: " ;unauthorized
 428                                   (signature-field
 429                                    %narinfo
 430                                    #:public-key %wrong-public-key))
 431         %main-substitute-directory
 432
 433       (guix-substitute "--substitute"
 434                        (string-append (%store-prefix)
 435                                       "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 436                        "substitute-retrieved"))))
 437
 438 (test-end "substitute")
 439
 440 ;;; Local Variables:
 441 ;;; eval: (put 'with-narinfo 'scheme-indent-function 1)
 442 ;;; eval: (put 'with-narinfo* 'scheme-indent-function 2)
 443 ;;; eval: (put 'test-quit 'scheme-indent-function 2)
 444 ;;; End: