[jackhill/guix/guix.git] / tests / nar.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (test-nar)
  #:use-module (guix nar)
  #:use-module (guix store)
  #:use-module ((guix hash)
                #:select (open-sha256-port open-sha256-input-port))
  #:use-module ((guix packages)
                #:select (base32))
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (srfi srfi-64)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 match))

;; Test the (guix nar) module.

\f
;;;
;;; File system testing tools, initially contributed to Guile, then libchop.
;;;

(define (random-file-size)
  (define %average (* 1024 512))                  ; 512 KiB
  (define %stddev  (* 1024 64))                   ; 64 KiB
  (inexact->exact
   (max 0 (round (+ %average (* %stddev (random:normal)))))))

(define (make-file-tree dir tree)
  "Make file system TREE at DIR."
  (let loop ((dir  dir)
             (tree tree))
    (define (scope file)
      (string-append dir "/" file))

    (match tree
      (('directory name (body ...))
       (mkdir (scope name))
       (for-each (cute loop (scope name) <>) body))
      (('directory name (? integer? mode) (body ...))
       (mkdir (scope name))
       (for-each (cute loop (scope name) <>) body)
       (chmod (scope name) mode))
      ((file)
       (populate-file (scope file) (random-file-size)))
      ((file (? integer? mode))
       (populate-file (scope file) (random-file-size))
       (chmod (scope file) mode))
      ((from '-> to)
       (symlink to (scope from))))))

(define (delete-file-tree dir tree)
  "Delete file TREE from DIR."
  (let loop ((dir  dir)
             (tree tree))
    (define (scope file)
      (string-append dir "/" file))

    (match tree
      (('directory name (body ...))
       (for-each (cute loop (scope name) <>) body)
       (rmdir (scope name)))
      (('directory name (? integer? mode) (body ...))
       (chmod (scope name) #o755)          ; make sure it can be entered
       (for-each (cute loop (scope name) <>) body)
       (rmdir (scope name)))
      ((from '-> _)
       (delete-file (scope from)))
      ((file _ ...)
       (delete-file (scope file))))))

(define-syntax-rule (with-file-tree dir tree body ...)
  (dynamic-wind
    (lambda ()
      (make-file-tree dir 'tree))
    (lambda ()
      body ...)
    (lambda ()
      (delete-file-tree dir 'tree))))

(define (file-tree-equal? input output)
  "Return #t if the file trees at INPUT and OUTPUT are equal."
  (define strip
    (cute string-drop <> (string-length input)))
  (define sibling
    (compose (cut string-append output <>) strip))
  (define (file=? a b)
    (and (eq? (stat:type (lstat a)) (stat:type (lstat b)))
         (case (stat:type (lstat a))
           ((regular)
            (equal?
             (call-with-input-file a get-bytevector-all)
             (call-with-input-file b get-bytevector-all)))
           ((symlink)
            (string=? (readlink a) (readlink b)))
           (else
            (error "what?" (lstat a))))))

  (file-system-fold (const #t)
                    (lambda (name stat result)    ; leaf
                      (and result
                           (file=? name (sibling name))))
                    (lambda (name stat result)    ; down
                      result)
                    (lambda (name stat result)    ; up
                      result)
                    (const #f)                    ; skip
                    (lambda (name stat errno result)
                      (pk 'error name stat errno)
                      #f)
                    (> (stat:nlink (stat output)) 2)
                    input
                    lstat))

(define (make-random-bytevector n)
  (let ((bv (make-bytevector n)))
    (let loop ((i 0))
      (if (< i n)
          (begin
            (bytevector-u8-set! bv i (random 256))
            (loop (1+ i)))
          bv))))

(define (populate-file file size)
  (call-with-output-file file
    (lambda (p)
      (put-bytevector p (make-random-bytevector size)))))

(define (rm-rf dir)
  (file-system-fold (const #t)                    ; enter?
                    (lambda (file stat result)    ; leaf
                      (delete-file file))
                    (const #t)                    ; down
                    (lambda (dir stat result)     ; up
                      (rmdir dir))
                    (const #t)                    ; skip
                    (const #t)                    ; error
                    #t
                    dir
                    lstat))

(define %test-dir
  ;; An output directory under $top_builddir.
  (string-append (dirname (search-path %load-path "pre-inst-env"))
                 "/test-nar-" (number->string (getpid))))

;; XXX: Factorize.
(define %seed
  (seed->random-state (logxor (getpid) (car (gettimeofday)))))

(define (random-text)
  (number->string (random (expt 2 256) %seed) 16))

(define-syntax-rule (let/ec k exp...)
  ;; This one appeared in Guile 2.0.9, so provide a copy here.
  (let ((tag (make-prompt-tag)))
    (call-with-prompt tag
      (lambda ()
        (let ((k (lambda args
                   (apply abort-to-prompt tag args))))
          exp...))
      (lambda (_ . args)
        (apply values args)))))

\f
(test-begin "nar")

(test-assert "write-file supports non-file output ports"
  (let ((input  (string-append (dirname (search-path %load-path "guix.scm"))
                               "/guix"))
        (output (%make-void-port "w")))
    (write-file input output)
    #t))

(test-equal "write-file puts file in C locale collation order"
  (base32 "0sfn5r63k88w9ls4hivnvscg82bqg8a0w7955l6xlk4g96jnb2z3")
  (let ((input (string-append %test-dir ".input")))
    (dynamic-wind
      (lambda ()
        (define (touch file)
          (call-with-output-file (string-append input "/" file)
            (const #t)))

        (mkdir input)
        (touch "B")
        (touch "Z")
        (touch "a")
        (symlink "B" (string-append input "/z")))
      (lambda ()
        (let-values (((port get-hash) (open-sha256-port)))
          (write-file input port)
          (get-hash)))
      (lambda ()
        (rm-rf input)))))

(test-assert "write-file + restore-file"
  (let* ((input  (string-append (dirname (search-path %load-path "guix.scm"))
                                "/guix"))
         (output %test-dir)
         (nar    (string-append output ".nar")))
    (dynamic-wind
      (lambda () #t)
      (lambda ()
        (call-with-output-file nar
          (cut write-file input <>))
        (call-with-input-file nar
          (cut restore-file <> output))
        (file-tree-equal? input output))
      (lambda ()
        (false-if-exception (delete-file nar))
        (false-if-exception (rm-rf output))))))

(test-assert "write-file + restore-file with symlinks"
  (let ((input (string-append %test-dir ".input")))
    (mkdir input)
    (dynamic-wind
      (const #t)
      (lambda ()
        (with-file-tree input
            (directory "root"
                       (("reg") ("exe" #o777) ("sym" -> "reg")))
          (let* ((output %test-dir)
                 (nar    (string-append output ".nar")))
            (dynamic-wind
              (lambda () #t)
              (lambda ()
                (call-with-output-file nar
                  (cut write-file input <>))
                (call-with-input-file nar
                  (cut restore-file <> output))
                (file-tree-equal? input output))
              (lambda ()
                (false-if-exception (delete-file nar))
                (false-if-exception (rm-rf output)))))))
      (lambda ()
        (rmdir input)))))

;; 'restore-file-set' depends on 'open-sha256-input-port', which in turn
;; relies on a Guile 2.0.10+ feature.
(test-skip (if (false-if-exception
                (open-sha256-input-port (%make-void-port "r")))
               0
               3))

(test-assert "restore-file-set (signed, valid)"
  (with-store store
    (let* ((texts (unfold (cut >= <> 10)
                          (lambda _ (random-text))
                          1+
                          0))
           (files (map (cut add-text-to-store store "text" <>) texts))
           (dump  (call-with-bytevector-output-port
                   (cut export-paths store files <>))))
      (delete-paths store files)
      (and (every (negate file-exists?) files)
           (let* ((source   (open-bytevector-input-port dump))
                  (imported (restore-file-set source)))
             (and (equal? imported files)
                  (every (lambda (file)
                           (and (file-exists? file)
                                (valid-path? store file)))
                         files)
                  (equal? texts
                          (map (lambda (file)
                                 (call-with-input-file file
                                   get-string-all))
                               files))))))))

(test-assert "restore-file-set (missing signature)"
  (let/ec return
    (with-store store
      (let* ((file  (add-text-to-store store "foo" "Hello, world!"))
             (dump  (call-with-bytevector-output-port
                     (cute export-paths store (list file) <>
                           #:sign? #f))))
        (delete-paths store (list file))
        (and (not (file-exists? file))
             (let ((source (open-bytevector-input-port dump)))
               (guard (c ((nar-signature-error? c)
                          (let ((message (condition-message c))
                                (port    (nar-error-port c)))
                            (return
                             (and (string-match "lacks.*signature" message)
                                  (string=? file (nar-error-file c))
                                  (eq? source port))))))
                 (restore-file-set source))
               #f))))))

(test-assert "restore-file-set (corrupt)"
  (let/ec return
    (with-store store
      (let* ((file  (add-text-to-store store "foo"
                                       (random-text)))
             (dump  (call-with-bytevector-output-port
                     (cute export-paths store (list file) <>))))
        (delete-paths store (list file))

        ;; Flip a byte in the file contents.
        (let* ((index 120)
               (byte  (bytevector-u8-ref dump index)))
          (bytevector-u8-set! dump index (logxor #xff byte)))

        (and (not (file-exists? file))
             (let ((source (open-bytevector-input-port dump)))
               (guard (c ((nar-invalid-hash-error? c)
                          (let ((message (condition-message c))
                                (port    (nar-error-port c)))
                            (return
                             (and (string-contains message "hash")
                                  (string=? file (nar-error-file c))
                                  (eq? source port))))))
                 (restore-file-set source))
               #f))))))

(test-end "nar")

\f
(exit (= (test-runner-fail-count (test-runner-current)) 0))

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