guix/tests.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013-2022 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 gexp)
  24   #:use-module (guix packages)
  25   #:use-module (guix base32)
  26   #:use-module (guix serialization)
  27   #:use-module (guix monads)
  28   #:use-module ((guix utils) #:select (substitute-keyword-arguments))
  29   #:use-module ((guix build utils) #:select (mkdir-p compressor))
  30   #:use-module ((gcrypt hash) #:hide (sha256))
  31   #:use-module (guix build-system gnu)
  32   #:use-module (gnu packages base)
  33   #:use-module (gnu packages bootstrap)
  34   #:use-module (srfi srfi-26)
  35   #:use-module (srfi srfi-34)
  36   #:use-module (srfi srfi-64)
  37   #:use-module (rnrs bytevectors)
  38   #:use-module (ice-9 match)
  39   #:use-module (ice-9 binary-ports)
  40   #:use-module (web uri)
  41   #:export (open-connection-for-tests
  42             with-external-store
  43             %seed
  44             random-text
  45             random-bytevector
  46             file=?
  47             canonical-file?
  48             network-reachable?
  49             shebang-too-long?
  50             with-environment-variable
  51
  52             search-bootstrap-binary
  53
  54             mock
  55             %test-substitute-urls
  56             test-assertm
  57             test-equalm
  58             %substitute-directory
  59             with-derivation-narinfo
  60             with-derivation-substitute
  61             dummy-package
  62             dummy-origin
  63
  64             gnu-make-for-tests
  65
  66             test-file))
  67
  68 ;;; Commentary:
  69 ;;;
  70 ;;; This module provide shared infrastructure for the test suite.  For
  71 ;;; internal use only.
  72 ;;;
  73 ;;; Code:
  74
  75 (define %test-substitute-urls
  76   ;; URLs where to look for substitutes during tests.
  77   (make-parameter
  78    (or (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL") list)
  79        '())))
  80
  81 (define* (open-connection-for-tests #:optional (uri (%daemon-socket-uri)))
  82   "Open a connection to the build daemon for tests purposes and return it."
  83   (guard (c ((store-error? c)
  84              (format (current-error-port)
  85                      "warning: build daemon error: ~s~%" c)
  86              #f))
  87     (let ((store (open-connection uri)))
  88       ;; Make sure we build everything by ourselves.  When we build something,
  89       ;; it should take at most 5 minutes.
  90       (set-build-options store
  91                          #:use-substitutes? #f
  92                          #:substitute-urls (%test-substitute-urls)
  93                          #:timeout (* 5 60))
  94
  95       ;; Use the bootstrap Guile when running tests, so we don't end up
  96       ;; building everything in the temporary test store.
  97       (%guile-for-build (package-derivation store %bootstrap-guile))
  98
  99       store)))
 100
 101 (define (bootstrap-binary-file program system)
 102   "Return the absolute file name where bootstrap binary PROGRAM for SYSTEM is
 103 stored."
 104   (string-append (dirname (search-path %load-path
 105                                        "gnu/packages/bootstrap.scm"))
 106                  "/bootstrap/" system "/" program))
 107
 108 (define (search-bootstrap-binary file-name system)
 109   "Search the bootstrap binary FILE-NAME for SYSTEM.  Raise an error if not
 110 found."
 111   ;; Note: Keep bootstrap binaries on the local file system so that the 'guix'
 112   ;; package can provide them as inputs and copy them to the right place.
 113   (let* ((system (match system
 114                    ("x86_64-linux" "i686-linux")
 115                    (_ system)))
 116          (file   (bootstrap-binary-file file-name system)))
 117     (if (file-exists? file)
 118         file
 119         (with-store store
 120           (run-with-store store
 121             (mlet %store-monad ((drv (origin->derivation
 122                                       (bootstrap-executable file-name system))))
 123               (mbegin %store-monad
 124                 (built-derivations (list drv))
 125                 (begin
 126                   (mkdir-p (dirname file))
 127                   (copy-file (derivation->output-path drv) file)
 128                   (return file)))))))))
 129
 130 (define (call-with-external-store proc)
 131   "Call PROC with an open connection to the external store or #f it there is
 132 no external store to talk to."
 133   (parameterize ((%daemon-socket-uri
 134                   (string-append %localstatedir
 135                                  "/guix/daemon-socket/socket"))
 136                  (%store-prefix %storedir))
 137     (define store
 138       (catch #t
 139         (lambda ()
 140           (open-connection))
 141         (const #f)))
 142
 143     (let ((store-variable (getenv "NIX_STORE_DIR")))
 144       (dynamic-wind
 145         (lambda ()
 146           ;; This environment variable is set by 'pre-inst-env' but it
 147           ;; influences '%store-directory' in (guix build utils), which is
 148           ;; itself used in (guix packages).  Thus, unset it before going any
 149           ;; further.
 150           (unsetenv "NIX_STORE_DIR"))
 151         (lambda ()
 152           (when store
 153             ;; Make sure we don't end up rebuilding the world for those tests.
 154             (set-build-options store #:timeout (* 10 60)))
 155           (proc store))
 156         (lambda ()
 157           (when store-variable
 158             (setenv "NIX_STORE_DIR" store-variable))
 159           (when store
 160             (close-connection store)))))))
 161
 162 (define-syntax-rule (with-external-store store exp ...)
 163   "Evaluate EXP with STORE bound to the external store rather than the
 164 temporary test store, or #f if there is no external store to talk to.
 165
 166 This is meant to be used for tests that need to build packages that would be
 167 too expensive to build entirely in the test store."
 168   (call-with-external-store (lambda (store) exp ...)))
 169
 170 (define (random-seed)
 171   (or (and=> (getenv "GUIX_TESTS_RANDOM_SEED")
 172              number->string)
 173       (logxor (getpid) (car (gettimeofday)))))
 174
 175 (define (%seed)
 176   (let ((seed (random-seed)))
 177     (format (current-error-port) "random seed for tests: ~a~%"
 178             seed)
 179     (let ((result (seed->random-state seed)))
 180       (set! %seed (lambda () result))
 181       result)))
 182
 183 (define (random-text)
 184   "Return the hexadecimal representation of a random number."
 185   (number->string (random (expt 2 256) (%seed)) 16))
 186
 187 (define (random-bytevector n)
 188   "Return a random bytevector of N bytes."
 189   (let ((bv (make-bytevector n)))
 190     (let loop ((i 0))
 191       (if (< i n)
 192           (begin
 193             (bytevector-u8-set! bv i (random 256 (%seed)))
 194             (loop (1+ i)))
 195           bv))))
 196
 197 (define* (file=? a b #:optional (stat lstat))
 198   "Return true if files A and B have the same type and same content.  Call
 199 STAT to obtain file metadata."
 200   (let ((sta (stat a)) (stb (stat b)))
 201     (and (eq? (stat:type sta) (stat:type stb))
 202          (case (stat:type sta)
 203            ((regular)
 204             (or (and (= (stat:ino sta) (stat:ino stb))
 205                      (= (stat:dev sta) (stat:dev stb)))
 206                 (equal?
 207                  (call-with-input-file a get-bytevector-all)
 208                  (call-with-input-file b get-bytevector-all))))
 209            ((symlink)
 210             (string=? (readlink a) (readlink b)))
 211            (else
 212             (error "what?" (stat a)))))))
 213
 214 (define (canonical-file? file)
 215   "Return #t if FILE is in the store, is read-only, and its mtime is 1."
 216   (let ((st (lstat file)))
 217     (or (not (string-prefix? (%store-prefix) file))
 218         (eq? 'symlink (stat:type st))
 219         (and (= 1 (stat:mtime st))
 220              (zero? (logand #o222 (stat:mode st)))))))
 221
 222 (define (network-reachable?)
 223   "Return true if we can reach the Internet."
 224   (false-if-exception (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)))
 225
 226 (define-syntax-rule (mock (module proc replacement) body ...)
 227   "Within BODY, replace the definition of PROC from MODULE with the definition
 228 given by REPLACEMENT."
 229   (let* ((m (resolve-module 'module))
 230          (original (module-ref m 'proc)))
 231     (dynamic-wind
 232       (lambda () (module-set! m 'proc replacement))
 233       (lambda () body ...)
 234       (lambda () (module-set! m 'proc original)))))
 235
 236 (define-syntax-rule (test-assertm name exp)
 237   "Like 'test-assert', but EXP is a monadic value.  A new connection to the
 238 store is opened."
 239   (test-assert name
 240     (let ((store (open-connection-for-tests)))
 241       (dynamic-wind
 242         (const #t)
 243         (lambda ()
 244           (run-with-store store exp
 245                           #:guile-for-build (%guile-for-build)))
 246         (lambda ()
 247           (close-connection store))))))
 248
 249 (define-syntax-rule (test-equalm name value exp)
 250   "Like 'test-equal', but EXP is a monadic value.  A new connection to the
 251 store is opened."
 252   (test-equal name
 253     value
 254     (with-store store
 255       (run-with-store store exp
 256                       #:guile-for-build (%guile-for-build)))))
 257
 258 (define-syntax-rule (with-environment-variable variable value body ...)
 259   "Run BODY with VARIABLE set to VALUE."
 260   (let ((orig (getenv variable)))
 261     (dynamic-wind
 262       (lambda ()
 263         (setenv variable value))
 264       (lambda ()
 265         body ...)
 266       (lambda ()
 267         (if orig
 268             (setenv variable orig)
 269             (unsetenv variable))))))
 270
 271 \f
 272 ;;;
 273 ;;; Narinfo files, as used by the substituter.
 274 ;;;
 275
 276 (define* (derivation-narinfo drv #:key (nar "example.nar")
 277                              (sha256 (make-bytevector 32 0))
 278                              (references '()))
 279   "Return the contents of the narinfo corresponding to DRV, with the specified
 280 REFERENCES (a list of store items); NAR should be the file name of the archive
 281 containing the substitute for DRV, and SHA256 is the expected hash."
 282   (format #f "StorePath: ~a
 283 URL: ~a
 284 Compression: none
 285 NarSize: 1234
 286 NarHash: sha256:~a
 287 References: ~a
 288 System: ~a
 289 Deriver: ~a~%"
 290           (derivation->output-path drv)       ; StorePath
 291           nar                                 ; URL
 292           (bytevector->nix-base32-string sha256)  ; NarHash
 293           (string-join (map basename references)) ; References
 294           (derivation-system drv)             ; System
 295           (basename
 296            (derivation-file-name drv))))      ; Deriver
 297
 298 (define %substitute-directory
 299   (make-parameter
 300    (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL")
 301           (compose uri-path string->uri))))
 302
 303 (define* (call-with-derivation-narinfo drv thunk
 304                                        #:key
 305                                        (sha256 (make-bytevector 32 0))
 306                                        (references '()))
 307   "Call THUNK in a context where fake substituter data, as read by 'guix
 308 substitute', has been installed for DRV.  SHA256 is the hash of the
 309 expected output of DRV."
 310   (let* ((output  (derivation->output-path drv))
 311          (dir     (%substitute-directory))
 312          (info    (string-append dir "/nix-cache-info"))
 313          (narinfo (string-append dir "/" (store-path-hash-part output)
 314                                  ".narinfo")))
 315     (dynamic-wind
 316       (lambda ()
 317         (call-with-output-file info
 318           (lambda (p)
 319             (format p "StoreDir: ~a\nWantMassQuery: 0\n"
 320                     (%store-prefix))))
 321         (call-with-output-file narinfo
 322           (lambda (p)
 323             (display (derivation-narinfo drv #:sha256 sha256
 324                                          #:references references)
 325                      p))))
 326       thunk
 327       (lambda ()
 328         (delete-file narinfo)
 329         (delete-file info)))))
 330
 331 (define-syntax with-derivation-narinfo
 332   (syntax-rules (sha256 references =>)
 333     "Evaluate BODY in a context where DRV looks substitutable from the
 334 substituter's viewpoint."
 335     ((_ drv (sha256 => hash) (references => refs) body ...)
 336      (call-with-derivation-narinfo drv
 337        (lambda () body ...)
 338        #:sha256 hash
 339        #:references refs))
 340     ((_ drv (sha256 => hash) body ...)
 341      (with-derivation-narinfo drv
 342        (sha256 => hash) (references => '())
 343        body ...))
 344     ((_ drv body ...)
 345      (call-with-derivation-narinfo drv
 346        (lambda ()
 347          body ...)))))
 348
 349 (define* (call-with-derivation-substitute drv contents thunk
 350                                           #:key
 351                                           sha256
 352                                           (references '()))
 353   "Call THUNK in a context where a substitute for DRV has been installed,
 354 using CONTENTS, a string, as its contents.  If SHA256 is true, use it as the
 355 expected hash of the substitute; otherwise use the hash of the nar containing
 356 CONTENTS."
 357   (define dir (%substitute-directory))
 358   (dynamic-wind
 359     (lambda ()
 360       (call-with-output-file (string-append dir "/example.out")
 361         (lambda (port)
 362           (display contents port)))
 363       (call-with-output-file (string-append dir "/example.nar")
 364         (lambda (p)
 365           (write-file (string-append dir "/example.out") p))))
 366     (lambda ()
 367       (let ((hash (call-with-input-file (string-append dir "/example.nar")
 368                     port-sha256)))
 369         ;; Create fake substituter data, to be read by 'guix substitute'.
 370         (call-with-derivation-narinfo drv
 371           thunk
 372           #:sha256 (or sha256 hash)
 373           #:references references)))
 374     (lambda ()
 375       (delete-file (string-append dir "/example.out"))
 376       (delete-file (string-append dir "/example.nar")))))
 377
 378 (define (shebang-too-long?)
 379   "Return true if the typical shebang in the current store would exceed
 380 Linux's static limit---the BINPRM_BUF_SIZE constant, normally 128 characters
 381 all included."
 382   (define shebang
 383     (string-append "#!" (%store-prefix) "/"
 384                    (make-string 32 #\a)
 385                    "-bootstrap-binaries-0/bin/bash\0"))
 386
 387   (> (string-length shebang) 128))
 388
 389 (define-syntax with-derivation-substitute
 390   (syntax-rules (sha256 references =>)
 391     "Evaluate BODY in a context where DRV is substitutable with the given
 392 CONTENTS."
 393     ((_ drv contents (sha256 => hash) (references => refs) body ...)
 394      (call-with-derivation-substitute drv contents
 395        (lambda () body ...)
 396        #:sha256 hash
 397        #:references refs))
 398     ((_ drv contents (sha256 => hash) body ...)
 399      (with-derivation-substitute drv contents
 400        (sha256 => hash) (references => '())
 401        body ...))
 402     ((_ drv contents body ...)
 403      (call-with-derivation-substitute drv contents
 404        (lambda ()
 405          body ...)))))
 406
 407 (define-syntax-rule (dummy-package name* extra-fields ...)
 408   "Return a \"dummy\" package called NAME*, with all its compulsory fields
 409 initialized with default values, and with EXTRA-FIELDS set as specified."
 410   (let ((p (package
 411              (name name*) (version "0") (source #f)
 412              (build-system gnu-build-system)
 413              (synopsis #f) (description #f)
 414              (home-page #f) (license #f))))
 415     (package (inherit p) extra-fields ...)))
 416
 417 (define-syntax-rule (dummy-origin extra-fields ...)
 418   "Return a \"dummy\" origin, with all its compulsory fields initialized with
 419 default values, and with EXTRA-FIELDS set as specified."
 420   (let ((o (origin (method #f) (uri "http://www.example.com")
 421                    (sha256 (base32 (make-string 52 #\x))))))
 422     (origin (inherit o) extra-fields ...)))
 423
 424 (define gnu-make-for-tests
 425   ;; This is a variant of 'gnu-make-boot0' that can be built with minimal
 426   ;; resources.
 427   (package-with-bootstrap-guile
 428    (package
 429      (inherit gnu-make)
 430      (name "make-test-boot0")
 431      (arguments
 432       `(#:guile ,%bootstrap-guile
 433         #:implicit-inputs? #f
 434         #:tests? #f                               ;cannot run "make check"
 435         ,@(substitute-keyword-arguments (package-arguments gnu-make)
 436             ((#:configure-flags flags ''())
 437              ;; As in 'gnu-make-boot0', work around a 'config.status' defect.
 438              `(cons "--disable-dependency-tracking" ,flags))
 439             ((#:phases phases)
 440              `(modify-phases ,phases
 441                 (replace 'build
 442                   (lambda _
 443                     (invoke "./build.sh")
 444                     #t))
 445                 (replace 'install
 446                   (lambda* (#:key outputs #:allow-other-keys)
 447                     (let* ((out (assoc-ref outputs "out"))
 448                            (bin (string-append out "/bin")))
 449                       (install-file "make" bin)
 450                       #t))))))))
 451      (native-inputs '())                          ;no need for 'pkg-config'
 452      (inputs %bootstrap-inputs-for-tests))))
 453
 454 \f
 455 ;;;
 456 ;;; Test utility procedures.
 457
 458 (define (test-file store name content)
 459   "Create a simple file in STORE with CONTENT (a string), compressed according
 460 to its file name extension.  Return both its file name and its hash."
 461   (let* ((ext (string-index-right name #\.))
 462          (name-sans-ext (if ext
 463                             (string-take name (string-index-right name #\.))
 464                             name))
 465          (comp (compressor name))
 466          (command #~(if #+comp
 467                         (string-append #+%bootstrap-coreutils&co
 468                                        "/bin/" #+comp)
 469                         #f))
 470          (f (with-imported-modules '((guix build utils))
 471               (computed-file name
 472                              #~(begin
 473                                  (use-modules (guix build utils)
 474                                               (rnrs io simple))
 475                                  (with-output-to-file #+name-sans-ext
 476                                    (lambda _
 477                                      (format #t #+content)))
 478                                  (when #+command
 479                                    (invoke #+command #+name-sans-ext))
 480                                  (copy-file #+name #$output))
 481                              #:guile %bootstrap-guile)))
 482          (file-drv (run-with-store store (lower-object f)))
 483          (file (derivation->output-path file-drv))
 484          (file-drv-outputs (derivation-outputs file-drv))
 485          (_ (build-derivations store (list file-drv)))
 486          (file-hash (derivation-output-hash
 487                      (assoc-ref file-drv-outputs "out"))))
 488     (values file file-hash)))
 489
 490 ;;;
 491 ;; Local Variables:
 492 ;; eval: (put 'call-with-derivation-narinfo 'scheme-indent-function 1)
 493 ;; eval: (put 'call-with-derivation-substitute 'scheme-indent-function 2)
 494 ;; End:
 495
 496 ;;; tests.scm ends here