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