tests/nar.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014 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 match))
  39
  40 ;; Test the (guix nar) module.
  41
  42 \f
  43 ;;;
  44 ;;; File system testing tools, initially contributed to Guile, then libchop.
  45 ;;;
  46
  47 (define (random-file-size)
  48   (define %average (* 1024 512))                  ; 512 KiB
  49   (define %stddev  (* 1024 64))                   ; 64 KiB
  50   (inexact->exact
  51    (max 0 (round (+ %average (* %stddev (random:normal)))))))
  52
  53 (define (make-file-tree dir tree)
  54   "Make file system TREE at DIR."
  55   (let loop ((dir  dir)
  56              (tree tree))
  57     (define (scope file)
  58       (string-append dir "/" file))
  59
  60     (match tree
  61       (('directory name (body ...))
  62        (mkdir (scope name))
  63        (for-each (cute loop (scope name) <>) body))
  64       (('directory name (? integer? mode) (body ...))
  65        (mkdir (scope name))
  66        (for-each (cute loop (scope name) <>) body)
  67        (chmod (scope name) mode))
  68       ((file)
  69        (populate-file (scope file) (random-file-size)))
  70       ((file (? integer? mode))
  71        (populate-file (scope file) (random-file-size))
  72        (chmod (scope file) mode))
  73       ((from '-> to)
  74        (symlink to (scope from))))))
  75
  76 (define (delete-file-tree dir tree)
  77   "Delete file TREE from DIR."
  78   (let loop ((dir  dir)
  79              (tree tree))
  80     (define (scope file)
  81       (string-append dir "/" file))
  82
  83     (match tree
  84       (('directory name (body ...))
  85        (for-each (cute loop (scope name) <>) body)
  86        (rmdir (scope name)))
  87       (('directory name (? integer? mode) (body ...))
  88        (chmod (scope name) #o755)          ; make sure it can be entered
  89        (for-each (cute loop (scope name) <>) body)
  90        (rmdir (scope name)))
  91       ((from '-> _)
  92        (delete-file (scope from)))
  93       ((file _ ...)
  94        (delete-file (scope file))))))
  95
  96 (define-syntax-rule (with-file-tree dir tree body ...)
  97   (dynamic-wind
  98     (lambda ()
  99       (make-file-tree dir 'tree))
 100     (lambda ()
 101       body ...)
 102     (lambda ()
 103       (delete-file-tree dir 'tree))))
 104
 105 (define (file-tree-equal? input output)
 106   "Return #t if the file trees at INPUT and OUTPUT are equal."
 107   (define strip
 108     (cute string-drop <> (string-length input)))
 109   (define sibling
 110     (compose (cut string-append output <>) strip))
 111   (define (file=? a b)
 112     (and (eq? (stat:type (lstat a)) (stat:type (lstat b)))
 113          (case (stat:type (lstat a))
 114            ((regular)
 115             (equal?
 116              (call-with-input-file a get-bytevector-all)
 117              (call-with-input-file b get-bytevector-all)))
 118            ((symlink)
 119             (string=? (readlink a) (readlink b)))
 120            (else
 121             (error "what?" (lstat a))))))
 122
 123   (file-system-fold (const #t)
 124                     (lambda (name stat result)    ; leaf
 125                       (and result
 126                            (file=? name (sibling name))))
 127                     (lambda (name stat result)    ; down
 128                       result)
 129                     (lambda (name stat result)    ; up
 130                       result)
 131                     (const #f)                    ; skip
 132                     (lambda (name stat errno result)
 133                       (pk 'error name stat errno)
 134                       #f)
 135                     (> (stat:nlink (stat output)) 2)
 136                     input
 137                     lstat))
 138
 139 (define (populate-file file size)
 140   (call-with-output-file file
 141     (lambda (p)
 142       (put-bytevector p (random-bytevector size)))))
 143
 144 (define (rm-rf dir)
 145   (file-system-fold (const #t)                    ; enter?
 146                     (lambda (file stat result)    ; leaf
 147                       (delete-file file))
 148                     (const #t)                    ; down
 149                     (lambda (dir stat result)     ; up
 150                       (rmdir dir))
 151                     (const #t)                    ; skip
 152                     (const #t)                    ; error
 153                     #t
 154                     dir
 155                     lstat))
 156
 157 (define %test-dir
 158   ;; An output directory under $top_builddir.
 159   (string-append (dirname (search-path %load-path "pre-inst-env"))
 160                  "/test-nar-" (number->string (getpid))))
 161
 162 (define-syntax-rule (let/ec k exp...)
 163   ;; This one appeared in Guile 2.0.9, so provide a copy here.
 164   (let ((tag (make-prompt-tag)))
 165     (call-with-prompt tag
 166       (lambda ()
 167         (let ((k (lambda args
 168                    (apply abort-to-prompt tag args))))
 169           exp...))
 170       (lambda (_ . args)
 171         (apply values args)))))
 172
 173 \f
 174 (test-begin "nar")
 175
 176 (test-assert "write-file supports non-file output ports"
 177   (let ((input  (string-append (dirname (search-path %load-path "guix.scm"))
 178                                "/guix"))
 179         (output (%make-void-port "w")))
 180     (write-file input output)
 181     #t))
 182
 183 (test-equal "write-file puts file in C locale collation order"
 184   (base32 "0sfn5r63k88w9ls4hivnvscg82bqg8a0w7955l6xlk4g96jnb2z3")
 185   (let ((input (string-append %test-dir ".input")))
 186     (dynamic-wind
 187       (lambda ()
 188         (define (touch file)
 189           (call-with-output-file (string-append input "/" file)
 190             (const #t)))
 191
 192         (mkdir input)
 193         (touch "B")
 194         (touch "Z")
 195         (touch "a")
 196         (symlink "B" (string-append input "/z")))
 197       (lambda ()
 198         (let-values (((port get-hash) (open-sha256-port)))
 199           (write-file input port)
 200           (get-hash)))
 201       (lambda ()
 202         (rm-rf input)))))
 203
 204 (test-assert "write-file + restore-file"
 205   (let* ((input  (string-append (dirname (search-path %load-path "guix.scm"))
 206                                 "/guix"))
 207          (output %test-dir)
 208          (nar    (string-append output ".nar")))
 209     (dynamic-wind
 210       (lambda () #t)
 211       (lambda ()
 212         (call-with-output-file nar
 213           (cut write-file input <>))
 214         (call-with-input-file nar
 215           (cut restore-file <> output))
 216         (file-tree-equal? input output))
 217       (lambda ()
 218         (false-if-exception (delete-file nar))
 219         (false-if-exception (rm-rf output))))))
 220
 221 (test-assert "write-file + restore-file with symlinks"
 222   (let ((input (string-append %test-dir ".input")))
 223     (mkdir input)
 224     (dynamic-wind
 225       (const #t)
 226       (lambda ()
 227         (with-file-tree input
 228             (directory "root"
 229                        (("reg") ("exe" #o777) ("sym" -> "reg")))
 230           (let* ((output %test-dir)
 231                  (nar    (string-append output ".nar")))
 232             (dynamic-wind
 233               (lambda () #t)
 234               (lambda ()
 235                 (call-with-output-file nar
 236                   (cut write-file input <>))
 237                 (call-with-input-file nar
 238                   (cut restore-file <> output))
 239                 (file-tree-equal? input output))
 240               (lambda ()
 241                 (false-if-exception (delete-file nar))
 242                 (false-if-exception (rm-rf output)))))))
 243       (lambda ()
 244         (rmdir input)))))
 245
 246 ;; 'restore-file-set' depends on 'open-sha256-input-port', which in turn
 247 ;; relies on a Guile 2.0.10+ feature.
 248 (test-skip (if (false-if-exception
 249                 (open-sha256-input-port (%make-void-port "r")))
 250                0
 251                3))
 252
 253 (test-assert "restore-file-set (signed, valid)"
 254   (with-store store
 255     (let* ((texts (unfold (cut >= <> 10)
 256                           (lambda _ (random-text))
 257                           1+
 258                           0))
 259            (files (map (cut add-text-to-store store "text" <>) texts))
 260            (dump  (call-with-bytevector-output-port
 261                    (cut export-paths store files <>))))
 262       (delete-paths store files)
 263       (and (every (negate file-exists?) files)
 264            (let* ((source   (open-bytevector-input-port dump))
 265                   (imported (restore-file-set source)))
 266              (and (equal? imported files)
 267                   (every (lambda (file)
 268                            (and (file-exists? file)
 269                                 (valid-path? store file)))
 270                          files)
 271                   (equal? texts
 272                           (map (lambda (file)
 273                                  (call-with-input-file file
 274                                    get-string-all))
 275                                files))))))))
 276
 277 (test-assert "restore-file-set (missing signature)"
 278   (let/ec return
 279     (with-store store
 280       (let* ((file  (add-text-to-store store "foo" "Hello, world!"))
 281              (dump  (call-with-bytevector-output-port
 282                      (cute export-paths store (list file) <>
 283                            #:sign? #f))))
 284         (delete-paths store (list file))
 285         (and (not (file-exists? file))
 286              (let ((source (open-bytevector-input-port dump)))
 287                (guard (c ((nar-signature-error? c)
 288                           (let ((message (condition-message c))
 289                                 (port    (nar-error-port c)))
 290                             (return
 291                              (and (string-match "lacks.*signature" message)
 292                                   (string=? file (nar-error-file c))
 293                                   (eq? source port))))))
 294                  (restore-file-set source))
 295                #f))))))
 296
 297 (test-assert "restore-file-set (corrupt)"
 298   (let/ec return
 299     (with-store store
 300       (let* ((file  (add-text-to-store store "foo"
 301                                        (random-text)))
 302              (dump  (call-with-bytevector-output-port
 303                      (cute export-paths store (list file) <>))))
 304         (delete-paths store (list file))
 305
 306         ;; Flip a byte in the file contents.
 307         (let* ((index 120)
 308                (byte  (bytevector-u8-ref dump index)))
 309           (bytevector-u8-set! dump index (logxor #xff byte)))
 310
 311         (and (not (file-exists? file))
 312              (let ((source (open-bytevector-input-port dump)))
 313                (guard (c ((nar-invalid-hash-error? c)
 314                           (let ((message (condition-message c))
 315                                 (port    (nar-error-port c)))
 316                             (return
 317                              (and (string-contains message "hash")
 318                                   (string=? file (nar-error-file c))
 319                                   (eq? source port))))))
 320                  (restore-file-set source))
 321                #f))))))
 322
 323 (test-end "nar")
 324
 325 \f
 326 (exit (= (test-runner-fail-count (test-runner-current)) 0))
 327
 328 ;;; Local Variables:
 329 ;;; eval: (put 'with-file-tree 'scheme-indent-function 2)
 330 ;;; End: