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 ((guix utils)
  23                 #:select (%current-system
  24                           source-properties->location
  25                           call-with-temporary-directory))
  26   #:use-module ((guix store)
  27                 #:select (nix-server-socket
  28                           nix-server-major-version
  29                           nix-server-minor-version
  30                           store-lift))
  31   #:use-module ((guix derivations)
  32                 #:select (read-derivation-from-file))
  33   #:use-module (guix gexp)
  34   #:use-module (ice-9 match)
  35   #:use-module (ice-9 popen)
  36   #:use-module (ice-9 binary-ports)
  37   #:export (inferior?
  38             open-inferior
  39             close-inferior
  40             inferior-eval
  41             inferior-object?
  42
  43             inferior-package?
  44             inferior-package-name
  45             inferior-package-version
  46
  47             inferior-packages
  48             inferior-package-synopsis
  49             inferior-package-description
  50             inferior-package-home-page
  51             inferior-package-location
  52             inferior-package-derivation))
  53
  54 ;;; Commentary:
  55 ;;;
  56 ;;; This module provides a way to spawn Guix "inferior" processes and to talk
  57 ;;; to them.  It allows us, from one instance of Guix, to interact with
  58 ;;; another instance of Guix coming from a different commit.
  59 ;;;
  60 ;;; Code:
  61
  62 ;; Inferior Guix process.
  63 (define-record-type <inferior>
  64   (inferior pid socket version)
  65   inferior?
  66   (pid      inferior-pid)
  67   (socket   inferior-socket)
  68   (version  inferior-version))                    ;REPL protocol version
  69
  70 (define (inferior-pipe directory command)
  71   "Return an input/output pipe on the Guix instance in DIRECTORY.  This runs
  72 'DIRECTORY/COMMAND repl' if it exists, or falls back to some other method if
  73 it's an old Guix."
  74   (let ((pipe (with-error-to-port (%make-void-port "w")
  75                 (lambda ()
  76                   (open-pipe* OPEN_BOTH
  77                               (string-append directory "/" command)
  78                               "repl" "-t" "machine")))))
  79     (if (eof-object? (peek-char pipe))
  80         (begin
  81           (close-pipe pipe)
  82
  83           ;; Older versions of Guix didn't have a 'guix repl' command, so
  84           ;; emulate it.
  85           (open-pipe* OPEN_BOTH "guile"
  86                       "-L" (string-append directory "/share/guile/site/"
  87                                           (effective-version))
  88                       "-C" (string-append directory "/share/guile/site/"
  89                                           (effective-version))
  90                       "-C" (string-append directory "/lib/guile/"
  91                                           (effective-version) "/site-ccache")
  92                       "-c"
  93                       (object->string
  94                        `(begin
  95                           (primitive-load ,(search-path %load-path
  96                                                         "guix/scripts/repl.scm"))
  97                           ((@ (guix scripts repl) machine-repl))))))
  98         pipe)))
  99
 100 (define* (open-inferior directory #:key (command "bin/guix"))
 101   "Open the inferior Guix in DIRECTORY, running 'DIRECTORY/COMMAND repl' or
 102 equivalent.  Return #f if the inferior could not be launched."
 103   (define pipe
 104     (inferior-pipe directory command))
 105
 106   (cond-expand
 107     ((and guile-2 (not guile-2.2)) #t)
 108     (else (setvbuf pipe 'line)))
 109
 110   (match (read pipe)
 111     (('repl-version 0 rest ...)
 112      (let ((result (inferior 'pipe pipe (cons 0 rest))))
 113        (inferior-eval '(use-modules (guix)) result)
 114        (inferior-eval '(use-modules (gnu)) result)
 115        (inferior-eval '(define %package-table (make-hash-table))
 116                       result)
 117        result))
 118     (_
 119      #f)))
 120
 121 (define (close-inferior inferior)
 122   "Close INFERIOR."
 123   (close-pipe (inferior-socket inferior)))
 124
 125 ;; Non-self-quoting object of the inferior.
 126 (define-record-type <inferior-object>
 127   (inferior-object address appearance)
 128   inferior-object?
 129   (address     inferior-object-address)
 130   (appearance  inferior-object-appearance))
 131
 132 (define (write-inferior-object object port)
 133   (match object
 134     (($ <inferior-object> _ appearance)
 135      (format port "#<inferior-object ~a>" appearance))))
 136
 137 (set-record-type-printer! <inferior-object> write-inferior-object)
 138
 139 (define (read-inferior-response inferior)
 140   (define sexp->object
 141     (match-lambda
 142       (('value value)
 143        value)
 144       (('non-self-quoting address string)
 145        (inferior-object address string))))
 146
 147   (match (read (inferior-socket inferior))
 148     (('values objects ...)
 149      (apply values (map sexp->object objects)))
 150     (('exception key objects ...)
 151      (apply throw key (map sexp->object objects)))))
 152
 153 (define (send-inferior-request exp inferior)
 154   (write exp (inferior-socket inferior))
 155   (newline (inferior-socket inferior)))
 156
 157 (define (inferior-eval exp inferior)
 158   "Evaluate EXP in INFERIOR."
 159   (send-inferior-request exp inferior)
 160   (read-inferior-response inferior))
 161
 162 \f
 163 ;;;
 164 ;;; Inferior packages.
 165 ;;;
 166
 167 (define-record-type <inferior-package>
 168   (inferior-package inferior name version id)
 169   inferior-package?
 170   (inferior   inferior-package-inferior)
 171   (name       inferior-package-name)
 172   (version    inferior-package-version)
 173   (id         inferior-package-id))
 174
 175 (define (write-inferior-package package port)
 176   (match package
 177     (($ <inferior-package> _ name version)
 178      (format port "#<inferior-package ~a@~a ~a>"
 179              name version
 180              (number->string (object-address package) 16)))))
 181
 182 (set-record-type-printer! <inferior-package> write-inferior-package)
 183
 184 (define (inferior-packages inferior)
 185   "Return the list of packages known to INFERIOR."
 186   (let ((result (inferior-eval
 187                  '(fold-packages (lambda (package result)
 188                                    (let ((id (object-address package)))
 189                                      (hashv-set! %package-table id package)
 190                                      (cons (list (package-name package)
 191                                                  (package-version package)
 192                                                  id)
 193                                            result)))
 194                                  '())
 195                  inferior)))
 196     (map (match-lambda
 197            ((name version id)
 198             (inferior-package inferior name version id)))
 199          result)))
 200
 201 (define (inferior-package-field package getter)
 202   "Return the field of PACKAGE, an inferior package, accessed with GETTER."
 203   (let ((inferior (inferior-package-inferior package))
 204         (id       (inferior-package-id package)))
 205     (inferior-eval `(,getter (hashv-ref %package-table ,id))
 206                    inferior)))
 207
 208 (define* (inferior-package-synopsis package #:key (translate? #t))
 209   "Return the Texinfo synopsis of PACKAGE, an inferior package.  When
 210 TRANSLATE? is true, translate it to the current locale's language."
 211   (inferior-package-field package
 212                           (if translate?
 213                               '(compose (@ (guix ui) P_) package-synopsis)
 214                               'package-synopsis)))
 215
 216 (define* (inferior-package-description package #:key (translate? #t))
 217   "Return the Texinfo description of PACKAGE, an inferior package.  When
 218 TRANSLATE? is true, translate it to the current locale's language."
 219   (inferior-package-field package
 220                           (if translate?
 221                               '(compose (@ (guix ui) P_) package-description)
 222                               'package-description)))
 223
 224 (define (inferior-package-home-page package)
 225   "Return the home page of PACKAGE."
 226   (inferior-package-field package 'package-home-page))
 227
 228 (define (inferior-package-location package)
 229   "Return the source code location of PACKAGE, either #f or a <location>
 230 record."
 231   (source-properties->location
 232    (inferior-package-field package
 233                            '(compose (lambda (loc)
 234                                        (and loc
 235                                             (location->source-properties
 236                                              loc)))
 237                                      package-location))))
 238
 239 (define (proxy client backend)                    ;adapted from (guix ssh)
 240   "Proxy communication between CLIENT and BACKEND until CLIENT closes the
 241 connection, at which point CLIENT is closed (both CLIENT and BACKEND must be
 242 input/output ports.)"
 243   (define (select* read write except)
 244     ;; This is a workaround for <https://bugs.gnu.org/30365> in Guile < 2.2.4:
 245     ;; since 'select' sometimes returns non-empty sets for no good reason,
 246     ;; call 'select' a second time with a zero timeout to filter out incorrect
 247     ;; replies.
 248     (match (select read write except)
 249       ((read write except)
 250        (select read write except 0))))
 251
 252   ;; Use buffered ports so that 'get-bytevector-some' returns up to the
 253   ;; whole buffer like read(2) would--see <https://bugs.gnu.org/30066>.
 254   (setvbuf client _IOFBF 65536)
 255   (setvbuf backend _IOFBF 65536)
 256
 257   (let loop ()
 258     (match (select* (list client backend) '() '())
 259       ((reads () ())
 260        (when (memq client reads)
 261          (match (get-bytevector-some client)
 262            ((? eof-object?)
 263             (close-port client))
 264            (bv
 265             (put-bytevector backend bv)
 266             (force-output backend))))
 267        (when (memq backend reads)
 268          (match (get-bytevector-some backend)
 269            (bv
 270             (put-bytevector client bv)
 271             (force-output client))))
 272        (unless (port-closed? client)
 273          (loop))))))
 274
 275 (define* (inferior-package-derivation store package
 276                                       #:optional
 277                                       (system (%current-system))
 278                                       #:key target)
 279   "Return the derivation for PACKAGE, an inferior package, built for SYSTEM
 280 and cross-built for TARGET if TARGET is true.  The inferior corresponding to
 281 PACKAGE must be live."
 282   ;; Create a named socket in /tmp and let the inferior of PACKAGE connect to
 283   ;; it and use it as its store.  This ensures the inferior uses the same
 284   ;; store, with the same options, the same per-session GC roots, etc.
 285   (call-with-temporary-directory
 286    (lambda (directory)
 287      (chmod directory #o700)
 288      (let* ((name     (string-append directory "/inferior"))
 289             (socket   (socket AF_UNIX SOCK_STREAM 0))
 290             (inferior (inferior-package-inferior package))
 291             (major    (nix-server-major-version store))
 292             (minor    (nix-server-minor-version store))
 293             (proto    (logior major minor)))
 294        (bind socket AF_UNIX name)
 295        (listen socket 1024)
 296        (send-inferior-request
 297         `(let ((socket (socket AF_UNIX SOCK_STREAM 0)))
 298            (connect socket AF_UNIX ,name)
 299
 300            ;; 'port->connection' appeared in June 2018 and we can hardly
 301            ;; emulate it on older versions.  Thus fall back to
 302            ;; 'open-connection', at the risk of talking to the wrong daemon or
 303            ;; having our build result reclaimed (XXX).
 304            (let* ((store   (if (defined? 'port->connection)
 305                                (port->connection socket #:version ,proto)
 306                                (open-connection)))
 307                   (package (hashv-ref %package-table
 308                                       ,(inferior-package-id package)))
 309                   (drv     ,(if target
 310                                 `(package-cross-derivation store package
 311                                                            ,target
 312                                                            ,system)
 313                                 `(package-derivation store package
 314                                                      ,system))))
 315              (close-connection store)
 316              (close-port socket)
 317              (derivation-file-name drv)))
 318         inferior)
 319        (match (accept socket)
 320          ((client . address)
 321           (proxy client (nix-server-socket store))))
 322        (close-port socket)
 323        (read-derivation-from-file (read-inferior-response inferior))))))
 324
 325 (define inferior-package->derivation
 326   (store-lift inferior-package-derivation))
 327
 328 (define-gexp-compiler (package-compiler (package <inferior-package>) system
 329                                         target)
 330   ;; Compile PACKAGE for SYSTEM, optionally cross-building for TARGET.
 331   (inferior-package->derivation package system #:target target))