tests/nar.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014 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 (test-nar)
  20   #:use-module (guix nar)
  21   #:use-module (guix store)
  22   #:use-module ((guix hash) #:select (open-sha256-input-port))
  23   #:use-module (rnrs bytevectors)
  24   #:use-module (rnrs io ports)
  25   #:use-module (srfi srfi-1)
  26   #:use-module (srfi srfi-26)
  27   #:use-module (srfi srfi-34)
  28   #:use-module (srfi srfi-35)
  29   #:use-module (srfi srfi-64)
  30   #:use-module (ice-9 ftw)
  31   #:use-module (ice-9 regex)
  32   #:use-module (ice-9 match))
  33
  34 ;; Test the (guix nar) module.
  35
  36 \f
  37 ;;;
  38 ;;; File system testing tools, initially contributed to Guile, then libchop.
  39 ;;;
  40
  41 (define (random-file-size)
  42   (define %average (* 1024 512))                  ; 512 KiB
  43   (define %stddev  (* 1024 64))                   ; 64 KiB
  44   (inexact->exact
  45    (max 0 (round (+ %average (* %stddev (random:normal)))))))
  46
  47 (define (make-file-tree dir tree)
  48   "Make file system TREE at DIR."
  49   (let loop ((dir  dir)
  50              (tree tree))
  51     (define (scope file)
  52       (string-append dir "/" file))
  53
  54     (match tree
  55       (('directory name (body ...))
  56        (mkdir (scope name))
  57        (for-each (cute loop (scope name) <>) body))
  58       (('directory name (? integer? mode) (body ...))
  59        (mkdir (scope name))
  60        (for-each (cute loop (scope name) <>) body)
  61        (chmod (scope name) mode))
  62       ((file)
  63        (populate-file (scope file) (random-file-size)))
  64       ((file (? integer? mode))
  65        (populate-file (scope file) (random-file-size))
  66        (chmod (scope file) mode))
  67       ((from '-> to)
  68        (symlink to (scope from))))))
  69
  70 (define (delete-file-tree dir tree)
  71   "Delete file TREE from DIR."
  72   (let loop ((dir  dir)
  73              (tree tree))
  74     (define (scope file)
  75       (string-append dir "/" file))
  76
  77     (match tree
  78       (('directory name (body ...))
  79        (for-each (cute loop (scope name) <>) body)
  80        (rmdir (scope name)))
  81       (('directory name (? integer? mode) (body ...))
  82        (chmod (scope name) #o755)          ; make sure it can be entered
  83        (for-each (cute loop (scope name) <>) body)
  84        (rmdir (scope name)))
  85       ((from '-> _)
  86        (delete-file (scope from)))
  87       ((file _ ...)
  88        (delete-file (scope file))))))
  89
  90 (define-syntax-rule (with-file-tree dir tree body ...)
  91   (dynamic-wind
  92     (lambda ()
  93       (make-file-tree dir 'tree))
  94     (lambda ()
  95       body ...)
  96     (lambda ()
  97       (delete-file-tree dir 'tree))))
  98
  99 (define (file-tree-equal? input output)
 100   "Return #t if the file trees at INPUT and OUTPUT are equal."
 101   (define strip
 102     (cute string-drop <> (string-length input)))
 103   (define sibling
 104     (compose (cut string-append output <>) strip))
 105   (define (file=? a b)
 106     (and (eq? (stat:type (lstat a)) (stat:type (lstat b)))
 107          (case (stat:type (lstat a))
 108            ((regular)
 109             (equal?
 110              (call-with-input-file a get-bytevector-all)
 111              (call-with-input-file b get-bytevector-all)))
 112            ((symlink)
 113             (string=? (readlink a) (readlink b)))
 114            (else
 115             (error "what?" (lstat a))))))
 116
 117   (file-system-fold (const #t)
 118                     (lambda (name stat result)    ; leaf
 119                       (and result
 120                            (file=? name (sibling name))))
 121                     (lambda (name stat result)    ; down
 122                       result)
 123                     (lambda (name stat result)    ; up
 124                       result)
 125                     (const #f)                    ; skip
 126                     (lambda (name stat errno result)
 127                       (pk 'error name stat errno)
 128                       #f)
 129                     (> (stat:nlink (stat output)) 2)
 130                     input
 131                     lstat))
 132
 133 (define (make-random-bytevector n)
 134   (let ((bv (make-bytevector n)))
 135     (let loop ((i 0))
 136       (if (< i n)
 137           (begin
 138             (bytevector-u8-set! bv i (random 256))
 139             (loop (1+ i)))
 140           bv))))
 141
 142 (define (populate-file file size)
 143   (call-with-output-file file
 144     (lambda (p)
 145       (put-bytevector p (make-random-bytevector size)))))
 146
 147 (define (rm-rf dir)
 148   (file-system-fold (const #t)                    ; enter?
 149                     (lambda (file stat result)    ; leaf
 150                       (delete-file file))
 151                     (const #t)                    ; down
 152                     (lambda (dir stat result)     ; up
 153                       (rmdir dir))
 154                     (const #t)                    ; skip
 155                     (const #t)                    ; error
 156                     #t
 157                     dir
 158                     lstat))
 159
 160 (define %test-dir
 161   ;; An output directory under $top_builddir.
 162   (string-append (dirname (search-path %load-path "pre-inst-env"))
 163                  "/test-nar-" (number->string (getpid))))
 164
 165 ;; XXX: Factorize.
 166 (define %seed
 167   (seed->random-state (logxor (getpid) (car (gettimeofday)))))
 168
 169 (define (random-text)
 170   (number->string (random (expt 2 256) %seed) 16))
 171
 172 (define-syntax-rule (let/ec k exp...)
 173   ;; This one appeared in Guile 2.0.9, so provide a copy here.
 174   (let ((tag (make-prompt-tag)))
 175     (call-with-prompt tag
 176       (lambda ()
 177         (let ((k (lambda args
 178                    (apply abort-to-prompt tag args))))
 179           exp...))
 180       (lambda (_ . args)
 181         (apply values args)))))
 182
 183 \f
 184 (test-begin "nar")
 185
 186 (test-assert "write-file supports non-file output ports"
 187   (let ((input  (string-append (dirname (search-path %load-path "guix.scm"))
 188                                "/guix"))
 189         (output (%make-void-port "w")))
 190     (write-file input output)
 191     #t))
 192
 193 (test-assert "write-file + restore-file"
 194   (let* ((input  (string-append (dirname (search-path %load-path "guix.scm"))
 195                                 "/guix"))
 196          (output %test-dir)
 197          (nar    (string-append output ".nar")))
 198     (dynamic-wind
 199       (lambda () #t)
 200       (lambda ()
 201         (call-with-output-file nar
 202           (cut write-file input <>))
 203         (call-with-input-file nar
 204           (cut restore-file <> output))
 205         (file-tree-equal? input output))
 206       (lambda ()
 207         (false-if-exception (delete-file nar))
 208         (false-if-exception (rm-rf output))))))
 209
 210 (test-assert "write-file + restore-file with symlinks"
 211   (let ((input (string-append %test-dir ".input")))
 212     (mkdir input)
 213     (dynamic-wind
 214       (const #t)
 215       (lambda ()
 216         (with-file-tree input
 217             (directory "root"
 218                        (("reg") ("exe" #o777) ("sym" -> "reg")))
 219           (let* ((output %test-dir)
 220                  (nar    (string-append output ".nar")))
 221             (dynamic-wind
 222               (lambda () #t)
 223               (lambda ()
 224                 (call-with-output-file nar
 225                   (cut write-file input <>))
 226                 (call-with-input-file nar
 227                   (cut restore-file <> output))
 228                 (file-tree-equal? input output))
 229               (lambda ()
 230                 (false-if-exception (delete-file nar))
 231                 (false-if-exception (rm-rf output)))))))
 232       (lambda ()
 233         (rmdir input)))))
 234
 235 ;; 'restore-file-set' depends on 'open-sha256-input-port', which in turn
 236 ;; relies on a Guile 2.0.10+ feature.
 237 (test-skip (if (false-if-exception
 238                 (open-sha256-input-port (%make-void-port "r")))
 239                0
 240                3))
 241
 242 (test-assert "restore-file-set (signed, valid)"
 243   (with-store store
 244     (let* ((texts (unfold (cut >= <> 10)
 245                           (lambda _ (random-text))
 246                           1+
 247                           0))
 248            (files (map (cut add-text-to-store store "text" <>) texts))
 249            (dump  (call-with-bytevector-output-port
 250                    (cut export-paths store files <>))))
 251       (delete-paths store files)
 252       (and (every (negate file-exists?) files)
 253            (let* ((source   (open-bytevector-input-port dump))
 254                   (imported (restore-file-set source)))
 255              (and (equal? imported files)
 256                   (every (lambda (file)
 257                            (and (file-exists? file)
 258                                 (valid-path? store file)))
 259                          files)
 260                   (equal? texts
 261                           (map (lambda (file)
 262                                  (call-with-input-file file
 263                                    get-string-all))
 264                                files))))))))
 265
 266 (test-assert "restore-file-set (missing signature)"
 267   (let/ec return
 268     (with-store store
 269       (let* ((file  (add-text-to-store store "foo" "Hello, world!"))
 270              (dump  (call-with-bytevector-output-port
 271                      (cute export-paths store (list file) <>
 272                            #:sign? #f))))
 273         (delete-paths store (list file))
 274         (and (not (file-exists? file))
 275              (let ((source (open-bytevector-input-port dump)))
 276                (guard (c ((nar-signature-error? c)
 277                           (let ((message (condition-message c))
 278                                 (port    (nar-error-port c)))
 279                             (return
 280                              (and (string-match "lacks.*signature" message)
 281                                   (string=? file (nar-error-file c))
 282                                   (eq? source port))))))
 283                  (restore-file-set source))
 284                #f))))))
 285
 286 (test-assert "restore-file-set (corrupt)"
 287   (let/ec return
 288     (with-store store
 289       (let* ((file  (add-text-to-store store "foo"
 290                                        (random-text)))
 291              (dump  (call-with-bytevector-output-port
 292                      (cute export-paths store (list file) <>))))
 293         (delete-paths store (list file))
 294
 295         ;; Flip a byte in the file contents.
 296         (let* ((index 120)
 297                (byte  (bytevector-u8-ref dump index)))
 298           (bytevector-u8-set! dump index (logxor #xff byte)))
 299
 300         (and (not (file-exists? file))
 301              (let ((source (open-bytevector-input-port dump)))
 302                (guard (c ((nar-invalid-hash-error? c)
 303                           (let ((message (condition-message c))
 304                                 (port    (nar-error-port c)))
 305                             (return
 306                              (and (string-contains message "hash")
 307                                   (string=? file (nar-error-file c))
 308                                   (eq? source port))))))
 309                  (restore-file-set source))
 310                #f))))))
 311
 312 (test-end "nar")
 313
 314 \f
 315 (exit (= (test-runner-fail-count (test-runner-current)) 0))
 316
 317 ;;; Local Variables:
 318 ;;; eval: (put 'with-file-tree 'scheme-indent-function 2)
 319 ;;; End: