tests/store.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
  20 (define-module (test-store)
  21   #:use-module (guix store)
  22   #:use-module (guix utils)
  23   #:use-module (guix base32)
  24   #:use-module (guix packages)
  25   #:use-module (guix derivations)
  26   #:use-module (gnu packages)
  27   #:use-module (gnu packages bootstrap)
  28   #:use-module (ice-9 match)
  29   #:use-module (srfi srfi-1)
  30   #:use-module (srfi srfi-11)
  31   #:use-module (srfi srfi-64))
  32
  33 ;; Test the (guix store) module.
  34
  35 (define %store
  36   (false-if-exception (open-connection)))
  37
  38 (when %store
  39   ;; Make sure we build everything by ourselves.
  40   (set-build-options %store #:use-substitutes? #f))
  41
  42 (define %seed
  43   (seed->random-state (logxor (getpid) (car (gettimeofday)))))
  44
  45 (define (random-text)
  46   (number->string (random (expt 2 256) %seed) 16))
  47
  48 \f
  49 (test-begin "store")
  50
  51 (test-equal "store-path-hash-part"
  52   "283gqy39v3g9dxjy26rynl0zls82fmcg"
  53   (store-path-hash-part
  54    (string-append (%store-prefix)
  55                   "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7")))
  56
  57 (test-equal "store-path-hash-part #f"
  58   #f
  59   (store-path-hash-part
  60    (string-append (%store-prefix)
  61                   "/foo/bar/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7")))
  62
  63 (test-skip (if %store 0 10))
  64
  65 (test-assert "dead-paths"
  66   (let ((p (add-text-to-store %store "random-text"
  67                               (random-text) '())))
  68     (member p (dead-paths %store))))
  69
  70 ;; FIXME: Find a test for `live-paths'.
  71 ;;
  72 ;; (test-assert "temporary root is in live-paths"
  73 ;;   (let* ((p1 (add-text-to-store %store "random-text"
  74 ;;                                 (random-text) '()))
  75 ;;          (b  (add-text-to-store %store "link-builder"
  76 ;;                                 (format #f "echo ~a > $out" p1)
  77 ;;                                 '()))
  78 ;;          (d1 (derivation %store "link" (%current-system)
  79 ;;                          "/bin/sh" `("-e" ,b) '()
  80 ;;                          `((,b) (,p1))))
  81 ;;          (p2 (derivation-path->output-path d1)))
  82 ;;     (and (add-temp-root %store p2)
  83 ;;          (build-derivations %store (list d1))
  84 ;;          (valid-path? %store p1)
  85 ;;          (member (pk p2) (live-paths %store)))))
  86
  87 (test-assert "dead path can be explicitly collected"
  88   (let ((p (add-text-to-store %store "random-text"
  89                               (random-text) '())))
  90     (let-values (((paths freed) (delete-paths %store (list p))))
  91       (and (equal? paths (list p))
  92            (> freed 0)
  93            (not (file-exists? p))))))
  94
  95 (test-assert "references"
  96   (let* ((t1 (add-text-to-store %store "random1"
  97                                 (random-text) '()))
  98          (t2 (add-text-to-store %store "random2"
  99                                 (random-text) (list t1))))
 100     (and (equal? (list t1) (references %store t2))
 101          (equal? (list t2) (referrers %store t1))
 102          (null? (references %store t1))
 103          (null? (referrers %store t2)))))
 104
 105 (test-assert "derivers"
 106   (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
 107          (s (add-to-store %store "bash" #t "sha256"
 108                           (search-bootstrap-binary "bash"
 109                                                    (%current-system))))
 110          (d (derivation %store "the-thing" (%current-system)
 111                         s `("-e" ,b) `(("foo" . ,(random-text)))
 112                         `((,b) (,s))))
 113          (o (derivation-path->output-path d)))
 114     (and (build-derivations %store (list d))
 115          (equal? (query-derivation-outputs %store d)
 116                  (list o))
 117          (equal? (valid-derivers %store o)
 118                  (list d)))))
 119
 120 (test-assert "no substitutes"
 121   (let* ((s  (open-connection))
 122          (d1 (package-derivation s %bootstrap-guile (%current-system)))
 123          (d2 (package-derivation s %bootstrap-glibc (%current-system)))
 124          (o  (map derivation-path->output-path (list d1 d2))))
 125     (set-build-options s #:use-substitutes? #f)
 126     (and (not (has-substitutes? s d1))
 127          (not (has-substitutes? s d2))
 128          (null? (substitutable-paths s o))
 129          (null? (substitutable-path-info s o)))))
 130
 131 (test-end "store")
 132
 133 \f
 134 (exit (= (test-runner-fail-count (test-runner-current)) 0))