tests/store-roots.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2019 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-store-deduplication)
  20   #:use-module (guix tests)
  21   #:use-module (guix store)
  22   #:use-module (guix store roots)
  23   #:use-module ((guix utils) #:select (call-with-temporary-directory))
  24   #:use-module (srfi srfi-1)
  25   #:use-module (srfi srfi-64))
  26
  27 (define %store
  28   (open-connection))
  29
  30 (test-begin "store-roots")
  31
  32 (test-assert "gc-roots, regular root"
  33   (let* ((item (add-text-to-store %store "something"
  34                                   (random-text)))
  35          (root (string-append %gc-roots-directory "/test-gc-root")))
  36     (symlink item root)
  37     (let ((result (member root (gc-roots))))
  38       (delete-file root)
  39       result)))
  40
  41 (test-assert "gc-roots, indirect root"
  42   (call-with-temporary-directory
  43    (lambda (directory)
  44      (let* ((item (add-text-to-store %store "something"
  45                                      (random-text)))
  46             (root (string-append directory "/gc-root")))
  47        (symlink item root)
  48        (add-indirect-root %store root)
  49        (let ((result (member root (gc-roots))))
  50          (delete-file root)
  51          result)))))
  52
  53 (test-end "store-roots")