tests/inferior.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018, 2019, 2020 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-inferior)
  20   #:use-module (guix tests)
  21   #:use-module (guix inferior)
  22   #:use-module (guix packages)
  23   #:use-module (guix store)
  24   #:use-module (guix profiles)
  25   #:use-module (guix derivations)
  26   #:use-module (gnu packages)
  27   #:use-module (gnu packages bootstrap)
  28   #:use-module (gnu packages guile)
  29   #:use-module (srfi srfi-1)
  30   #:use-module (srfi srfi-34)
  31   #:use-module (srfi srfi-64)
  32   #:use-module (ice-9 match))
  33
  34 (define %top-srcdir
  35   (dirname (search-path %load-path "guix.scm")))
  36
  37 (define %top-builddir
  38   (dirname (search-path %load-compiled-path "guix.go")))
  39
  40 (define %store
  41   (open-connection-for-tests))
  42
  43 (define (manifest-entry->list entry)
  44   (list (manifest-entry-name entry)
  45         (manifest-entry-version entry)
  46         (manifest-entry-output entry)
  47         (manifest-entry-search-paths entry)
  48         (map manifest-entry->list (manifest-entry-dependencies entry))))
  49
  50 \f
  51 (test-begin "inferior")
  52
  53 (test-equal "open-inferior"
  54   '(42 #t)
  55   (let ((inferior (open-inferior %top-builddir
  56                                  #:command "scripts/guix")))
  57     (and (inferior? inferior)
  58          (let ((a (inferior-eval '(apply * '(6 7)) inferior))
  59                (b (inferior-eval '(@ (gnu packages base) coreutils)
  60                                  inferior)))
  61            (close-inferior inferior)
  62            (list a (inferior-object? b))))))
  63
  64 (test-equal "&inferior-exception"
  65   '(a b c d)
  66   (let ((inferior (open-inferior %top-builddir
  67                                  #:command "scripts/guix")))
  68     (guard (c ((inferior-exception? c)
  69                (close-inferior inferior)
  70                (and (eq? inferior (inferior-exception-inferior c))
  71                     (inferior-exception-arguments c))))
  72       (inferior-eval '(throw 'a 'b 'c 'd) inferior)
  73       'badness)))
  74
  75 (test-equal "inferior-packages"
  76   (take (sort (fold-packages (lambda (package lst)
  77                                (cons (list (package-name package)
  78                                            (package-version package)
  79                                            (package-home-page package)
  80                                            (package-location package))
  81                                      lst))
  82                              '())
  83               (lambda (x y)
  84                 (string<? (car x) (car y))))
  85         10)
  86   (let* ((inferior (open-inferior %top-builddir
  87                                   #:command "scripts/guix"))
  88          (packages (inferior-packages inferior)))
  89     (and (every string? (map inferior-package-synopsis packages))
  90          (let ()
  91            (define result
  92              (take (sort (map (lambda (package)
  93                                 (list (inferior-package-name package)
  94                                       (inferior-package-version package)
  95                                       (inferior-package-home-page package)
  96                                       (inferior-package-location package)))
  97                               packages)
  98                          (lambda (x y)
  99                            (string<? (car x) (car y))))
 100                    10))
 101            (close-inferior inferior)
 102            result))))
 103
 104 (test-equal "inferior-available-packages"
 105   (take (sort (fold-available-packages
 106                (lambda* (name version result
 107                               #:key supported? deprecated?
 108                               #:allow-other-keys)
 109                  (if (and supported? (not deprecated?))
 110                      (alist-cons name version result)
 111                      result))
 112                '())
 113               (lambda (x y)
 114                 (string<? (car x) (car y))))
 115         10)
 116   (let* ((inferior (open-inferior %top-builddir
 117                                   #:command "scripts/guix"))
 118          (packages (inferior-available-packages inferior)))
 119     (close-inferior inferior)
 120     (take (sort packages (lambda (x y)
 121                            (string<? (car x) (car y))))
 122           10)))
 123
 124 (test-equal "lookup-inferior-packages"
 125   (let ((->list (lambda (package)
 126                   (list (package-name package)
 127                         (package-version package)
 128                         (package-location package)))))
 129     (list (map ->list (find-packages-by-name "guile" #f))
 130           (map ->list (find-packages-by-name "guile" "2.2"))))
 131   (let* ((inferior (open-inferior %top-builddir
 132                                   #:command "scripts/guix"))
 133          (->list   (lambda (package)
 134                      (list (inferior-package-name package)
 135                            (inferior-package-version package)
 136                            (inferior-package-location package))))
 137          (lst1     (map ->list
 138                         (lookup-inferior-packages inferior "guile")))
 139          (lst2     (map ->list
 140                         (lookup-inferior-packages inferior
 141                                                   "guile" "2.2"))))
 142     (close-inferior inferior)
 143     (list lst1 lst2)))
 144
 145 (test-assert "lookup-inferior-packages and eq?-ness"
 146   (let* ((inferior (open-inferior %top-builddir
 147                                   #:command "scripts/guix"))
 148          (lst1     (lookup-inferior-packages inferior "guile"))
 149          (lst2     (lookup-inferior-packages inferior "guile")))
 150     (close-inferior inferior)
 151     (every eq? lst1 lst2)))
 152
 153 (test-equal "inferior-package-inputs"
 154   (let ((->list (match-lambda
 155                   ((label (? package? package) . rest)
 156                    `(,label
 157                      (package ,(package-name package)
 158                               ,(package-version package)
 159                               ,(package-location package))
 160                      ,@rest)))))
 161     (list (map ->list (package-inputs guile-2.2))
 162           (map ->list (package-native-inputs guile-2.2))
 163           (map ->list (package-propagated-inputs guile-2.2))))
 164   (let* ((inferior (open-inferior %top-builddir
 165                                   #:command "scripts/guix"))
 166          (guile    (first (lookup-inferior-packages inferior "guile")))
 167          (->list   (match-lambda
 168                      ((label (? inferior-package? package) . rest)
 169                       `(,label
 170                         (package ,(inferior-package-name package)
 171                                  ,(inferior-package-version package)
 172                                  ,(inferior-package-location package))
 173                         ,@rest))))
 174          (result   (list (map ->list (inferior-package-inputs guile))
 175                          (map ->list
 176                               (inferior-package-native-inputs guile))
 177                          (map ->list
 178                               (inferior-package-propagated-inputs
 179                                guile)))))
 180     (close-inferior inferior)
 181     result))
 182
 183 (test-equal "inferior-package-search-paths"
 184   (package-native-search-paths guile-2.2)
 185   (let* ((inferior (open-inferior %top-builddir
 186                                   #:command "scripts/guix"))
 187          (guile    (first (lookup-inferior-packages inferior "guile")))
 188          (result   (inferior-package-native-search-paths guile)))
 189     (close-inferior inferior)
 190     result))
 191
 192 (test-equal "inferior-eval-with-store"
 193   (add-text-to-store %store "foo" "Hello, world!")
 194   (let* ((inferior (open-inferior %top-builddir
 195                                   #:command "scripts/guix")))
 196     (inferior-eval-with-store inferior %store
 197                               '(lambda (store)
 198                                  (add-text-to-store store "foo"
 199                                                     "Hello, world!")))))
 200
 201 (test-assert "inferior-eval-with-store, &store-protocol-error"
 202   (let* ((inferior (open-inferior %top-builddir
 203                                   #:command "scripts/guix")))
 204     (guard (c ((store-protocol-error? c)
 205                (string-contains (store-protocol-error-message c)
 206                                 "invalid character")))
 207       (inferior-eval-with-store inferior %store
 208                                 '(lambda (store)
 209                                    (add-text-to-store store "we|rd/?!@"
 210                                                       "uh uh")))
 211       #f)))
 212
 213 (test-equal "inferior-package-derivation"
 214   (map derivation-file-name
 215        (list (package-derivation %store %bootstrap-guile "x86_64-linux")
 216              (package-derivation %store %bootstrap-guile "armhf-linux")))
 217   (let* ((inferior (open-inferior %top-builddir
 218                                   #:command "scripts/guix"))
 219          (packages (inferior-packages inferior))
 220          (guile    (find (lambda (package)
 221                            (string=? (package-name %bootstrap-guile)
 222                                      (inferior-package-name package)))
 223                          packages)))
 224     (map derivation-file-name
 225          (list (inferior-package-derivation %store guile "x86_64-linux")
 226                (inferior-package-derivation %store guile "armhf-linux")))))
 227
 228 (test-equal "inferior-package->manifest-entry"
 229   (manifest-entry->list (package->manifest-entry
 230                          (first (find-best-packages-by-name "guile" #f))))
 231   (let* ((inferior (open-inferior %top-builddir
 232                                   #:command "scripts/guix"))
 233          (guile    (first (lookup-inferior-packages inferior "guile")))
 234          (entry    (inferior-package->manifest-entry guile)))
 235     (close-inferior inferior)
 236     (manifest-entry->list entry)))
 237
 238 (test-equal "packages->manifest"
 239   (map manifest-entry->list
 240        (manifest-entries (packages->manifest
 241                           (find-best-packages-by-name "guile" #f))))
 242   (let* ((inferior (open-inferior %top-builddir
 243                                   #:command "scripts/guix"))
 244          (guile    (first (lookup-inferior-packages inferior "guile")))
 245          (manifest (packages->manifest (list guile))))
 246     (close-inferior inferior)
 247     (map manifest-entry->list (manifest-entries manifest))))
 248
 249 (test-end "inferior")