tests/nar.scm

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