tests/substitute.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
   3 ;;; Copyright © 2014, 2015 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 (guix hash)
  24   #:use-module (guix serialization)
  25   #:use-module (guix 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) #:select (delete-file-recursively))
  32   #:use-module (rnrs bytevectors)
  33   #:use-module (rnrs io ports)
  34   #:use-module (web uri)
  35   #:use-module (ice-9 regex)
  36   #:use-module (srfi srfi-26)
  37   #:use-module (srfi srfi-34)
  38   #:use-module (srfi srfi-35)
  39   #:use-module ((srfi srfi-64) #:hide (test-error)))
  40
  41 (define-syntax-rule (test-quit name error-rx exp)
  42   "Emit a test that passes when EXP throws to 'quit' with value 1, and when
  43 it writes to GUIX-WARNING-PORT a messages that matches ERROR-RX."
  44   (test-equal name
  45     '(1 #t)
  46     (let ((error-output (open-output-string)))
  47       (parameterize ((guix-warning-port error-output))
  48         (catch 'quit
  49           (lambda ()
  50             exp
  51             #f)
  52           (lambda (key value)
  53             (list value
  54                   (let ((message (get-output-string error-output)))
  55                     (->bool (string-match error-rx message))))))))))
  56
  57 (define %public-key
  58   ;; This key is known to be in the ACL by default.
  59   (call-with-input-file (string-append %config-directory "/signing-key.pub")
  60     (compose string->canonical-sexp get-string-all)))
  61
  62 (define %private-key
  63   (call-with-input-file (string-append %config-directory "/signing-key.sec")
  64     (compose string->canonical-sexp get-string-all)))
  65
  66 (define* (signature-body bv #:key (public-key %public-key))
  67   "Return the signature of BV as the base64-encoded body of a narinfo's
  68 'Signature' field."
  69   (base64-encode
  70    (string->utf8
  71     (canonical-sexp->string
  72      (signature-sexp (bytevector->hash-data (sha256 bv)
  73                                             #:key-type 'rsa)
  74                      %private-key
  75                      public-key)))))
  76
  77 (define %wrong-public-key
  78   (string->canonical-sexp "(public-key
  79  (rsa
  80   (n #00E05873AC2B168760343145918E954EE9AB73C026355693B192E01EE835261AA689E9EF46642E895BCD65C648524059FC450E4BA77A68F4C52D0E39EF0CC9359709AB6AAB153B63782201871325B0FDA19CB401CD99FD0C31A91CA9000AA90A77E82B89E036FB63BC1D3961207469B3B12468977148D376F8012BB12A4B11A8F1#)
  81   (e #010001#)
  82   )
  83  )"))
  84
  85 (define* (signature-field bv-or-str
  86                           #:key (version "1") (public-key %public-key))
  87   "Return the 'Signature' field value of bytevector/string BV-OR-STR, using
  88 PUBLIC-KEY as the signature's principal, and using VERSION as the signature
  89 version identifier.."
  90   (string-append version ";example.gnu.org;"
  91                  (signature-body (if (string? bv-or-str)
  92                                      (string->utf8 bv-or-str)
  93                                      bv-or-str)
  94                                  #:public-key public-key)))
  95
  96
  97 \f
  98 (test-begin "substitute")
  99
 100 (test-quit "not a number"
 101     "signature version"
 102   (narinfo-signature->canonical-sexp
 103    (signature-field "foo" #:version "not a number")))
 104
 105 (test-quit "wrong version number"
 106     "unsupported.*version"
 107   (narinfo-signature->canonical-sexp
 108    (signature-field "foo" #:version "2")))
 109
 110 (test-assert "valid narinfo-signature->canonical-sexp"
 111   (canonical-sexp? (narinfo-signature->canonical-sexp (signature-field "foo"))))
 112
 113
 114 \f
 115 (define %narinfo
 116   ;; Skeleton of the narinfo used below.
 117   (string-append "StorePath: " (%store-prefix)
 118                  "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
 119 URL: example.nar
 120 Compression: none
 121 NarHash: sha256:" (bytevector->nix-base32-string
 122                    (sha256 (string->utf8 "Substitutable data."))) "
 123 NarSize: 42
 124 References: bar baz
 125 Deriver: " (%store-prefix) "/foo.drv
 126 System: mips64el-linux\n"))
 127
 128 (define (call-with-narinfo narinfo thunk)
 129   "Call THUNK in a context where $GUIX_BINARY_SUBSTITUTE_URL is populated with
 130 a file for NARINFO."
 131   (let ((narinfo-directory (and=> (string->uri (getenv
 132                                                 "GUIX_BINARY_SUBSTITUTE_URL"))
 133                                   uri-path))
 134         (cache-directory   (string-append (getenv "XDG_CACHE_HOME")
 135                                           "/guix/substitute/")))
 136     (dynamic-wind
 137       (lambda ()
 138         (when (file-exists? cache-directory)
 139           (delete-file-recursively cache-directory))
 140         (call-with-output-file (string-append narinfo-directory
 141                                               "/nix-cache-info")
 142           (lambda (port)
 143             (format port "StoreDir: ~a\nWantMassQuery: 0\n"
 144                     (%store-prefix))))
 145         (call-with-output-file (string-append narinfo-directory "/"
 146                                               "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
 147                                               ".narinfo")
 148           (cut display narinfo <>))
 149
 150         ;; Prepare the nar.
 151         (call-with-output-file
 152             (string-append narinfo-directory "/example.out")
 153           (cut display "Substitutable data." <>))
 154         (call-with-output-file
 155             (string-append narinfo-directory "/example.nar")
 156           (cute write-file
 157                 (string-append narinfo-directory "/example.out") <>))
 158
 159         (set! (@@ (guix scripts substitute)
 160                   %allow-unauthenticated-substitutes?)
 161               #f))
 162       thunk
 163       (lambda ()
 164         (delete-file-recursively cache-directory)))))
 165
 166 (define-syntax-rule (with-narinfo narinfo body ...)
 167   (call-with-narinfo narinfo (lambda () body ...)))
 168
 169 ;; Transmit these options to 'guix substitute'.
 170 (set! (@@ (guix scripts substitute) %cache-urls)
 171   (list (getenv "GUIX_BINARY_SUBSTITUTE_URL")))
 172
 173 (test-equal "query narinfo without signature"
 174   ""                                              ; not substitutable
 175
 176   (with-narinfo %narinfo
 177     (string-trim-both
 178      (with-output-to-string
 179        (lambda ()
 180          (with-input-from-string (string-append "have " (%store-prefix)
 181                                                 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 182            (lambda ()
 183              (guix-substitute "--query"))))))))
 184
 185 (test-equal "query narinfo with invalid hash"
 186   ;; The hash in the signature differs from the hash of %NARINFO.
 187   ""
 188
 189   (with-narinfo (string-append %narinfo "Signature: "
 190                                (signature-field "different body")
 191                                "\n")
 192     (string-trim-both
 193      (with-output-to-string
 194        (lambda ()
 195          (with-input-from-string (string-append "have " (%store-prefix)
 196                                                 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 197            (lambda ()
 198              (guix-substitute "--query"))))))))
 199
 200 (test-equal "query narinfo signed with authorized key"
 201   (string-append (%store-prefix) "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 202
 203   (with-narinfo (string-append %narinfo "Signature: "
 204                                (signature-field %narinfo)
 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 unauthorized key"
 215   ""                                              ; not substitutable
 216
 217   (with-narinfo (string-append %narinfo "Signature: "
 218                                (signature-field
 219                                 %narinfo
 220                                 #:public-key %wrong-public-key)
 221                                "\n")
 222     (string-trim-both
 223      (with-output-to-string
 224        (lambda ()
 225          (with-input-from-string (string-append "have " (%store-prefix)
 226                                                 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 227            (lambda ()
 228              (guix-substitute "--query"))))))))
 229
 230 (test-quit "substitute, no signature"
 231     "lacks a signature"
 232   (with-narinfo %narinfo
 233     (guix-substitute "--substitute"
 234                      (string-append (%store-prefix)
 235                                     "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 236                      "foo")))
 237
 238 (test-quit "substitute, invalid hash"
 239     "hash"
 240   ;; The hash in the signature differs from the hash of %NARINFO.
 241   (with-narinfo (string-append %narinfo "Signature: "
 242                                (signature-field "different body")
 243                                "\n")
 244     (guix-substitute "--substitute"
 245                      (string-append (%store-prefix)
 246                                     "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 247                      "foo")))
 248
 249 (test-quit "substitute, unauthorized key"
 250     "unauthorized"
 251   (with-narinfo (string-append %narinfo "Signature: "
 252                                (signature-field
 253                                 %narinfo
 254                                 #:public-key %wrong-public-key)
 255                                "\n")
 256     (guix-substitute "--substitute"
 257                      (string-append (%store-prefix)
 258                                     "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 259                      "foo")))
 260
 261 (test-equal "substitute, authorized key"
 262   "Substitutable data."
 263   (with-narinfo (string-append %narinfo "Signature: "
 264                                (signature-field %narinfo))
 265     (dynamic-wind
 266       (const #t)
 267       (lambda ()
 268         (guix-substitute "--substitute"
 269                          (string-append (%store-prefix)
 270                                         "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 271                          "substitute-retrieved")
 272         (call-with-input-file "substitute-retrieved" get-string-all))
 273       (lambda ()
 274         (false-if-exception (delete-file "substitute-retrieved"))))))
 275
 276 (test-end "substitute")
 277
 278 \f
 279 (exit (= (test-runner-fail-count (test-runner-current)) 0))
 280
 281 ;;; Local Variables:
 282 ;;; eval: (put 'with-narinfo 'scheme-indent-function 1)
 283 ;;; eval: (put 'test-quit 'scheme-indent-function 2)
 284 ;;; End: