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