tests/inferior.scm

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