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