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