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 (gnu packages sqlite)
  30   #:use-module (srfi srfi-1)
  31   #:use-module (srfi srfi-34)
  32   #:use-module (srfi srfi-64)
  33   #:use-module (ice-9 match))
  34
  35 (define %top-srcdir
  36   (dirname (search-path %load-path "guix.scm")))
  37
  38 (define %top-builddir
  39   (dirname (search-path %load-compiled-path "guix.go")))
  40
  41 (define %store
  42   (open-connection-for-tests))
  43
  44 (define (manifest-entry->list entry)
  45   (list (manifest-entry-name entry)
  46         (manifest-entry-version entry)
  47         (manifest-entry-output entry)
  48         (manifest-entry-search-paths entry)
  49         (map manifest-entry->list (manifest-entry-dependencies entry))))
  50
  51 \f
  52 (test-begin "inferior")
  53
  54 (test-equal "open-inferior"
  55   '(42 #t)
  56   (let ((inferior (open-inferior %top-builddir
  57                                  #:command "scripts/guix")))
  58     (and (inferior? inferior)
  59          (let ((a (inferior-eval '(apply * '(6 7)) inferior))
  60                (b (inferior-eval '(@ (gnu packages base) coreutils)
  61                                  inferior)))
  62            (close-inferior inferior)
  63            (list a (inferior-object? b))))))
  64
  65 (test-equal "&inferior-exception"
  66   '(a b c d)
  67   (let ((inferior (open-inferior %top-builddir
  68                                  #:command "scripts/guix")))
  69     (guard (c ((inferior-exception? c)
  70                (close-inferior inferior)
  71                (and (eq? inferior (inferior-exception-inferior c))
  72                     (match (inferior-exception-stack c)
  73                       (((_ (files lines columns)) ..1)
  74                        (member "guix/repl.scm" files)))
  75                     (inferior-exception-arguments c))))
  76       (inferior-eval '(throw 'a 'b 'c 'd) inferior)
  77       'badness)))
  78
  79 (test-equal "&inferior-exception, legacy mode"
  80   '(a b c d)
  81   ;; Omit #:command to open an inferior in "legacy" mode, where Guile runs
  82   ;; directly.
  83   (let ((inferior (open-inferior %top-builddir)))
  84     (guard (c ((inferior-exception? c)
  85                (close-inferior inferior)
  86                (and (eq? inferior (inferior-exception-inferior c))
  87                     (inferior-exception-arguments c))))
  88       (inferior-eval '(throw 'a 'b 'c 'd) inferior)
  89       'badness)))
  90
  91 (test-equal "inferior-packages"
  92   (take (sort (fold-packages (lambda (package lst)
  93                                (cons (list (package-name package)
  94                                            (package-version package)
  95                                            (package-home-page package)
  96                                            (package-location package))
  97                                      lst))
  98                              '())
  99               (lambda (x y)
 100                 (string<? (car x) (car y))))
 101         10)
 102   (let* ((inferior (open-inferior %top-builddir
 103                                   #:command "scripts/guix"))
 104          (packages (inferior-packages inferior)))
 105     (and (every string? (map inferior-package-synopsis packages))
 106          (let ()
 107            (define result
 108              (take (sort (map (lambda (package)
 109                                 (list (inferior-package-name package)
 110                                       (inferior-package-version package)
 111                                       (inferior-package-home-page package)
 112                                       (inferior-package-location package)))
 113                               packages)
 114                          (lambda (x y)
 115                            (string<? (car x) (car y))))
 116                    10))
 117            (close-inferior inferior)
 118            result))))
 119
 120 (test-equal "inferior-available-packages"
 121   (take (sort (fold-available-packages
 122                (lambda* (name version result
 123                               #:key supported? deprecated?
 124                               #:allow-other-keys)
 125                  (if (and supported? (not deprecated?))
 126                      (alist-cons name version result)
 127                      result))
 128                '())
 129               (lambda (x y)
 130                 (string<? (car x) (car y))))
 131         10)
 132   (let* ((inferior (open-inferior %top-builddir
 133                                   #:command "scripts/guix"))
 134          (packages (inferior-available-packages inferior)))
 135     (close-inferior inferior)
 136     (take (sort packages (lambda (x y)
 137                            (string<? (car x) (car y))))
 138           10)))
 139
 140 (test-equal "lookup-inferior-packages"
 141   (let ((->list (lambda (package)
 142                   (list (package-name package)
 143                         (package-version package)
 144                         (package-location package)))))
 145     (list (map ->list (find-packages-by-name "guile" #f))
 146           (map ->list (find-packages-by-name "guile" "2.2"))))
 147   (let* ((inferior (open-inferior %top-builddir
 148                                   #:command "scripts/guix"))
 149          (->list   (lambda (package)
 150                      (list (inferior-package-name package)
 151                            (inferior-package-version package)
 152                            (inferior-package-location package))))
 153          (lst1     (map ->list
 154                         (lookup-inferior-packages inferior "guile")))
 155          (lst2     (map ->list
 156                         (lookup-inferior-packages inferior
 157                                                   "guile" "2.2"))))
 158     (close-inferior inferior)
 159     (list lst1 lst2)))
 160
 161 (test-assert "lookup-inferior-packages and eq?-ness"
 162   (let* ((inferior (open-inferior %top-builddir
 163                                   #:command "scripts/guix"))
 164          (lst1     (lookup-inferior-packages inferior "guile"))
 165          (lst2     (lookup-inferior-packages inferior "guile")))
 166     (close-inferior inferior)
 167     (every eq? lst1 lst2)))
 168
 169 (test-equal "inferior-package-inputs"
 170   (let ((->list (match-lambda
 171                   ((label (? package? package) . rest)
 172                    `(,label
 173                      (package ,(package-name package)
 174                               ,(package-version package)
 175                               ,(package-location package))
 176                      ,@rest)))))
 177     (list (map ->list (package-inputs guile-3.0-latest))
 178           (map ->list (package-native-inputs guile-3.0-latest))
 179           (map ->list (package-propagated-inputs guile-3.0-latest))))
 180   (let* ((inferior (open-inferior %top-builddir
 181                                   #:command "scripts/guix"))
 182          (guile    (first (lookup-inferior-packages inferior "guile")))
 183          (->list   (match-lambda
 184                      ((label (? inferior-package? package) . rest)
 185                       `(,label
 186                         (package ,(inferior-package-name package)
 187                                  ,(inferior-package-version package)
 188                                  ,(inferior-package-location package))
 189                         ,@rest))))
 190          (result   (list (map ->list (inferior-package-inputs guile))
 191                          (map ->list
 192                               (inferior-package-native-inputs guile))
 193                          (map ->list
 194                               (inferior-package-propagated-inputs
 195                                guile)))))
 196     (close-inferior inferior)
 197     result))
 198
 199 (test-equal "inferior-package-search-paths"
 200   (package-native-search-paths guile-3.0)
 201   (let* ((inferior (open-inferior %top-builddir
 202                                   #:command "scripts/guix"))
 203          (guile    (first (lookup-inferior-packages inferior "guile")))
 204          (result   (inferior-package-native-search-paths guile)))
 205     (close-inferior inferior)
 206     result))
 207
 208 (test-equal "inferior-eval-with-store"
 209   (add-text-to-store %store "foo" "Hello, world!")
 210   (let* ((inferior (open-inferior %top-builddir
 211                                   #:command "scripts/guix")))
 212     (inferior-eval-with-store inferior %store
 213                               '(lambda (store)
 214                                  (add-text-to-store store "foo"
 215                                                     "Hello, world!")))))
 216
 217 (test-assert "inferior-eval-with-store, &store-protocol-error"
 218   (let* ((inferior (open-inferior %top-builddir
 219                                   #:command "scripts/guix")))
 220     (guard (c ((store-protocol-error? c)
 221                (string-contains (store-protocol-error-message c)
 222                                 "invalid character")))
 223       (inferior-eval-with-store inferior %store
 224                                 '(lambda (store)
 225                                    (add-text-to-store store "we|rd/?!@"
 226                                                       "uh uh")))
 227       #f)))
 228
 229 (test-equal "inferior-eval-with-store, exception"
 230   '(the-answer = 42)
 231   (let ((inferior (open-inferior %top-builddir
 232                                  #:command "scripts/guix")))
 233     (guard (c ((inferior-exception? c)
 234                (close-inferior inferior)
 235                (inferior-exception-arguments c)))
 236       (inferior-eval-with-store inferior %store
 237                                 '(lambda (store)
 238                                    (throw 'the-answer '= 42))))))
 239
 240 (test-equal "inferior-eval-with-store, not a procedure"
 241   'wrong-type-arg
 242   (let ((inferior (open-inferior %top-builddir
 243                                  #:command "scripts/guix")))
 244     (guard (c ((inferior-exception? c)
 245                (close-inferior inferior)
 246                (car (inferior-exception-arguments c))))
 247      (inferior-eval-with-store inferior %store '(+ 1 2)))))
 248
 249 (test-equal "inferior-package-derivation"
 250   (map derivation-file-name
 251        (list (package-derivation %store %bootstrap-guile "x86_64-linux")
 252              (package-derivation %store %bootstrap-guile "armhf-linux")))
 253   (let* ((inferior (open-inferior %top-builddir
 254                                   #:command "scripts/guix"))
 255          (packages (inferior-packages inferior))
 256          (guile    (find (lambda (package)
 257                            (string=? (package-name %bootstrap-guile)
 258                                      (inferior-package-name package)))
 259                          packages)))
 260     (map derivation-file-name
 261          (list (inferior-package-derivation %store guile "x86_64-linux")
 262                (inferior-package-derivation %store guile "armhf-linux")))))
 263
 264 (unless (package-replacement sqlite)
 265   (test-skip 1))
 266
 267 (test-equal "inferior-package-replacement"
 268   (package-derivation %store
 269                       (package-replacement sqlite)
 270                       "x86_64-linux")
 271   (let* ((inferior (open-inferior %top-builddir
 272                                   #:command "scripts/guix"))
 273          (packages (inferior-packages inferior)))
 274     (match (lookup-inferior-packages inferior
 275                                      (package-name sqlite)
 276                                      (package-version sqlite))
 277       ((inferior-sqlite rest ...)
 278        (inferior-package-derivation %store
 279                                     (inferior-package-replacement
 280                                      inferior-sqlite)
 281                                     "x86_64-linux")))))
 282
 283 (test-equal "inferior-package->manifest-entry"
 284   (manifest-entry->list (package->manifest-entry
 285                          (first (find-best-packages-by-name "guile" #f))))
 286   (let* ((inferior (open-inferior %top-builddir
 287                                   #:command "scripts/guix"))
 288          (guile    (first (lookup-inferior-packages inferior "guile")))
 289          (entry    (inferior-package->manifest-entry guile)))
 290     (close-inferior inferior)
 291     (manifest-entry->list entry)))
 292
 293 (test-equal "packages->manifest"
 294   (map manifest-entry->list
 295        (manifest-entries (packages->manifest
 296                           (find-best-packages-by-name "guile" #f))))
 297   (let* ((inferior (open-inferior %top-builddir
 298                                   #:command "scripts/guix"))
 299          (guile    (first (lookup-inferior-packages inferior "guile")))
 300          (manifest (packages->manifest (list guile))))
 301     (close-inferior inferior)
 302     (map manifest-entry->list (manifest-entries manifest))))
 303
 304 (test-end "inferior")