guix/inferior.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018 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 (guix inferior)
  20   #:use-module (srfi srfi-9)
  21   #:use-module (srfi srfi-9 gnu)
  22   #:use-module (ice-9 match)
  23   #:use-module (ice-9 popen)
  24   #:export (inferior?
  25             open-inferior
  26             close-inferior
  27             inferior-eval
  28             inferior-object?
  29
  30             inferior-package?
  31             inferior-package-name
  32             inferior-package-version
  33
  34             inferior-packages
  35             inferior-package-synopsis
  36             inferior-package-description))
  37
  38 ;;; Commentary:
  39 ;;;
  40 ;;; This module provides a way to spawn Guix "inferior" processes and to talk
  41 ;;; to them.  It allows us, from one instance of Guix, to interact with
  42 ;;; another instance of Guix coming from a different commit.
  43 ;;;
  44 ;;; Code:
  45
  46 ;; Inferior Guix process.
  47 (define-record-type <inferior>
  48   (inferior pid socket version)
  49   inferior?
  50   (pid      inferior-pid)
  51   (socket   inferior-socket)
  52   (version  inferior-version))                    ;REPL protocol version
  53
  54 (define (inferior-pipe directory command)
  55   "Return an input/output pipe on the Guix instance in DIRECTORY.  This runs
  56 'DIRECTORY/COMMAND repl' if it exists, or falls back to some other method if
  57 it's an old Guix."
  58   (let ((pipe (with-error-to-port (%make-void-port "w")
  59                 (lambda ()
  60                   (open-pipe* OPEN_BOTH
  61                               (string-append directory "/" command)
  62                               "repl" "-t" "machine")))))
  63     (if (eof-object? (peek-char pipe))
  64         (begin
  65           (close-pipe pipe)
  66
  67           ;; Older versions of Guix didn't have a 'guix repl' command, so
  68           ;; emulate it.
  69           (open-pipe* OPEN_BOTH "guile"
  70                       "-L" (string-append directory "/share/guile/site/"
  71                                           (effective-version))
  72                       "-C" (string-append directory "/share/guile/site/"
  73                                           (effective-version))
  74                       "-C" (string-append directory "/lib/guile/"
  75                                           (effective-version) "/site-ccache")
  76                       "-c"
  77                       (object->string
  78                        `(begin
  79                           (primitive-load ,(search-path %load-path
  80                                                         "guix/scripts/repl.scm"))
  81                           ((@ (guix scripts repl) machine-repl))))))
  82         pipe)))
  83
  84 (define* (open-inferior directory #:key (command "bin/guix"))
  85   "Open the inferior Guix in DIRECTORY, running 'DIRECTORY/COMMAND repl' or
  86 equivalent.  Return #f if the inferior could not be launched."
  87   (define pipe
  88     (inferior-pipe directory command))
  89
  90   (setvbuf pipe _IOLBF)
  91   (match (read pipe)
  92     (('repl-version 0 rest ...)
  93      (let ((result (inferior 'pipe pipe (cons 0 rest))))
  94        (inferior-eval '(use-modules (guix)) result)
  95        (inferior-eval '(use-modules (gnu)) result)
  96        (inferior-eval '(define %package-table (make-hash-table))
  97                       result)
  98        result))
  99     (_
 100      #f)))
 101
 102 (define (close-inferior inferior)
 103   "Close INFERIOR."
 104   (close-pipe (inferior-socket inferior)))
 105
 106 ;; Non-self-quoting object of the inferior.
 107 (define-record-type <inferior-object>
 108   (inferior-object address appearance)
 109   inferior-object?
 110   (address     inferior-object-address)
 111   (appearance  inferior-object-appearance))
 112
 113 (define (write-inferior-object object port)
 114   (match object
 115     (($ <inferior-object> _ appearance)
 116      (format port "#<inferior-object ~a>" appearance))))
 117
 118 (set-record-type-printer! <inferior-object> write-inferior-object)
 119
 120 (define (inferior-eval exp inferior)
 121   "Evaluate EXP in INFERIOR."
 122   (define sexp->object
 123     (match-lambda
 124       (('value value)
 125        value)
 126       (('non-self-quoting address string)
 127        (inferior-object address string))))
 128
 129   (write exp (inferior-socket inferior))
 130   (newline (inferior-socket inferior))
 131   (match (read (inferior-socket inferior))
 132     (('values objects ...)
 133      (apply values (map sexp->object objects)))
 134     (('exception key objects ...)
 135      (apply throw key (map sexp->object objects)))))
 136
 137 \f
 138 ;;;
 139 ;;; Inferior packages.
 140 ;;;
 141
 142 (define-record-type <inferior-package>
 143   (inferior-package inferior name version id)
 144   inferior-package?
 145   (inferior   inferior-package-inferior)
 146   (name       inferior-package-name)
 147   (version    inferior-package-version)
 148   (id         inferior-package-id))
 149
 150 (define (write-inferior-package package port)
 151   (match package
 152     (($ <inferior-package> _ name version)
 153      (format port "#<inferior-package ~a@~a ~a>"
 154              name version
 155              (number->string (object-address package) 16)))))
 156
 157 (set-record-type-printer! <inferior-package> write-inferior-package)
 158
 159 (define (inferior-packages inferior)
 160   "Return the list of packages known to INFERIOR."
 161   (let ((result (inferior-eval
 162                  '(fold-packages (lambda (package result)
 163                                    (let ((id (object-address package)))
 164                                      (hashv-set! %package-table id package)
 165                                      (cons (list (package-name package)
 166                                                  (package-version package)
 167                                                  id)
 168                                            result)))
 169                                  '())
 170                  inferior)))
 171     (map (match-lambda
 172            ((name version id)
 173             (inferior-package inferior name version id)))
 174          result)))
 175
 176 (define (inferior-package-field package getter)
 177   "Return the field of PACKAGE, an inferior package, accessed with GETTER."
 178   (let ((inferior (inferior-package-inferior package))
 179         (id       (inferior-package-id package)))
 180     (inferior-eval `(,getter (hashv-ref %package-table ,id))
 181                    inferior)))
 182
 183 (define* (inferior-package-synopsis package #:key (translate? #t))
 184   "Return the Texinfo synopsis of PACKAGE, an inferior package.  When
 185 TRANSLATE? is true, translate it to the current locale's language."
 186   (inferior-package-field package
 187                           (if translate?
 188                               '(compose (@ (guix ui) P_) package-synopsis)
 189                               'package-synopsis)))
 190
 191 (define* (inferior-package-description package #:key (translate? #t))
 192   "Return the Texinfo description of PACKAGE, an inferior package.  When
 193 TRANSLATE? is true, translate it to the current locale's language."
 194   (inferior-package-field package
 195                           (if translate?
 196                               '(compose (@ (guix ui) P_) package-description)
 197                               'package-description)))