guix/tests.scm

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