tests/nar.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 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-eq "restore-file with non-UTF8 locale"     ;<https://bugs.gnu.org/33603>
 338   'encoding-error
 339   (let* ((file   (search-path %load-path "guix.scm"))
 340          (output (string-append %test-dir "/output"))
 341          (locale (setlocale LC_ALL "C")))
 342     (dynamic-wind
 343       (lambda () #t)
 344       (lambda ()
 345         (define-values (port get-bytevector)
 346           (open-bytevector-output-port))
 347
 348         (write-file-tree "root" port
 349                          #:file-type+size
 350                          (match-lambda
 351                            ("root"   (values 'directory 0))
 352                            ("root/λ" (values 'regular 0)))
 353                          #:file-port (const (%make-void-port "r"))
 354                          #:symlink-target (const #f)
 355                          #:directory-entries (const '("λ")))
 356         (close-port port)
 357
 358         (mkdir %test-dir)
 359         (catch 'encoding-error
 360           (lambda ()
 361             ;; This show throw to 'encoding-error.
 362             (restore-file (open-bytevector-input-port (get-bytevector))
 363                           output)
 364             (scandir output))
 365           (lambda args
 366             'encoding-error)))
 367       (lambda ()
 368         (false-if-exception (rm-rf %test-dir))
 369         (setlocale LC_ALL locale)))))
 370
 371 (test-assert "restore-file-set (signed, valid)"
 372   (with-store store
 373     (let* ((texts (unfold (cut >= <> 10)
 374                           (lambda _ (random-text))
 375                           1+
 376                           0))
 377            (files (map (cut add-text-to-store store "text" <>) texts))
 378            (dump  (call-with-bytevector-output-port
 379                    (cut export-paths store files <>))))
 380       (delete-paths store files)
 381       (and (every (negate file-exists?) files)
 382            (let* ((source   (open-bytevector-input-port dump))
 383                   (imported (restore-file-set source)))
 384              (and (equal? imported files)
 385                   (every (lambda (file)
 386                            (and (file-exists? file)
 387                                 (valid-path? store file)))
 388                          files)
 389                   (equal? texts
 390                           (map (lambda (file)
 391                                  (call-with-input-file file
 392                                    get-string-all))
 393                                files))
 394                   (every canonical-file? files)))))))
 395
 396 (test-assert "restore-file-set with directories (signed, valid)"
 397   ;; <https://bugs.gnu.org/33361> describes a bug whereby directories
 398   ;; containing files subject to deduplication were not canonicalized--i.e.,
 399   ;; their mtime and permissions were not reset.  Ensure that this bug is
 400   ;; gone.
 401   (with-store store
 402     (let* ((text1 (random-text))
 403            (text2 (random-text))
 404            (tree  `("tree" directory
 405                     ("a" regular (data ,text1))
 406                     ("b" directory
 407                      ("c" regular (data ,text2))
 408                      ("d" regular (data ,text1))))) ;duplicate
 409            (file  (add-file-tree-to-store store tree))
 410            (dump  (call-with-bytevector-output-port
 411                    (cute export-paths store (list file) <>))))
 412       (delete-paths store (list file))
 413       (and (not (file-exists? file))
 414            (let* ((source   (open-bytevector-input-port dump))
 415                   (imported (restore-file-set source)))
 416              (and (equal? imported (list file))
 417                   (file-exists? file)
 418                   (valid-path? store file)
 419                   (string=? text1
 420                             (call-with-input-file (string-append file "/a")
 421                               get-string-all))
 422                   (string=? text2
 423                             (call-with-input-file
 424                                 (string-append file "/b/c")
 425                               get-string-all))
 426                   (= (stat:ino (stat (string-append file "/a"))) ;deduplication
 427                      (stat:ino (stat (string-append file "/b/d"))))
 428                   (every canonical-file?
 429                          (find-files file #:directories? #t))))))))
 430
 431 (test-assert "restore-file-set (missing signature)"
 432   (let/ec return
 433     (with-store store
 434       (let* ((file  (add-text-to-store store "foo" (random-text)))
 435              (dump  (call-with-bytevector-output-port
 436                      (cute export-paths store (list file) <>
 437                            #:sign? #f))))
 438         (delete-paths store (list file))
 439         (and (not (file-exists? file))
 440              (let ((source (open-bytevector-input-port dump)))
 441                (guard (c ((nar-signature-error? c)
 442                           (let ((message (condition-message c))
 443                                 (port    (nar-error-port c)))
 444                             (return
 445                              (and (string-match "lacks.*signature" message)
 446                                   (string=? file (nar-error-file c))
 447                                   (eq? source port))))))
 448                  (restore-file-set source))
 449                #f))))))
 450
 451 (test-assert "restore-file-set (corrupt)"
 452   (let/ec return
 453     (with-store store
 454       (let* ((file  (add-text-to-store store "foo"
 455                                        (random-text)))
 456              (dump  (call-with-bytevector-output-port
 457                      (cute export-paths store (list file) <>))))
 458         (delete-paths store (list file))
 459
 460         ;; Flip a byte in the file contents.
 461         (let* ((index 120)
 462                (byte  (bytevector-u8-ref dump index)))
 463           (bytevector-u8-set! dump index (logxor #xff byte)))
 464
 465         (and (not (file-exists? file))
 466              (let ((source (open-bytevector-input-port dump)))
 467                (guard (c ((nar-invalid-hash-error? c)
 468                           (let ((message (condition-message c))
 469                                 (port    (nar-error-port c)))
 470                             (return
 471                              (and (string-contains message "hash")
 472                                   (string=? file (nar-error-file c))
 473                                   (eq? source port))))))
 474                  (restore-file-set source))
 475                #f))))))
 476
 477 (test-end "nar")
 478
 479 ;;; Local Variables:
 480 ;;; eval: (put 'with-file-tree 'scheme-indent-function 2)
 481 ;;; End: