tests/nar.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 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 (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 ((gcrypt hash)
  25                 #:select (open-sha256-port open-sha256-input-port))
  26   #:use-module ((guix packages)
  27                 #:select (base32))
  28   #:use-module ((guix build utils)
  29                 #:select (find-files))
  30   #:use-module (rnrs bytevectors)
  31   #:use-module (rnrs io ports)
  32   #:use-module (srfi srfi-1)
  33   #:use-module (srfi srfi-11)
  34   #:use-module (srfi srfi-26)
  35   #:use-module (srfi srfi-34)
  36   #:use-module (srfi srfi-35)
  37   #:use-module (srfi srfi-64)
  38   #:use-module (ice-9 ftw)
  39   #:use-module (ice-9 regex)
  40   #:use-module ((ice-9 control) #:select (let/ec))
  41   #:use-module (ice-9 match))
  42
  43 ;; Test the (guix nar) module.
  44
  45 \f
  46 ;;;
  47 ;;; File system testing tools, initially contributed to Guile, then libchop.
  48 ;;;
  49
  50 (define (random-file-size)
  51   (define %average (* 1024 512))                  ; 512 KiB
  52   (define %stddev  (* 1024 64))                   ; 64 KiB
  53   (inexact->exact
  54    (max 0 (round (+ %average (* %stddev (random:normal)))))))
  55
  56 (define (make-file-tree dir tree)
  57   "Make file system TREE at DIR."
  58   (let loop ((dir  dir)
  59              (tree tree))
  60     (define (scope file)
  61       (string-append dir "/" file))
  62
  63     (match tree
  64       (('directory name (body ...))
  65        (mkdir (scope name))
  66        (for-each (cute loop (scope name) <>) body))
  67       (('directory name (? integer? mode) (body ...))
  68        (mkdir (scope name))
  69        (for-each (cute loop (scope name) <>) body)
  70        (chmod (scope name) mode))
  71       ((file)
  72        (populate-file (scope file) (random-file-size)))
  73       ((file (? integer? mode))
  74        (populate-file (scope file) (random-file-size))
  75        (chmod (scope file) mode))
  76       ((from '-> to)
  77        (symlink to (scope from))))))
  78
  79 (define (delete-file-tree dir tree)
  80   "Delete file TREE from DIR."
  81   (let loop ((dir  dir)
  82              (tree tree))
  83     (define (scope file)
  84       (string-append dir "/" file))
  85
  86     (match tree
  87       (('directory name (body ...))
  88        (for-each (cute loop (scope name) <>) body)
  89        (rmdir (scope name)))
  90       (('directory name (? integer? mode) (body ...))
  91        (chmod (scope name) #o755)          ; make sure it can be entered
  92        (for-each (cute loop (scope name) <>) body)
  93        (rmdir (scope name)))
  94       ((from '-> _)
  95        (delete-file (scope from)))
  96       ((file _ ...)
  97        (delete-file (scope file))))))
  98
  99 (define-syntax-rule (with-file-tree dir tree body ...)
 100   (dynamic-wind
 101     (lambda ()
 102       (make-file-tree dir 'tree))
 103     (lambda ()
 104       body ...)
 105     (lambda ()
 106       (delete-file-tree dir 'tree))))
 107
 108 (define (file-tree-equal? input output)
 109   "Return #t if the file trees at INPUT and OUTPUT are equal."
 110   (define strip
 111     (cute string-drop <> (string-length input)))
 112   (define sibling
 113     (compose (cut string-append output <>) strip))
 114
 115   (file-system-fold (const #t)
 116                     (lambda (name stat result)    ; leaf
 117                       (and result
 118                            (file=? name (sibling name))))
 119                     (lambda (name stat result)    ; down
 120                       result)
 121                     (lambda (name stat result)    ; up
 122                       result)
 123                     (const #f)                    ; skip
 124                     (lambda (name stat errno result)
 125                       (pk 'error name stat errno)
 126                       #f)
 127                     #t                            ; result
 128                     input
 129                     lstat))
 130
 131 (define (populate-file file size)
 132   (call-with-output-file file
 133     (lambda (p)
 134       (put-bytevector p (random-bytevector size)))))
 135
 136 (define (rm-rf dir)
 137   (file-system-fold (const #t)                    ; enter?
 138                     (lambda (file stat result)    ; leaf
 139                       (delete-file file))
 140                     (const #t)                    ; down
 141                     (lambda (dir stat result)     ; up
 142                       (rmdir dir))
 143                     (const #t)                    ; skip
 144                     (const #t)                    ; error
 145                     #t
 146                     dir
 147                     lstat))
 148
 149 (define %test-dir
 150   ;; An output directory under $top_builddir.
 151   (string-append (dirname (search-path %load-path "pre-inst-env"))
 152                  "/test-nar-" (number->string (getpid))))
 153
 154 \f
 155 (test-begin "nar")
 156
 157 (test-assert "write-file-tree + restore-file"
 158   (let* ((file1  (search-path %load-path "guix.scm"))
 159          (file2  (search-path %load-path "guix/base32.scm"))
 160          (file3  "#!/bin/something")
 161          (output (string-append %test-dir "/output")))
 162     (dynamic-wind
 163       (lambda () #t)
 164       (lambda ()
 165         (define-values (port get-bytevector)
 166           (open-bytevector-output-port))
 167         (write-file-tree "root" port
 168                          #:file-type+size
 169                          (match-lambda
 170                            ("root"
 171                             (values 'directory 0))
 172                            ("root/foo"
 173                             (values 'regular (stat:size (stat file1))))
 174                            ("root/lnk"
 175                             (values 'symlink 0))
 176                            ("root/dir"
 177                             (values 'directory 0))
 178                            ("root/dir/bar"
 179                             (values 'regular (stat:size (stat file2))))
 180                            ("root/dir/exe"
 181                             (values 'executable (string-length file3))))
 182                          #:file-port
 183                          (match-lambda
 184                            ("root/foo" (open-input-file file1))
 185                            ("root/dir/bar" (open-input-file file2))
 186                            ("root/dir/exe" (open-input-string file3)))
 187                          #:symlink-target
 188                          (match-lambda
 189                            ("root/lnk" "foo"))
 190                          #:directory-entries
 191                          (match-lambda
 192                            ("root" '("foo" "dir" "lnk"))
 193                            ("root/dir" '("bar" "exe"))))
 194         (close-port port)
 195
 196         (rm-rf %test-dir)
 197         (mkdir %test-dir)
 198         (restore-file (open-bytevector-input-port (get-bytevector))
 199                       output)
 200         (and (file=? (string-append output "/foo") file1)
 201              (string=? (readlink (string-append output "/lnk"))
 202                        "foo")
 203              (file=? (string-append output "/dir/bar") file2)
 204              (string=? (call-with-input-file (string-append output "/dir/exe")
 205                          get-string-all)
 206                        file3)
 207              (> (logand (stat:mode (lstat (string-append output "/dir/exe")))
 208                         #o100)
 209                 0)
 210              (equal? '("." ".." "bar" "exe")
 211                      (scandir (string-append output "/dir")))
 212              (equal? '("." ".." "dir" "foo" "lnk")
 213                      (scandir output))))
 214       (lambda ()
 215         (false-if-exception (rm-rf %test-dir))))))
 216
 217 (test-assert "write-file supports non-file output ports"
 218   (let ((input  (string-append (dirname (search-path %load-path "guix.scm"))
 219                                "/guix"))
 220         (output (%make-void-port "w")))
 221     (write-file input output)
 222     #t))
 223
 224 (test-equal "write-file puts file in C locale collation order"
 225   (base32 "0sfn5r63k88w9ls4hivnvscg82bqg8a0w7955l6xlk4g96jnb2z3")
 226   (let ((input (string-append %test-dir ".input")))
 227     (dynamic-wind
 228       (lambda ()
 229         (define (touch file)
 230           (call-with-output-file (string-append input "/" file)
 231             (const #t)))
 232
 233         (mkdir input)
 234         (touch "B")
 235         (touch "Z")
 236         (touch "a")
 237         (symlink "B" (string-append input "/z")))
 238       (lambda ()
 239         (let-values (((port get-hash) (open-sha256-port)))
 240           (write-file input port)
 241           (close-port port)
 242           (get-hash)))
 243       (lambda ()
 244         (rm-rf input)))))
 245
 246 (test-equal "restore-file with incomplete input"
 247   (string-append %test-dir "/foo")
 248   (let ((port (open-bytevector-input-port #vu8(1 2 3))))
 249     (guard (c ((nar-error? c)
 250                (and (eq? port (nar-error-port c))
 251                     (nar-error-file c))))
 252       (restore-file port (string-append %test-dir "/foo"))
 253       #f)))
 254
 255 (test-assert "write-file + restore-file"
 256   (let* ((input  (string-append (dirname (search-path %load-path "guix.scm"))
 257                                 "/guix"))
 258          (output %test-dir)
 259          (nar    (string-append output ".nar")))
 260     (dynamic-wind
 261       (lambda () #t)
 262       (lambda ()
 263         (call-with-output-file nar
 264           (cut write-file input <>))
 265         (call-with-input-file nar
 266           (cut restore-file <> output))
 267         (file-tree-equal? input output))
 268       (lambda ()
 269         (false-if-exception (delete-file nar))
 270         (false-if-exception (rm-rf output))))))
 271
 272 (test-assert "write-file + restore-file with symlinks"
 273   (let ((input (string-append %test-dir ".input")))
 274     (mkdir input)
 275     (dynamic-wind
 276       (const #t)
 277       (lambda ()
 278         (with-file-tree input
 279             (directory "root"
 280                        (("reg") ("exe" #o777) ("sym" -> "reg")))
 281           (let* ((output %test-dir)
 282                  (nar    (string-append output ".nar")))
 283             (dynamic-wind
 284               (lambda () #t)
 285               (lambda ()
 286                 (call-with-output-file nar
 287                   (cut write-file input <>))
 288                 (call-with-input-file nar
 289                   (cut restore-file <> output))
 290                 (file-tree-equal? input output))
 291               (lambda ()
 292                 (false-if-exception (delete-file nar))
 293                 (false-if-exception (rm-rf output)))))))
 294       (lambda ()
 295         (rmdir input)))))
 296
 297 (test-assert "write-file #:select? + restore-file"
 298   (let ((input (string-append %test-dir ".input")))
 299     (mkdir input)
 300     (dynamic-wind
 301       (const #t)
 302       (lambda ()
 303         (with-file-tree input
 304             (directory "root"
 305                        ((directory "a" (("x") ("y") ("z")))
 306                         ("b") ("c") ("d" -> "b")))
 307           (let* ((output %test-dir)
 308                  (nar    (string-append output ".nar")))
 309             (dynamic-wind
 310               (lambda () #t)
 311               (lambda ()
 312                 (call-with-output-file nar
 313                   (lambda (port)
 314                     (write-file input port
 315                                 #:select?
 316                                 (lambda (file stat)
 317                                   (and (not (string=? (basename file)
 318                                                       "a"))
 319                                        (not (eq? (stat:type stat)
 320                                                  'symlink)))))))
 321                 (call-with-input-file nar
 322                   (cut restore-file <> output))
 323
 324                 ;; Make sure "a" and "d" have been filtered out.
 325                 (and (not (file-exists? (string-append output "/root/a")))
 326                      (file=? (string-append output "/root/b")
 327                              (string-append input "/root/b"))
 328                      (file=? (string-append output "/root/c")
 329                              (string-append input "/root/c"))
 330                      (not (file-exists? (string-append output "/root/d")))))
 331               (lambda ()
 332                 (false-if-exception (delete-file nar))
 333                 (false-if-exception (rm-rf output)))))))
 334       (lambda ()
 335         (rmdir input)))))
 336
 337 (test-assert "restore-file-set (signed, valid)"
 338   (with-store store
 339     (let* ((texts (unfold (cut >= <> 10)
 340                           (lambda _ (random-text))
 341                           1+
 342                           0))
 343            (files (map (cut add-text-to-store store "text" <>) texts))
 344            (dump  (call-with-bytevector-output-port
 345                    (cut export-paths store files <>))))
 346       (delete-paths store files)
 347       (and (every (negate file-exists?) files)
 348            (let* ((source   (open-bytevector-input-port dump))
 349                   (imported (restore-file-set source)))
 350              (and (equal? imported files)
 351                   (every (lambda (file)
 352                            (and (file-exists? file)
 353                                 (valid-path? store file)))
 354                          files)
 355                   (equal? texts
 356                           (map (lambda (file)
 357                                  (call-with-input-file file
 358                                    get-string-all))
 359                                files))
 360                   (every canonical-file? files)))))))
 361
 362 (test-assert "restore-file-set with directories (signed, valid)"
 363   ;; <https://bugs.gnu.org/33361> describes a bug whereby directories
 364   ;; containing files subject to deduplication were not canonicalized--i.e.,
 365   ;; their mtime and permissions were not reset.  Ensure that this bug is
 366   ;; gone.
 367   (with-store store
 368     (let* ((text1 (random-text))
 369            (text2 (random-text))
 370            (tree  `("tree" directory
 371                     ("a" regular (data ,text1))
 372                     ("b" directory
 373                      ("c" regular (data ,text2))
 374                      ("d" regular (data ,text1))))) ;duplicate
 375            (file  (add-file-tree-to-store store tree))
 376            (dump  (call-with-bytevector-output-port
 377                    (cute export-paths store (list file) <>))))
 378       (delete-paths store (list file))
 379       (and (not (file-exists? file))
 380            (let* ((source   (open-bytevector-input-port dump))
 381                   (imported (restore-file-set source)))
 382              (and (equal? imported (list file))
 383                   (file-exists? file)
 384                   (valid-path? store file)
 385                   (string=? text1
 386                             (call-with-input-file (string-append file "/a")
 387                               get-string-all))
 388                   (string=? text2
 389                             (call-with-input-file
 390                                 (string-append file "/b/c")
 391                               get-string-all))
 392                   (= (stat:ino (stat (string-append file "/a"))) ;deduplication
 393                      (stat:ino (stat (string-append file "/b/d"))))
 394                   (every canonical-file?
 395                          (find-files file #:directories? #t))))))))
 396
 397 (test-assert "restore-file-set (missing signature)"
 398   (let/ec return
 399     (with-store store
 400       (let* ((file  (add-text-to-store store "foo" (random-text)))
 401              (dump  (call-with-bytevector-output-port
 402                      (cute export-paths store (list file) <>
 403                            #:sign? #f))))
 404         (delete-paths store (list file))
 405         (and (not (file-exists? file))
 406              (let ((source (open-bytevector-input-port dump)))
 407                (guard (c ((nar-signature-error? c)
 408                           (let ((message (condition-message c))
 409                                 (port    (nar-error-port c)))
 410                             (return
 411                              (and (string-match "lacks.*signature" message)
 412                                   (string=? file (nar-error-file c))
 413                                   (eq? source port))))))
 414                  (restore-file-set source))
 415                #f))))))
 416
 417 (test-assert "restore-file-set (corrupt)"
 418   (let/ec return
 419     (with-store store
 420       (let* ((file  (add-text-to-store store "foo"
 421                                        (random-text)))
 422              (dump  (call-with-bytevector-output-port
 423                      (cute export-paths store (list file) <>))))
 424         (delete-paths store (list file))
 425
 426         ;; Flip a byte in the file contents.
 427         (let* ((index 120)
 428                (byte  (bytevector-u8-ref dump index)))
 429           (bytevector-u8-set! dump index (logxor #xff byte)))
 430
 431         (and (not (file-exists? file))
 432              (let ((source (open-bytevector-input-port dump)))
 433                (guard (c ((nar-invalid-hash-error? c)
 434                           (let ((message (condition-message c))
 435                                 (port    (nar-error-port c)))
 436                             (return
 437                              (and (string-contains message "hash")
 438                                   (string=? file (nar-error-file c))
 439                                   (eq? source port))))))
 440                  (restore-file-set source))
 441                #f))))))
 442
 443 (test-end "nar")
 444
 445 ;;; Local Variables:
 446 ;;; eval: (put 'with-file-tree 'scheme-indent-function 2)
 447 ;;; End: