tests/nar.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012-2021 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                       (unless (eq? 'symlink (stat:type stat))
 140                         (chmod file #o644))
 141                       (delete-file file))
 142                     (lambda (dir stat result)     ; down
 143                       (chmod dir #o755))
 144                     (lambda (dir stat result)     ; up
 145                       (rmdir dir))
 146                     (const #t)                    ; skip
 147                     (const #t)                    ; error
 148                     #t
 149                     dir
 150                     lstat))
 151
 152 (define %test-dir
 153   ;; An output directory under $top_builddir.
 154   (string-append (dirname (search-path %load-path "pre-inst-env"))
 155                  "/test-nar-" (number->string (getpid))))
 156
 157 \f
 158 (test-begin "nar")
 159
 160 (test-assert "write-file-tree + restore-file"
 161   (let* ((file1  (search-path %load-path "guix.scm"))
 162          (file2  (search-path %load-path "guix/base32.scm"))
 163          (file3  "#!/bin/something")
 164          (output (string-append %test-dir "/output")))
 165     (dynamic-wind
 166       (lambda () #t)
 167       (lambda ()
 168         (define-values (port get-bytevector)
 169           (open-bytevector-output-port))
 170         (write-file-tree "root" port
 171                          #:file-type+size
 172                          (match-lambda
 173                            ("root"
 174                             (values 'directory 0))
 175                            ("root/foo"
 176                             (values 'regular (stat:size (stat file1))))
 177                            ("root/lnk"
 178                             (values 'symlink 0))
 179                            ("root/dir"
 180                             (values 'directory 0))
 181                            ("root/dir/bar"
 182                             (values 'regular (stat:size (stat file2))))
 183                            ("root/dir/exe"
 184                             (values 'executable (string-length file3))))
 185                          #:file-port
 186                          (match-lambda
 187                            ("root/foo" (open-input-file file1))
 188                            ("root/dir/bar" (open-input-file file2))
 189                            ("root/dir/exe" (open-input-string file3)))
 190                          #:symlink-target
 191                          (match-lambda
 192                            ("root/lnk" "foo"))
 193                          #:directory-entries
 194                          (match-lambda
 195                            ("root" '("foo" "dir" "lnk"))
 196                            ("root/dir" '("bar" "exe"))))
 197         (close-port port)
 198
 199         (rm-rf %test-dir)
 200         (mkdir %test-dir)
 201         (restore-file (open-bytevector-input-port (get-bytevector))
 202                       output)
 203         (and (file=? (string-append output "/foo") file1)
 204              (string=? (readlink (string-append output "/lnk"))
 205                        "foo")
 206              (file=? (string-append output "/dir/bar") file2)
 207              (string=? (call-with-input-file (string-append output "/dir/exe")
 208                          get-string-all)
 209                        file3)
 210              (> (logand (stat:mode (lstat (string-append output "/dir/exe")))
 211                         #o100)
 212                 0)
 213              (equal? '("." ".." "bar" "exe")
 214                      (scandir (string-append output "/dir")))
 215              (equal? '("." ".." "dir" "foo" "lnk")
 216                      (scandir output))))
 217       (lambda ()
 218         (false-if-exception (rm-rf %test-dir))))))
 219
 220 (test-equal "write-file-tree + fold-archive"
 221   '(("R" directory #f)
 222     ("R/dir" directory #f)
 223     ("R/dir/exe" executable "1234")
 224     ("R/dir" directory-complete #f)
 225     ("R/foo" regular "abcdefg")
 226     ("R/lnk" symlink "foo")
 227     ("R" directory-complete #f))
 228
 229   (let ()
 230     (define-values (port get-bytevector)
 231       (open-bytevector-output-port))
 232     (write-file-tree "root" port
 233                      #:file-type+size
 234                      (match-lambda
 235                        ("root"
 236                         (values 'directory 0))
 237                        ("root/foo"
 238                         (values 'regular 7))
 239                        ("root/lnk"
 240                         (values 'symlink 0))
 241                        ("root/dir"
 242                         (values 'directory 0))
 243                        ("root/dir/exe"
 244                         (values 'executable 4)))
 245                      #:file-port
 246                      (match-lambda
 247                        ("root/foo" (open-input-string "abcdefg"))
 248                        ("root/dir/exe" (open-input-string "1234")))
 249                      #:symlink-target
 250                      (match-lambda
 251                        ("root/lnk" "foo"))
 252                      #:directory-entries
 253                      (match-lambda
 254                        ("root" '("foo" "dir" "lnk"))
 255                        ("root/dir" '("exe"))))
 256     (close-port port)
 257
 258     (reverse
 259      (fold-archive (lambda (file type contents result)
 260                      (let ((contents (if (memq type '(regular executable))
 261                                          (utf8->string
 262                                           (get-bytevector-n (car contents)
 263                                                             (cdr contents)))
 264                                          contents)))
 265                        (cons `(,file ,type ,contents)
 266                              result)))
 267                    '()
 268                    (open-bytevector-input-port (get-bytevector))
 269                    "R"))))
 270
 271 (test-equal "write-file-tree + fold-archive, flat file"
 272   '(("R" regular "abcdefg"))
 273
 274   (let ()
 275     (define-values (port get-bytevector)
 276       (open-bytevector-output-port))
 277     (write-file-tree "root" port
 278                      #:file-type+size
 279                      (match-lambda
 280                        ("root" (values 'regular 7)))
 281                      #:file-port
 282                      (match-lambda
 283                        ("root" (open-input-string "abcdefg"))))
 284     (close-port port)
 285
 286     (reverse
 287      (fold-archive (lambda (file type contents result)
 288                      (let ((contents (utf8->string
 289                                       (get-bytevector-n (car contents)
 290                                                         (cdr contents)))))
 291                        (cons `(,file ,type ,contents) result)))
 292                    '()
 293                    (open-bytevector-input-port (get-bytevector))
 294                    "R"))))
 295
 296 (test-assert "write-file supports non-file output ports"
 297   (let ((input  (string-append (dirname (search-path %load-path "guix.scm"))
 298                                "/guix"))
 299         (output (%make-void-port "w")))
 300     (write-file input output)
 301     #t))
 302
 303 (test-equal "write-file puts file in C locale collation order"
 304   (base32 "0sfn5r63k88w9ls4hivnvscg82bqg8a0w7955l6xlk4g96jnb2z3")
 305   (let ((input (string-append %test-dir ".input")))
 306     (dynamic-wind
 307       (lambda ()
 308         (define (touch file)
 309           (call-with-output-file (string-append input "/" file)
 310             (const #t)))
 311
 312         (mkdir input)
 313         (touch "B")
 314         (touch "Z")
 315         (touch "a")
 316         (symlink "B" (string-append input "/z")))
 317       (lambda ()
 318         (let-values (((port get-hash) (open-sha256-port)))
 319           (write-file input port)
 320           (close-port port)
 321           (get-hash)))
 322       (lambda ()
 323         (rm-rf input)))))
 324
 325 (test-equal "restore-file with incomplete input"
 326   (string-append %test-dir "/foo")
 327   (let ((port (open-bytevector-input-port #vu8(1 2 3))))
 328     (guard (c ((nar-error? c)
 329                (and (eq? port (nar-error-port c))
 330                     (nar-error-file c))))
 331       (restore-file port (string-append %test-dir "/foo"))
 332       #f)))
 333
 334 (test-assert "write-file + restore-file"
 335   (let* ((input  (string-append (dirname (search-path %load-path "guix.scm"))
 336                                 "/guix"))
 337          (output %test-dir)
 338          (nar    (string-append output ".nar")))
 339     (dynamic-wind
 340       (lambda () #t)
 341       (lambda ()
 342         (call-with-output-file nar
 343           (cut write-file input <>))
 344         (call-with-input-file nar
 345           (cut restore-file <> output))
 346         (file-tree-equal? input output))
 347       (lambda ()
 348         (false-if-exception (delete-file nar))
 349         (false-if-exception (rm-rf output))))))
 350
 351 (test-assert "write-file + restore-file with symlinks"
 352   (let ((input (string-append %test-dir ".input")))
 353     (mkdir input)
 354     (dynamic-wind
 355       (const #t)
 356       (lambda ()
 357         (with-file-tree input
 358             (directory "root"
 359                        (("reg") ("exe" #o777) ("sym" -> "reg")))
 360           (let* ((output %test-dir)
 361                  (nar    (string-append output ".nar")))
 362             (dynamic-wind
 363               (lambda () #t)
 364               (lambda ()
 365                 (call-with-output-file nar
 366                   (cut write-file input <>))
 367                 (call-with-input-file nar
 368                   (cut restore-file <> output))
 369
 370                 (and (file-tree-equal? input output)
 371                      (every (lambda (file)
 372                               (canonical-file?
 373                                (string-append output "/" file)))
 374                             '("root" "root/reg" "root/exe"))))
 375               (lambda ()
 376                 (false-if-exception (delete-file nar))
 377                 (false-if-exception (rm-rf output)))))))
 378       (lambda ()
 379         (rmdir input)))))
 380
 381 (test-assert "write-file #:select? + restore-file"
 382   (let ((input (string-append %test-dir ".input")))
 383     (mkdir input)
 384     (dynamic-wind
 385       (const #t)
 386       (lambda ()
 387         (with-file-tree input
 388             (directory "root"
 389                        ((directory "a" (("x") ("y") ("z")))
 390                         ("b") ("c") ("d" -> "b")))
 391           (let* ((output %test-dir)
 392                  (nar    (string-append output ".nar")))
 393             (dynamic-wind
 394               (lambda () #t)
 395               (lambda ()
 396                 (call-with-output-file nar
 397                   (lambda (port)
 398                     (write-file input port
 399                                 #:select?
 400                                 (lambda (file stat)
 401                                   (and (not (string=? (basename file)
 402                                                       "a"))
 403                                        (not (eq? (stat:type stat)
 404                                                  'symlink)))))))
 405                 (call-with-input-file nar
 406                   (cut restore-file <> output))
 407
 408                 ;; Make sure "a" and "d" have been filtered out.
 409                 (and (not (file-exists? (string-append output "/root/a")))
 410                      (file=? (string-append output "/root/b")
 411                              (string-append input "/root/b"))
 412                      (file=? (string-append output "/root/c")
 413                              (string-append input "/root/c"))
 414                      (not (file-exists? (string-append output "/root/d")))))
 415               (lambda ()
 416                 (false-if-exception (delete-file nar))
 417                 (false-if-exception (rm-rf output)))))))
 418       (lambda ()
 419         (rmdir input)))))
 420
 421 (test-eq "restore-file with non-UTF8 locale"     ;<https://bugs.gnu.org/33603>
 422   'encoding-error
 423   (let* ((file   (search-path %load-path "guix.scm"))
 424          (output (string-append %test-dir "/output"))
 425          (locale (setlocale LC_ALL "C")))
 426     (dynamic-wind
 427       (lambda () #t)
 428       (lambda ()
 429         (define-values (port get-bytevector)
 430           (open-bytevector-output-port))
 431
 432         (write-file-tree "root" port
 433                          #:file-type+size
 434                          (match-lambda
 435                            ("root"   (values 'directory 0))
 436                            ("root/λ" (values 'regular 0)))
 437                          #:file-port (const (%make-void-port "r"))
 438                          #:symlink-target (const #f)
 439                          #:directory-entries (const '("λ")))
 440         (close-port port)
 441
 442         (mkdir %test-dir)
 443         (catch 'encoding-error
 444           (lambda ()
 445             ;; This show throw to 'encoding-error.
 446             (restore-file (open-bytevector-input-port (get-bytevector))
 447                           output)
 448             (scandir output))
 449           (lambda args
 450             'encoding-error)))
 451       (lambda ()
 452         (false-if-exception (rm-rf %test-dir))
 453         (setlocale LC_ALL locale)))))
 454
 455 ;; XXX: Tell the 'deduplicate' procedure what store we're actually using.
 456 (setenv "NIX_STORE" (%store-prefix))
 457
 458 (test-assert "restore-file-set (signed, valid)"
 459   (with-store store
 460     (let* ((texts (unfold (cut >= <> 10)
 461                           (lambda _ (random-text))
 462                           1+
 463                           0))
 464            (files (map (cut add-text-to-store store "text" <>) texts))
 465            (dump  (call-with-bytevector-output-port
 466                    (cut export-paths store files <>))))
 467       (delete-paths store files)
 468       (and (every (negate file-exists?) files)
 469            (let* ((source   (open-bytevector-input-port dump))
 470                   (imported (restore-file-set source)))
 471              (and (equal? imported files)
 472                   (every (lambda (file)
 473                            (and (file-exists? file)
 474                                 (valid-path? store file)))
 475                          files)
 476                   (equal? texts
 477                           (map (lambda (file)
 478                                  (call-with-input-file file
 479                                    get-string-all))
 480                                files))
 481                   (every canonical-file? files)))))))
 482
 483 (test-assert "restore-file-set with directories (signed, valid)"
 484   ;; <https://bugs.gnu.org/33361> describes a bug whereby directories
 485   ;; containing files subject to deduplication were not canonicalized--i.e.,
 486   ;; their mtime and permissions were not reset.  Ensure that this bug is
 487   ;; gone.
 488   (with-store store
 489     ;; Note: TEXT1 and TEXT2 must be longer than %DEDUPLICATION-MINIMUM-SIZE.
 490     (let* ((text1 (string-concatenate (make-list 200 (random-text))))
 491            (text2 (string-concatenate (make-list 200 (random-text))))
 492            (tree  `("tree" directory
 493                     ("a" regular (data ,text1))
 494                     ("b" directory
 495                      ("c" regular (data ,text2))
 496                      ("d" regular (data ,text1))))) ;duplicate
 497            (file  (add-file-tree-to-store store tree))
 498            (dump  (call-with-bytevector-output-port
 499                    (cute export-paths store (list file) <>))))
 500       (delete-paths store (list file))
 501       (and (not (file-exists? file))
 502            (let* ((source   (open-bytevector-input-port dump))
 503                   (imported (restore-file-set source)))
 504              (and (equal? imported (list file))
 505                   (file-exists? file)
 506                   (valid-path? store file)
 507                   (string=? text1
 508                             (call-with-input-file (string-append file "/a")
 509                               get-string-all))
 510                   (string=? text2
 511                             (call-with-input-file
 512                                 (string-append file "/b/c")
 513                               get-string-all))
 514                   (= (stat:ino (stat (string-append file "/a"))) ;deduplication
 515                      (stat:ino (stat (string-append file "/b/d"))))
 516                   (every canonical-file?
 517                          (find-files file #:directories? #t))))))))
 518
 519 (test-assert "restore-file-set (missing signature)"
 520   (let/ec return
 521     (with-store store
 522       (let* ((file  (add-text-to-store store "foo" (random-text)))
 523              (dump  (call-with-bytevector-output-port
 524                      (cute export-paths store (list file) <>
 525                            #:sign? #f))))
 526         (delete-paths store (list file))
 527         (and (not (file-exists? file))
 528              (let ((source (open-bytevector-input-port dump)))
 529                (guard (c ((nar-signature-error? c)
 530                           (let ((message (condition-message c))
 531                                 (port    (nar-error-port c)))
 532                             (return
 533                              (and (string-match "lacks.*signature" message)
 534                                   (string=? file (nar-error-file c))
 535                                   (eq? source port))))))
 536                  (restore-file-set source))
 537                #f))))))
 538
 539 (test-assert "restore-file-set (corrupt)"
 540   (let/ec return
 541     (with-store store
 542       (let* ((file  (add-text-to-store store "foo"
 543                                        (random-text)))
 544              (dump  (call-with-bytevector-output-port
 545                      (cute export-paths store (list file) <>))))
 546         (delete-paths store (list file))
 547
 548         ;; Flip a byte in the file contents.
 549         (let* ((index 120)
 550                (byte  (bytevector-u8-ref dump index)))
 551           (bytevector-u8-set! dump index (logxor #xff byte)))
 552
 553         (and (not (file-exists? file))
 554              (let ((source (open-bytevector-input-port dump)))
 555                (guard (c ((nar-invalid-hash-error? c)
 556                           (let ((message (condition-message c))
 557                                 (port    (nar-error-port c)))
 558                             (return
 559                              (and (string-contains message "hash")
 560                                   (string=? file (nar-error-file c))
 561                                   (eq? source port))))))
 562                  (restore-file-set source))
 563                #f))))))
 564
 565 (test-end "nar")
 566
 567 ;;; Local Variables:
 568 ;;; eval: (put 'with-file-tree 'scheme-indent-function 2)
 569 ;;; End: