guix/tests.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix tests)
  20   #:use-module ((guix config) #:select (%storedir %localstatedir))
  21   #:use-module (guix store)
  22   #:use-module (guix derivations)
  23   #:use-module (guix packages)
  24   #:use-module (guix base32)
  25   #:use-module (guix serialization)
  26   #:use-module ((guix utils) #:select (substitute-keyword-arguments))
  27   #:use-module (gcrypt hash)
  28   #:use-module (guix build-system gnu)
  29   #:use-module (gnu packages base)
  30   #:use-module (gnu packages bootstrap)
  31   #:use-module (srfi srfi-34)
  32   #:use-module (srfi srfi-64)
  33   #:use-module (rnrs bytevectors)
  34   #:use-module (ice-9 binary-ports)
  35   #:use-module (web uri)
  36   #:export (open-connection-for-tests
  37             with-external-store
  38             %seed
  39             random-text
  40             random-bytevector
  41             file=?
  42             canonical-file?
  43             network-reachable?
  44             shebang-too-long?
  45             with-environment-variable
  46
  47             mock
  48             %test-substitute-urls
  49             test-assertm
  50             test-equalm
  51             %substitute-directory
  52             with-derivation-narinfo
  53             with-derivation-substitute
  54             dummy-package
  55             dummy-origin
  56
  57             gnu-make-for-tests))
  58
  59 ;;; Commentary:
  60 ;;;
  61 ;;; This module provide shared infrastructure for the test suite.  For
  62 ;;; internal use only.
  63 ;;;
  64 ;;; Code:
  65
  66 (define %test-substitute-urls
  67   ;; URLs where to look for substitutes during tests.
  68   (make-parameter
  69    (or (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL") list)
  70        '())))
  71
  72 (define* (open-connection-for-tests #:optional (uri (%daemon-socket-uri)))
  73   "Open a connection to the build daemon for tests purposes and return it."
  74   (guard (c ((store-error? c)
  75              (format (current-error-port)
  76                      "warning: build daemon error: ~s~%" c)
  77              #f))
  78     (let ((store (open-connection uri)))
  79       ;; Make sure we build everything by ourselves.
  80       (set-build-options store
  81                          #:use-substitutes? #f
  82                          #:substitute-urls (%test-substitute-urls))
  83
  84       ;; Use the bootstrap Guile when running tests, so we don't end up
  85       ;; building everything in the temporary test store.
  86       (%guile-for-build (package-derivation store %bootstrap-guile))
  87
  88       store)))
  89
  90 (define (call-with-external-store proc)
  91   "Call PROC with an open connection to the external store or #f it there is
  92 no external store to talk to."
  93   (parameterize ((%daemon-socket-uri
  94                   (string-append %localstatedir
  95                                  "/guix/daemon-socket/socket"))
  96                  (%store-prefix %storedir))
  97     (define store
  98       (catch #t
  99         (lambda ()
 100           (open-connection))
 101         (const #f)))
 102
 103     (dynamic-wind
 104       (const #t)
 105       (lambda ()
 106         ;; Since we're using a different store we must clear the
 107         ;; package-derivation cache.
 108         (hash-clear! (@@ (guix packages) %derivation-cache))
 109
 110         (proc store))
 111       (lambda ()
 112         (when store
 113           (close-connection store))))))
 114
 115 (define-syntax-rule (with-external-store store exp ...)
 116   "Evaluate EXP with STORE bound to the external store rather than the
 117 temporary test store, or #f if there is no external store to talk to.
 118
 119 This is meant to be used for tests that need to build packages that would be
 120 too expensive to build entirely in the test store."
 121   (call-with-external-store (lambda (store) exp ...)))
 122
 123 (define (random-seed)
 124   (or (and=> (getenv "GUIX_TESTS_RANDOM_SEED")
 125              number->string)
 126       (logxor (getpid) (car (gettimeofday)))))
 127
 128 (define %seed
 129   (let ((seed (random-seed)))
 130     (format (current-error-port) "random seed for tests: ~a~%"
 131             seed)
 132     (seed->random-state seed)))
 133
 134 (define (random-text)
 135   "Return the hexadecimal representation of a random number."
 136   (number->string (random (expt 2 256) %seed) 16))
 137
 138 (define (random-bytevector n)
 139   "Return a random bytevector of N bytes."
 140   (let ((bv (make-bytevector n)))
 141     (let loop ((i 0))
 142       (if (< i n)
 143           (begin
 144             (bytevector-u8-set! bv i (random 256 %seed))
 145             (loop (1+ i)))
 146           bv))))
 147
 148 (define (file=? a b)
 149   "Return true if files A and B have the same type and same content."
 150   (and (eq? (stat:type (lstat a)) (stat:type (lstat b)))
 151        (case (stat:type (lstat a))
 152          ((regular)
 153           (equal?
 154            (call-with-input-file a get-bytevector-all)
 155            (call-with-input-file b get-bytevector-all)))
 156          ((symlink)
 157           (string=? (readlink a) (readlink b)))
 158          (else
 159           (error "what?" (lstat a))))))
 160
 161 (define (canonical-file? file)
 162   "Return #t if FILE is in the store, is read-only, and its mtime is 1."
 163   (let ((st (lstat file)))
 164     (or (not (string-prefix? (%store-prefix) file))
 165         (eq? 'symlink (stat:type st))
 166         (and (= 1 (stat:mtime st))
 167              (zero? (logand #o222 (stat:mode st)))))))
 168
 169 (define (network-reachable?)
 170   "Return true if we can reach the Internet."
 171   (false-if-exception (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)))
 172
 173 (define-syntax-rule (mock (module proc replacement) body ...)
 174   "Within BODY, replace the definition of PROC from MODULE with the definition
 175 given by REPLACEMENT."
 176   (let* ((m (resolve-module 'module))
 177          (original (module-ref m 'proc)))
 178     (dynamic-wind
 179       (lambda () (module-set! m 'proc replacement))
 180       (lambda () body ...)
 181       (lambda () (module-set! m 'proc original)))))
 182
 183 (define-syntax-rule (test-assertm name exp)
 184   "Like 'test-assert', but EXP is a monadic value.  A new connection to the
 185 store is opened."
 186   (test-assert name
 187     (let ((store (open-connection-for-tests)))
 188       (dynamic-wind
 189         (const #t)
 190         (lambda ()
 191           (run-with-store store exp
 192                           #:guile-for-build (%guile-for-build)))
 193         (lambda ()
 194           (close-connection store))))))
 195
 196 (define-syntax-rule (test-equalm name value exp)
 197   "Like 'test-equal', but EXP is a monadic value.  A new connection to the
 198 store is opened."
 199   (test-equal name
 200     value
 201     (with-store store
 202       (run-with-store store exp
 203                       #:guile-for-build (%guile-for-build)))))
 204
 205 (define-syntax-rule (with-environment-variable variable value body ...)
 206   "Run BODY with VARIABLE set to VALUE."
 207   (let ((orig (getenv variable)))
 208     (dynamic-wind
 209       (lambda ()
 210         (setenv variable value))
 211       (lambda ()
 212         body ...)
 213       (lambda ()
 214         (if orig
 215             (setenv variable orig)
 216             (unsetenv variable))))))
 217
 218 \f
 219 ;;;
 220 ;;; Narinfo files, as used by the substituter.
 221 ;;;
 222
 223 (define* (derivation-narinfo drv #:key (nar "example.nar")
 224                              (sha256 (make-bytevector 32 0))
 225                              (references '()))
 226   "Return the contents of the narinfo corresponding to DRV, with the specified
 227 REFERENCES (a list of store items); NAR should be the file name of the archive
 228 containing the substitute for DRV, and SHA256 is the expected hash."
 229   (format #f "StorePath: ~a
 230 URL: ~a
 231 Compression: none
 232 NarSize: 1234
 233 NarHash: sha256:~a
 234 References: ~a
 235 System: ~a
 236 Deriver: ~a~%"
 237           (derivation->output-path drv)       ; StorePath
 238           nar                                 ; URL
 239           (bytevector->nix-base32-string sha256)  ; NarHash
 240           (string-join (map basename references)) ; References
 241           (derivation-system drv)             ; System
 242           (basename
 243            (derivation-file-name drv))))      ; Deriver
 244
 245 (define %substitute-directory
 246   (make-parameter
 247    (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL")
 248           (compose uri-path string->uri))))
 249
 250 (define* (call-with-derivation-narinfo drv thunk
 251                                        #:key
 252                                        (sha256 (make-bytevector 32 0))
 253                                        (references '()))
 254   "Call THUNK in a context where fake substituter data, as read by 'guix
 255 substitute', has been installed for DRV.  SHA256 is the hash of the
 256 expected output of DRV."
 257   (let* ((output  (derivation->output-path drv))
 258          (dir     (%substitute-directory))
 259          (info    (string-append dir "/nix-cache-info"))
 260          (narinfo (string-append dir "/" (store-path-hash-part output)
 261                                  ".narinfo")))
 262     (dynamic-wind
 263       (lambda ()
 264         (call-with-output-file info
 265           (lambda (p)
 266             (format p "StoreDir: ~a\nWantMassQuery: 0\n"
 267                     (%store-prefix))))
 268         (call-with-output-file narinfo
 269           (lambda (p)
 270             (display (derivation-narinfo drv #:sha256 sha256
 271                                          #:references references)
 272                      p))))
 273       thunk
 274       (lambda ()
 275         (delete-file narinfo)
 276         (delete-file info)))))
 277
 278 (define-syntax with-derivation-narinfo
 279   (syntax-rules (sha256 references =>)
 280     "Evaluate BODY in a context where DRV looks substitutable from the
 281 substituter's viewpoint."
 282     ((_ drv (sha256 => hash) (references => refs) body ...)
 283      (call-with-derivation-narinfo drv
 284        (lambda () body ...)
 285        #:sha256 hash
 286        #:references refs))
 287     ((_ drv (sha256 => hash) body ...)
 288      (with-derivation-narinfo drv
 289        (sha256 => hash) (references => '())
 290        body ...))
 291     ((_ drv body ...)
 292      (call-with-derivation-narinfo drv
 293        (lambda ()
 294          body ...)))))
 295
 296 (define* (call-with-derivation-substitute drv contents thunk
 297                                           #:key
 298                                           sha256
 299                                           (references '()))
 300   "Call THUNK in a context where a substitute for DRV has been installed,
 301 using CONTENTS, a string, as its contents.  If SHA256 is true, use it as the
 302 expected hash of the substitute; otherwise use the hash of the nar containing
 303 CONTENTS."
 304   (define dir (%substitute-directory))
 305   (dynamic-wind
 306     (lambda ()
 307       (call-with-output-file (string-append dir "/example.out")
 308         (lambda (port)
 309           (display contents port)))
 310       (call-with-output-file (string-append dir "/example.nar")
 311         (lambda (p)
 312           (write-file (string-append dir "/example.out") p))))
 313     (lambda ()
 314       (let ((hash (call-with-input-file (string-append dir "/example.nar")
 315                     port-sha256)))
 316         ;; Create fake substituter data, to be read by 'guix substitute'.
 317         (call-with-derivation-narinfo drv
 318           thunk
 319           #:sha256 (or sha256 hash)
 320           #:references references)))
 321     (lambda ()
 322       (delete-file (string-append dir "/example.out"))
 323       (delete-file (string-append dir "/example.nar")))))
 324
 325 (define (shebang-too-long?)
 326   "Return true if the typical shebang in the current store would exceed
 327 Linux's static limit---the BINPRM_BUF_SIZE constant, normally 128 characters
 328 all included."
 329   (define shebang
 330     (string-append "#!" (%store-prefix) "/"
 331                    (make-string 32 #\a)
 332                    "-bootstrap-binaries-0/bin/bash\0"))
 333
 334   (> (string-length shebang) 128))
 335
 336 (define-syntax with-derivation-substitute
 337   (syntax-rules (sha256 references =>)
 338     "Evaluate BODY in a context where DRV is substitutable with the given
 339 CONTENTS."
 340     ((_ drv contents (sha256 => hash) (references => refs) body ...)
 341      (call-with-derivation-substitute drv contents
 342        (lambda () body ...)
 343        #:sha256 hash
 344        #:references refs))
 345     ((_ drv contents (sha256 => hash) body ...)
 346      (with-derivation-substitute drv contents
 347        (sha256 => hash) (references => '())
 348        body ...))
 349     ((_ drv contents body ...)
 350      (call-with-derivation-substitute drv contents
 351        (lambda ()
 352          body ...)))))
 353
 354 (define-syntax-rule (dummy-package name* extra-fields ...)
 355   "Return a \"dummy\" package called NAME*, with all its compulsory fields
 356 initialized with default values, and with EXTRA-FIELDS set as specified."
 357   (let ((p (package
 358              (name name*) (version "0") (source #f)
 359              (build-system gnu-build-system)
 360              (synopsis #f) (description #f)
 361              (home-page #f) (license #f))))
 362     (package (inherit p) extra-fields ...)))
 363
 364 (define-syntax-rule (dummy-origin extra-fields ...)
 365   "Return a \"dummy\" origin, with all its compulsory fields initialized with
 366 default values, and with EXTRA-FIELDS set as specified."
 367   (let ((o (origin (method #f) (uri "http://www.example.com")
 368                    (sha256 (base32 (make-string 52 #\x))))))
 369     (origin (inherit o) extra-fields ...)))
 370
 371 (define gnu-make-for-tests
 372   ;; This is a variant of 'gnu-make-boot0' that can be built with minimal
 373   ;; resources.
 374   (package-with-bootstrap-guile
 375    (package
 376      (inherit gnu-make)
 377      (name "make-test-boot0")
 378      (arguments
 379       `(#:guile ,%bootstrap-guile
 380         #:implicit-inputs? #f
 381         #:tests? #f                               ;cannot run "make check"
 382         ,@(substitute-keyword-arguments (package-arguments gnu-make)
 383             ((#:phases phases)
 384              `(modify-phases ,phases
 385                 (replace 'build
 386                   (lambda _
 387                     (invoke "./build.sh")
 388                     #t))
 389                 (replace 'install
 390                   (lambda* (#:key outputs #:allow-other-keys)
 391                     (let* ((out (assoc-ref outputs "out"))
 392                            (bin (string-append out "/bin")))
 393                       (install-file "make" bin)
 394                       #t))))))))
 395      (native-inputs '())                          ;no need for 'pkg-config'
 396      (inputs %bootstrap-inputs-for-tests))))
 397
 398 ;; Local Variables:
 399 ;; eval: (put 'call-with-derivation-narinfo 'scheme-indent-function 1)
 400 ;; eval: (put 'call-with-derivation-substitute 'scheme-indent-function 2)
 401 ;; End:
 402
 403 ;;; tests.scm ends here