tests/inferior.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018, 2019, 2020, 2021 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                     (match (inferior-exception-stack c)
  72                       (((_ (files lines columns)) ..1)
  73                        (member "guix/repl.scm" files)))
  74                     (inferior-exception-arguments c))))
  75       (inferior-eval '(throw 'a 'b 'c 'd) inferior)
  76       'badness)))
  77
  78 (test-equal "&inferior-exception, legacy mode"
  79   '(a b c d)
  80   ;; Omit #:command to open an inferior in "legacy" mode, where Guile runs
  81   ;; directly.
  82   (let ((inferior (open-inferior %top-builddir)))
  83     (guard (c ((inferior-exception? c)
  84                (close-inferior inferior)
  85                (and (eq? inferior (inferior-exception-inferior c))
  86                     (inferior-exception-arguments c))))
  87       (inferior-eval '(throw 'a 'b 'c 'd) inferior)
  88       'badness)))
  89
  90 (test-equal "inferior-packages"
  91   (take (sort (fold-packages (lambda (package lst)
  92                                (cons (list (package-name package)
  93                                            (package-version package)
  94                                            (package-home-page package)
  95                                            (package-location package))
  96                                      lst))
  97                              '())
  98               (lambda (x y)
  99                 (string<? (car x) (car y))))
 100         10)
 101   (let* ((inferior (open-inferior %top-builddir
 102                                   #:command "scripts/guix"))
 103          (packages (inferior-packages inferior)))
 104     (and (every string? (map inferior-package-synopsis packages))
 105          (let ()
 106            (define result
 107              (take (sort (map (lambda (package)
 108                                 (list (inferior-package-name package)
 109                                       (inferior-package-version package)
 110                                       (inferior-package-home-page package)
 111                                       (inferior-package-location package)))
 112                               packages)
 113                          (lambda (x y)
 114                            (string<? (car x) (car y))))
 115                    10))
 116            (close-inferior inferior)
 117            result))))
 118
 119 (test-equal "inferior-available-packages"
 120   (take (sort (fold-available-packages
 121                (lambda* (name version result
 122                               #:key supported? deprecated?
 123                               #:allow-other-keys)
 124                  (if (and supported? (not deprecated?))
 125                      (alist-cons name version result)
 126                      result))
 127                '())
 128               (lambda (x y)
 129                 (string<? (car x) (car y))))
 130         10)
 131   (let* ((inferior (open-inferior %top-builddir
 132                                   #:command "scripts/guix"))
 133          (packages (inferior-available-packages inferior)))
 134     (close-inferior inferior)
 135     (take (sort packages (lambda (x y)
 136                            (string<? (car x) (car y))))
 137           10)))
 138
 139 (test-equal "lookup-inferior-packages"
 140   (let ((->list (lambda (package)
 141                   (list (package-name package)
 142                         (package-version package)
 143                         (package-location package)))))
 144     (list (map ->list (find-packages-by-name "guile" #f))
 145           (map ->list (find-packages-by-name "guile" "2.2"))))
 146   (let* ((inferior (open-inferior %top-builddir
 147                                   #:command "scripts/guix"))
 148          (->list   (lambda (package)
 149                      (list (inferior-package-name package)
 150                            (inferior-package-version package)
 151                            (inferior-package-location package))))
 152          (lst1     (map ->list
 153                         (lookup-inferior-packages inferior "guile")))
 154          (lst2     (map ->list
 155                         (lookup-inferior-packages inferior
 156                                                   "guile" "2.2"))))
 157     (close-inferior inferior)
 158     (list lst1 lst2)))
 159
 160 (test-assert "lookup-inferior-packages and eq?-ness"
 161   (let* ((inferior (open-inferior %top-builddir
 162                                   #:command "scripts/guix"))
 163          (lst1     (lookup-inferior-packages inferior "guile"))
 164          (lst2     (lookup-inferior-packages inferior "guile")))
 165     (close-inferior inferior)
 166     (every eq? lst1 lst2)))
 167
 168 (test-equal "inferior-package-inputs"
 169   (let ((->list (match-lambda
 170                   ((label (? package? package) . rest)
 171                    `(,label
 172                      (package ,(package-name package)
 173                               ,(package-version package)
 174                               ,(package-location package))
 175                      ,@rest)))))
 176     (list (map ->list (package-inputs guile-2.2))
 177           (map ->list (package-native-inputs guile-2.2))
 178           (map ->list (package-propagated-inputs guile-2.2))))
 179   (let* ((inferior (open-inferior %top-builddir
 180                                   #:command "scripts/guix"))
 181          (guile    (first (lookup-inferior-packages inferior "guile")))
 182          (->list   (match-lambda
 183                      ((label (? inferior-package? package) . rest)
 184                       `(,label
 185                         (package ,(inferior-package-name package)
 186                                  ,(inferior-package-version package)
 187                                  ,(inferior-package-location package))
 188                         ,@rest))))
 189          (result   (list (map ->list (inferior-package-inputs guile))
 190                          (map ->list
 191                               (inferior-package-native-inputs guile))
 192                          (map ->list
 193                               (inferior-package-propagated-inputs
 194                                guile)))))
 195     (close-inferior inferior)
 196     result))
 197
 198 (test-equal "inferior-package-search-paths"
 199   (package-native-search-paths guile-3.0)
 200   (let* ((inferior (open-inferior %top-builddir
 201                                   #:command "scripts/guix"))
 202          (guile    (first (lookup-inferior-packages inferior "guile")))
 203          (result   (inferior-package-native-search-paths guile)))
 204     (close-inferior inferior)
 205     result))
 206
 207 (test-equal "inferior-eval-with-store"
 208   (add-text-to-store %store "foo" "Hello, world!")
 209   (let* ((inferior (open-inferior %top-builddir
 210                                   #:command "scripts/guix")))
 211     (inferior-eval-with-store inferior %store
 212                               '(lambda (store)
 213                                  (add-text-to-store store "foo"
 214                                                     "Hello, world!")))))
 215
 216 (test-assert "inferior-eval-with-store, &store-protocol-error"
 217   (let* ((inferior (open-inferior %top-builddir
 218                                   #:command "scripts/guix")))
 219     (guard (c ((store-protocol-error? c)
 220                (string-contains (store-protocol-error-message c)
 221                                 "invalid character")))
 222       (inferior-eval-with-store inferior %store
 223                                 '(lambda (store)
 224                                    (add-text-to-store store "we|rd/?!@"
 225                                                       "uh uh")))
 226       #f)))
 227
 228 (test-equal "inferior-eval-with-store, exception"
 229   '(the-answer = 42)
 230   (let ((inferior (open-inferior %top-builddir
 231                                  #:command "scripts/guix")))
 232     (guard (c ((inferior-exception? c)
 233                (close-inferior inferior)
 234                (inferior-exception-arguments c)))
 235       (inferior-eval-with-store inferior %store
 236                                 '(lambda (store)
 237                                    (throw 'the-answer '= 42))))))
 238
 239 (test-equal "inferior-eval-with-store, not a procedure"
 240   'wrong-type-arg
 241   (let ((inferior (open-inferior %top-builddir
 242                                  #:command "scripts/guix")))
 243     (guard (c ((inferior-exception? c)
 244                (close-inferior inferior)
 245                (car (inferior-exception-arguments c))))
 246      (inferior-eval-with-store inferior %store '(+ 1 2)))))
 247
 248 (test-equal "inferior-package-derivation"
 249   (map derivation-file-name
 250        (list (package-derivation %store %bootstrap-guile "x86_64-linux")
 251              (package-derivation %store %bootstrap-guile "armhf-linux")))
 252   (let* ((inferior (open-inferior %top-builddir
 253                                   #:command "scripts/guix"))
 254          (packages (inferior-packages inferior))
 255          (guile    (find (lambda (package)
 256                            (string=? (package-name %bootstrap-guile)
 257                                      (inferior-package-name package)))
 258                          packages)))
 259     (map derivation-file-name
 260          (list (inferior-package-derivation %store guile "x86_64-linux")
 261                (inferior-package-derivation %store guile "armhf-linux")))))
 262
 263 (test-equal "inferior-package->manifest-entry"
 264   (manifest-entry->list (package->manifest-entry
 265                          (first (find-best-packages-by-name "guile" #f))))
 266   (let* ((inferior (open-inferior %top-builddir
 267                                   #:command "scripts/guix"))
 268          (guile    (first (lookup-inferior-packages inferior "guile")))
 269          (entry    (inferior-package->manifest-entry guile)))
 270     (close-inferior inferior)
 271     (manifest-entry->list entry)))
 272
 273 (test-equal "packages->manifest"
 274   (map manifest-entry->list
 275        (manifest-entries (packages->manifest
 276                           (find-best-packages-by-name "guile" #f))))
 277   (let* ((inferior (open-inferior %top-builddir
 278                                   #:command "scripts/guix"))
 279          (guile    (first (lookup-inferior-packages inferior "guile")))
 280          (manifest (packages->manifest (list guile))))
 281     (close-inferior inferior)
 282     (map manifest-entry->list (manifest-entries manifest))))
 283
 284 (test-end "inferior")