tests/nar.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013 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 (rnrs bytevectors)
  22   #:use-module (rnrs io ports)
  23   #:use-module (srfi srfi-26)
  24   #:use-module (srfi srfi-64)
  25   #:use-module (ice-9 ftw))
  26
  27 ;; Test the (guix nar) module.
  28
  29 (define (rm-rf dir)
  30   (file-system-fold (const #t)                    ; enter?
  31                     (lambda (file stat result)    ; leaf
  32                       (delete-file file))
  33                     (const #t)                    ; down
  34                     (lambda (dir stat result)     ; up
  35                       (rmdir dir))
  36                     (const #t)                    ; skip
  37                     (const #t)                    ; error
  38                     #t
  39                     dir
  40                     lstat))
  41
  42 \f
  43 (test-begin "nar")
  44
  45 (test-assert "write-file + restore-file"
  46   (let* ((input  (string-append (dirname (search-path %load-path "guix.scm"))
  47                                 "/guix"))
  48          (output (string-append (dirname input)
  49                                 "/test-nar-"
  50                                 (number->string (getpid))))
  51          (nar    (string-append output ".nar")))
  52     (dynamic-wind
  53       (lambda () #t)
  54       (lambda ()
  55         (call-with-output-file nar
  56           (cut write-file input <>))
  57         (call-with-input-file nar
  58           (cut restore-file <> output))
  59         (let* ((strip   (cute string-drop <> (string-length input)))
  60                (sibling (compose (cut string-append output <>) strip))
  61                (file=?  (lambda (a b)
  62                           (and (eq? (stat:type (lstat a)) (stat:type (lstat b)))
  63                                (case (stat:type (lstat a))
  64                                  ((regular)
  65                                   (equal?
  66                                    (call-with-input-file a get-bytevector-all)
  67                                    (call-with-input-file b get-bytevector-all)))
  68                                  ((symlink)
  69                                   (string=? (readlink a) (readlink b)))
  70                                  (else
  71                                   (error "what?" (lstat a))))))))
  72           (file-system-fold (const #t)
  73                             (lambda (name stat result) ; leaf
  74                               (and result
  75                                    (file=? name (sibling name))))
  76                             (lambda (name stat result) ; down
  77                               result)
  78                             (lambda (name stat result) ; up
  79                               result)
  80                             (const #f)                 ; skip
  81                             (lambda (name stat errno result)
  82                               (pk 'error name stat errno)
  83                               #f)
  84                             (> (stat:nlink (stat output)) 2)
  85                             input
  86                             lstat)))
  87       (lambda ()
  88         (false-if-exception (delete-file nar))
  89         (false-if-exception (rm-rf output))
  90         ))))
  91
  92 (test-end "nar")
  93
  94 \f
  95 (exit (= (test-runner-fail-count (test-runner-current)) 0))