tests/nar.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 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 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 supports non-file output ports"
 156   (let ((input  (string-append (dirname (search-path %load-path "guix.scm"))
 157                                "/guix"))
 158         (output (%make-void-port "w")))
 159     (write-file input output)
 160     #t))
 161
 162 (test-equal "write-file puts file in C locale collation order"
 163   (base32 "0sfn5r63k88w9ls4hivnvscg82bqg8a0w7955l6xlk4g96jnb2z3")
 164   (let ((input (string-append %test-dir ".input")))
 165     (dynamic-wind
 166       (lambda ()
 167         (define (touch file)
 168           (call-with-output-file (string-append input "/" file)
 169             (const #t)))
 170
 171         (mkdir input)
 172         (touch "B")
 173         (touch "Z")
 174         (touch "a")
 175         (symlink "B" (string-append input "/z")))
 176       (lambda ()
 177         (let-values (((port get-hash) (open-sha256-port)))
 178           (write-file input port)
 179           (close-port port)
 180           (get-hash)))
 181       (lambda ()
 182         (rm-rf input)))))
 183
 184 (test-equal "restore-file with incomplete input"
 185   (string-append %test-dir "/foo")
 186   (let ((port (open-bytevector-input-port #vu8(1 2 3))))
 187     (guard (c ((nar-error? c)
 188                (and (eq? port (nar-error-port c))
 189                     (nar-error-file c))))
 190       (restore-file port (string-append %test-dir "/foo"))
 191       #f)))
 192
 193 (test-assert "write-file + restore-file"
 194   (let* ((input  (string-append (dirname (search-path %load-path "guix.scm"))
 195                                 "/guix"))
 196          (output %test-dir)
 197          (nar    (string-append output ".nar")))
 198     (dynamic-wind
 199       (lambda () #t)
 200       (lambda ()
 201         (call-with-output-file nar
 202           (cut write-file input <>))
 203         (call-with-input-file nar
 204           (cut restore-file <> output))
 205         (file-tree-equal? input output))
 206       (lambda ()
 207         (false-if-exception (delete-file nar))
 208         (false-if-exception (rm-rf output))))))
 209
 210 (test-assert "write-file + restore-file with symlinks"
 211   (let ((input (string-append %test-dir ".input")))
 212     (mkdir input)
 213     (dynamic-wind
 214       (const #t)
 215       (lambda ()
 216         (with-file-tree input
 217             (directory "root"
 218                        (("reg") ("exe" #o777) ("sym" -> "reg")))
 219           (let* ((output %test-dir)
 220                  (nar    (string-append output ".nar")))
 221             (dynamic-wind
 222               (lambda () #t)
 223               (lambda ()
 224                 (call-with-output-file nar
 225                   (cut write-file input <>))
 226                 (call-with-input-file nar
 227                   (cut restore-file <> output))
 228                 (file-tree-equal? input output))
 229               (lambda ()
 230                 (false-if-exception (delete-file nar))
 231                 (false-if-exception (rm-rf output)))))))
 232       (lambda ()
 233         (rmdir input)))))
 234
 235 (test-assert "write-file #:select? + restore-file"
 236   (let ((input (string-append %test-dir ".input")))
 237     (mkdir input)
 238     (dynamic-wind
 239       (const #t)
 240       (lambda ()
 241         (with-file-tree input
 242             (directory "root"
 243                        ((directory "a" (("x") ("y") ("z")))
 244                         ("b") ("c") ("d" -> "b")))
 245           (let* ((output %test-dir)
 246                  (nar    (string-append output ".nar")))
 247             (dynamic-wind
 248               (lambda () #t)
 249               (lambda ()
 250                 (call-with-output-file nar
 251                   (lambda (port)
 252                     (write-file input port
 253                                 #:select?
 254                                 (lambda (file stat)
 255                                   (and (not (string=? (basename file)
 256                                                       "a"))
 257                                        (not (eq? (stat:type stat)
 258                                                  'symlink)))))))
 259                 (call-with-input-file nar
 260                   (cut restore-file <> output))
 261
 262                 ;; Make sure "a" and "d" have been filtered out.
 263                 (and (not (file-exists? (string-append output "/root/a")))
 264                      (file=? (string-append output "/root/b")
 265                              (string-append input "/root/b"))
 266                      (file=? (string-append output "/root/c")
 267                              (string-append input "/root/c"))
 268                      (not (file-exists? (string-append output "/root/d")))))
 269               (lambda ()
 270                 (false-if-exception (delete-file nar))
 271                 (false-if-exception (rm-rf output)))))))
 272       (lambda ()
 273         (rmdir input)))))
 274
 275 ;; 'restore-file-set' depends on 'open-sha256-input-port', which in turn
 276 ;; relies on a Guile 2.0.10+ feature.
 277 (test-skip (if (false-if-exception
 278                 (open-sha256-input-port (%make-void-port "r")))
 279                0
 280                3))
 281
 282 (test-assert "restore-file-set (signed, valid)"
 283   (with-store store
 284     (let* ((texts (unfold (cut >= <> 10)
 285                           (lambda _ (random-text))
 286                           1+
 287                           0))
 288            (files (map (cut add-text-to-store store "text" <>) texts))
 289            (dump  (call-with-bytevector-output-port
 290                    (cut export-paths store files <>))))
 291       (delete-paths store files)
 292       (and (every (negate file-exists?) files)
 293            (let* ((source   (open-bytevector-input-port dump))
 294                   (imported (restore-file-set source)))
 295              (and (equal? imported files)
 296                   (every (lambda (file)
 297                            (and (file-exists? file)
 298                                 (valid-path? store file)))
 299                          files)
 300                   (equal? texts
 301                           (map (lambda (file)
 302                                  (call-with-input-file file
 303                                    get-string-all))
 304                                files))))))))
 305
 306 (test-assert "restore-file-set (missing signature)"
 307   (let/ec return
 308     (with-store store
 309       (let* ((file  (add-text-to-store store "foo" (random-text)))
 310              (dump  (call-with-bytevector-output-port
 311                      (cute export-paths store (list file) <>
 312                            #:sign? #f))))
 313         (delete-paths store (list file))
 314         (and (not (file-exists? file))
 315              (let ((source (open-bytevector-input-port dump)))
 316                (guard (c ((nar-signature-error? c)
 317                           (let ((message (condition-message c))
 318                                 (port    (nar-error-port c)))
 319                             (return
 320                              (and (string-match "lacks.*signature" message)
 321                                   (string=? file (nar-error-file c))
 322                                   (eq? source port))))))
 323                  (restore-file-set source))
 324                #f))))))
 325
 326 (test-assert "restore-file-set (corrupt)"
 327   (let/ec return
 328     (with-store store
 329       (let* ((file  (add-text-to-store store "foo"
 330                                        (random-text)))
 331              (dump  (call-with-bytevector-output-port
 332                      (cute export-paths store (list file) <>))))
 333         (delete-paths store (list file))
 334
 335         ;; Flip a byte in the file contents.
 336         (let* ((index 120)
 337                (byte  (bytevector-u8-ref dump index)))
 338           (bytevector-u8-set! dump index (logxor #xff byte)))
 339
 340         (and (not (file-exists? file))
 341              (let ((source (open-bytevector-input-port dump)))
 342                (guard (c ((nar-invalid-hash-error? c)
 343                           (let ((message (condition-message c))
 344                                 (port    (nar-error-port c)))
 345                             (return
 346                              (and (string-contains message "hash")
 347                                   (string=? file (nar-error-file c))
 348                                   (eq? source port))))))
 349                  (restore-file-set source))
 350                #f))))))
 351
 352 (test-end "nar")
 353
 354 ;;; Local Variables:
 355 ;;; eval: (put 'with-file-tree 'scheme-indent-function 2)
 356 ;;; End: