guix/tests.scm

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