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     (let ((result (seed->random-state seed)))
 168       (set! %seed (lambda () result))
 169       result)))
 170
 171 (define (random-text)
 172   "Return the hexadecimal representation of a random number."
 173   (number->string (random (expt 2 256) (%seed)) 16))
 174
 175 (define (random-bytevector n)
 176   "Return a random bytevector of N bytes."
 177   (let ((bv (make-bytevector n)))
 178     (let loop ((i 0))
 179       (if (< i n)
 180           (begin
 181             (bytevector-u8-set! bv i (random 256 (%seed)))
 182             (loop (1+ i)))
 183           bv))))
 184
 185 (define (file=? a b)
 186   "Return true if files A and B have the same type and same content."
 187   (and (eq? (stat:type (lstat a)) (stat:type (lstat b)))
 188        (case (stat:type (lstat a))
 189          ((regular)
 190           (equal?
 191            (call-with-input-file a get-bytevector-all)
 192            (call-with-input-file b get-bytevector-all)))
 193          ((symlink)
 194           (string=? (readlink a) (readlink b)))
 195          (else
 196           (error "what?" (lstat a))))))
 197
 198 (define (canonical-file? file)
 199   "Return #t if FILE is in the store, is read-only, and its mtime is 1."
 200   (let ((st (lstat file)))
 201     (or (not (string-prefix? (%store-prefix) file))
 202         (eq? 'symlink (stat:type st))
 203         (and (= 1 (stat:mtime st))
 204              (zero? (logand #o222 (stat:mode st)))))))
 205
 206 (define (network-reachable?)
 207   "Return true if we can reach the Internet."
 208   (false-if-exception (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)))
 209
 210 (define-syntax-rule (mock (module proc replacement) body ...)
 211   "Within BODY, replace the definition of PROC from MODULE with the definition
 212 given by REPLACEMENT."
 213   (let* ((m (resolve-module 'module))
 214          (original (module-ref m 'proc)))
 215     (dynamic-wind
 216       (lambda () (module-set! m 'proc replacement))
 217       (lambda () body ...)
 218       (lambda () (module-set! m 'proc original)))))
 219
 220 (define-syntax-rule (test-assertm name exp)
 221   "Like 'test-assert', but EXP is a monadic value.  A new connection to the
 222 store is opened."
 223   (test-assert name
 224     (let ((store (open-connection-for-tests)))
 225       (dynamic-wind
 226         (const #t)
 227         (lambda ()
 228           (run-with-store store exp
 229                           #:guile-for-build (%guile-for-build)))
 230         (lambda ()
 231           (close-connection store))))))
 232
 233 (define-syntax-rule (test-equalm name value exp)
 234   "Like 'test-equal', but EXP is a monadic value.  A new connection to the
 235 store is opened."
 236   (test-equal name
 237     value
 238     (with-store store
 239       (run-with-store store exp
 240                       #:guile-for-build (%guile-for-build)))))
 241
 242 (define-syntax-rule (with-environment-variable variable value body ...)
 243   "Run BODY with VARIABLE set to VALUE."
 244   (let ((orig (getenv variable)))
 245     (dynamic-wind
 246       (lambda ()
 247         (setenv variable value))
 248       (lambda ()
 249         body ...)
 250       (lambda ()
 251         (if orig
 252             (setenv variable orig)
 253             (unsetenv variable))))))
 254
 255 \f
 256 ;;;
 257 ;;; Narinfo files, as used by the substituter.
 258 ;;;
 259
 260 (define* (derivation-narinfo drv #:key (nar "example.nar")
 261                              (sha256 (make-bytevector 32 0))
 262                              (references '()))
 263   "Return the contents of the narinfo corresponding to DRV, with the specified
 264 REFERENCES (a list of store items); NAR should be the file name of the archive
 265 containing the substitute for DRV, and SHA256 is the expected hash."
 266   (format #f "StorePath: ~a
 267 URL: ~a
 268 Compression: none
 269 NarSize: 1234
 270 NarHash: sha256:~a
 271 References: ~a
 272 System: ~a
 273 Deriver: ~a~%"
 274           (derivation->output-path drv)       ; StorePath
 275           nar                                 ; URL
 276           (bytevector->nix-base32-string sha256)  ; NarHash
 277           (string-join (map basename references)) ; References
 278           (derivation-system drv)             ; System
 279           (basename
 280            (derivation-file-name drv))))      ; Deriver
 281
 282 (define %substitute-directory
 283   (make-parameter
 284    (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL")
 285           (compose uri-path string->uri))))
 286
 287 (define* (call-with-derivation-narinfo drv thunk
 288                                        #:key
 289                                        (sha256 (make-bytevector 32 0))
 290                                        (references '()))
 291   "Call THUNK in a context where fake substituter data, as read by 'guix
 292 substitute', has been installed for DRV.  SHA256 is the hash of the
 293 expected output of DRV."
 294   (let* ((output  (derivation->output-path drv))
 295          (dir     (%substitute-directory))
 296          (info    (string-append dir "/nix-cache-info"))
 297          (narinfo (string-append dir "/" (store-path-hash-part output)
 298                                  ".narinfo")))
 299     (dynamic-wind
 300       (lambda ()
 301         (call-with-output-file info
 302           (lambda (p)
 303             (format p "StoreDir: ~a\nWantMassQuery: 0\n"
 304                     (%store-prefix))))
 305         (call-with-output-file narinfo
 306           (lambda (p)
 307             (display (derivation-narinfo drv #:sha256 sha256
 308                                          #:references references)
 309                      p))))
 310       thunk
 311       (lambda ()
 312         (delete-file narinfo)
 313         (delete-file info)))))
 314
 315 (define-syntax with-derivation-narinfo
 316   (syntax-rules (sha256 references =>)
 317     "Evaluate BODY in a context where DRV looks substitutable from the
 318 substituter's viewpoint."
 319     ((_ drv (sha256 => hash) (references => refs) body ...)
 320      (call-with-derivation-narinfo drv
 321        (lambda () body ...)
 322        #:sha256 hash
 323        #:references refs))
 324     ((_ drv (sha256 => hash) body ...)
 325      (with-derivation-narinfo drv
 326        (sha256 => hash) (references => '())
 327        body ...))
 328     ((_ drv body ...)
 329      (call-with-derivation-narinfo drv
 330        (lambda ()
 331          body ...)))))
 332
 333 (define* (call-with-derivation-substitute drv contents thunk
 334                                           #:key
 335                                           sha256
 336                                           (references '()))
 337   "Call THUNK in a context where a substitute for DRV has been installed,
 338 using CONTENTS, a string, as its contents.  If SHA256 is true, use it as the
 339 expected hash of the substitute; otherwise use the hash of the nar containing
 340 CONTENTS."
 341   (define dir (%substitute-directory))
 342   (dynamic-wind
 343     (lambda ()
 344       (call-with-output-file (string-append dir "/example.out")
 345         (lambda (port)
 346           (display contents port)))
 347       (call-with-output-file (string-append dir "/example.nar")
 348         (lambda (p)
 349           (write-file (string-append dir "/example.out") p))))
 350     (lambda ()
 351       (let ((hash (call-with-input-file (string-append dir "/example.nar")
 352                     port-sha256)))
 353         ;; Create fake substituter data, to be read by 'guix substitute'.
 354         (call-with-derivation-narinfo drv
 355           thunk
 356           #:sha256 (or sha256 hash)
 357           #:references references)))
 358     (lambda ()
 359       (delete-file (string-append dir "/example.out"))
 360       (delete-file (string-append dir "/example.nar")))))
 361
 362 (define (shebang-too-long?)
 363   "Return true if the typical shebang in the current store would exceed
 364 Linux's static limit---the BINPRM_BUF_SIZE constant, normally 128 characters
 365 all included."
 366   (define shebang
 367     (string-append "#!" (%store-prefix) "/"
 368                    (make-string 32 #\a)
 369                    "-bootstrap-binaries-0/bin/bash\0"))
 370
 371   (> (string-length shebang) 128))
 372
 373 (define-syntax with-derivation-substitute
 374   (syntax-rules (sha256 references =>)
 375     "Evaluate BODY in a context where DRV is substitutable with the given
 376 CONTENTS."
 377     ((_ drv contents (sha256 => hash) (references => refs) body ...)
 378      (call-with-derivation-substitute drv contents
 379        (lambda () body ...)
 380        #:sha256 hash
 381        #:references refs))
 382     ((_ drv contents (sha256 => hash) body ...)
 383      (with-derivation-substitute drv contents
 384        (sha256 => hash) (references => '())
 385        body ...))
 386     ((_ drv contents body ...)
 387      (call-with-derivation-substitute drv contents
 388        (lambda ()
 389          body ...)))))
 390
 391 (define-syntax-rule (dummy-package name* extra-fields ...)
 392   "Return a \"dummy\" package called NAME*, with all its compulsory fields
 393 initialized with default values, and with EXTRA-FIELDS set as specified."
 394   (let ((p (package
 395              (name name*) (version "0") (source #f)
 396              (build-system gnu-build-system)
 397              (synopsis #f) (description #f)
 398              (home-page #f) (license #f))))
 399     (package (inherit p) extra-fields ...)))
 400
 401 (define-syntax-rule (dummy-origin extra-fields ...)
 402   "Return a \"dummy\" origin, with all its compulsory fields initialized with
 403 default values, and with EXTRA-FIELDS set as specified."
 404   (let ((o (origin (method #f) (uri "http://www.example.com")
 405                    (sha256 (base32 (make-string 52 #\x))))))
 406     (origin (inherit o) extra-fields ...)))
 407
 408 (define gnu-make-for-tests
 409   ;; This is a variant of 'gnu-make-boot0' that can be built with minimal
 410   ;; resources.
 411   (package-with-bootstrap-guile
 412    (package
 413      (inherit gnu-make)
 414      (name "make-test-boot0")
 415      (arguments
 416       `(#:guile ,%bootstrap-guile
 417         #:implicit-inputs? #f
 418         #:tests? #f                               ;cannot run "make check"
 419         ,@(substitute-keyword-arguments (package-arguments gnu-make)
 420             ((#:configure-flags flags ''())
 421              ;; As in 'gnu-make-boot0', work around a 'config.status' defect.
 422              `(cons "--disable-dependency-tracking" ,flags))
 423             ((#:phases phases)
 424              `(modify-phases ,phases
 425                 (replace 'build
 426                   (lambda _
 427                     (invoke "./build.sh")
 428                     #t))
 429                 (replace 'install
 430                   (lambda* (#:key outputs #:allow-other-keys)
 431                     (let* ((out (assoc-ref outputs "out"))
 432                            (bin (string-append out "/bin")))
 433                       (install-file "make" bin)
 434                       #t))))))))
 435      (native-inputs '())                          ;no need for 'pkg-config'
 436      (inputs %bootstrap-inputs-for-tests))))
 437
 438 ;; Local Variables:
 439 ;; eval: (put 'call-with-derivation-narinfo 'scheme-indent-function 1)
 440 ;; eval: (put 'call-with-derivation-substitute 'scheme-indent-function 2)
 441 ;; End:
 442
 443 ;;; tests.scm ends here