[jackhill/guix/guix.git] / guix / inferior.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix inferior)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module ((guix utils)
                #:select (%current-system
                          source-properties->location
                          call-with-temporary-directory
                          version>? version-prefix?
                          cache-directory))
  #:use-module ((guix store)
                #:select (nix-server-socket
                          nix-server-major-version
                          nix-server-minor-version
                          store-lift))
  #:use-module ((guix derivations)
                #:select (read-derivation-from-file))
  #:use-module (guix gexp)
  #:use-module (guix search-paths)
  #:use-module (guix profiles)
  #:use-module (guix channels)
  #:use-module (guix monads)
  #:use-module (guix store)
  #:use-module (guix derivations)
  #:use-module (guix base32)
  #:use-module (gcrypt hash)
  #:autoload   (guix cache) (maybe-remove-expired-cache-entries)
  #:autoload   (guix ui) (show-what-to-build*)
  #:autoload   (guix build utils) (mkdir-p)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:autoload   (ice-9 ftw) (scandir)
  #:use-module (ice-9 match)
  #:use-module (ice-9 popen)
  #:use-module (ice-9 vlist)
  #:use-module (ice-9 binary-ports)
  #:use-module ((rnrs bytevectors) #:select (string->utf8))
  #:export (inferior?
            open-inferior
            port->inferior
            close-inferior
            inferior-eval
            inferior-eval-with-store
            inferior-object?

            inferior-packages
            lookup-inferior-packages

            inferior-package?
            inferior-package-name
            inferior-package-version
            inferior-package-synopsis
            inferior-package-description
            inferior-package-home-page
            inferior-package-location
            inferior-package-inputs
            inferior-package-native-inputs
            inferior-package-propagated-inputs
            inferior-package-transitive-propagated-inputs
            inferior-package-native-search-paths
            inferior-package-transitive-native-search-paths
            inferior-package-search-paths
            inferior-package-derivation

            inferior-package->manifest-entry

            %inferior-cache-directory
            inferior-for-channels))

;;; Commentary:
;;;
;;; This module provides a way to spawn Guix "inferior" processes and to talk
;;; to them.  It allows us, from one instance of Guix, to interact with
;;; another instance of Guix coming from a different commit.
;;;
;;; Code:

;; Inferior Guix process.
(define-record-type <inferior>
  (inferior pid socket close version packages table)
  inferior?
  (pid      inferior-pid)
  (socket   inferior-socket)
  (close    inferior-close-socket)               ;procedure
  (version  inferior-version)                    ;REPL protocol version
  (packages inferior-package-promise)            ;promise of inferior packages
  (table    inferior-package-table))             ;promise of vhash

(define (inferior-pipe directory command)
  "Return an input/output pipe on the Guix instance in DIRECTORY.  This runs
'DIRECTORY/COMMAND repl' if it exists, or falls back to some other method if
it's an old Guix."
  (let ((pipe (with-error-to-port (%make-void-port "w")
                (lambda ()
                  (open-pipe* OPEN_BOTH
                              (string-append directory "/" command)
                              "repl" "-t" "machine")))))
    (if (eof-object? (peek-char pipe))
        (begin
          (close-pipe pipe)

          ;; Older versions of Guix didn't have a 'guix repl' command, so
          ;; emulate it.
          (open-pipe* OPEN_BOTH "guile"
                      "-L" (string-append directory "/share/guile/site/"
                                          (effective-version))
                      "-C" (string-append directory "/share/guile/site/"
                                          (effective-version))
                      "-C" (string-append directory "/lib/guile/"
                                          (effective-version) "/site-ccache")
                      "-c"
                      (object->string
                       `(begin
                          (primitive-load ,(search-path %load-path
                                                        "guix/scripts/repl.scm"))
                          ((@ (guix scripts repl) machine-repl))))))
        pipe)))

(define* (port->inferior pipe #:optional (close close-port))
  "Given PIPE, an input/output port, return an inferior that talks over PIPE.
PIPE is closed with CLOSE when 'close-inferior' is called on the returned
inferior."
  (setvbuf pipe 'line)

  (match (read pipe)
    (('repl-version 0 rest ...)
     (letrec ((result (inferior 'pipe pipe close (cons 0 rest)
                                (delay (%inferior-packages result))
                                (delay (%inferior-package-table result)))))
       (inferior-eval '(use-modules (guix)) result)
       (inferior-eval '(use-modules (gnu)) result)
       (inferior-eval '(use-modules (ice-9 match)) result)
       (inferior-eval '(define %package-table (make-hash-table))
                      result)
       result))
    (_
     #f)))

(define* (open-inferior directory #:key (command "bin/guix"))
  "Open the inferior Guix in DIRECTORY, running 'DIRECTORY/COMMAND repl' or
equivalent.  Return #f if the inferior could not be launched."
  (define pipe
    (inferior-pipe directory command))

  (port->inferior pipe close-pipe))

(define (close-inferior inferior)
  "Close INFERIOR."
  (let ((close (inferior-close-socket inferior)))
    (close (inferior-socket inferior))))

;; Non-self-quoting object of the inferior.
(define-record-type <inferior-object>
  (inferior-object address appearance)
  inferior-object?
  (address     inferior-object-address)
  (appearance  inferior-object-appearance))

(define (write-inferior-object object port)
  (match object
    (($ <inferior-object> _ appearance)
     (format port "#<inferior-object ~a>" appearance))))

(set-record-type-printer! <inferior-object> write-inferior-object)

(define (read-inferior-response inferior)
  (define sexp->object
    (match-lambda
      (('value value)
       value)
      (('non-self-quoting address string)
       (inferior-object address string))))

  (match (read (inferior-socket inferior))
    (('values objects ...)
     (apply values (map sexp->object objects)))
    (('exception key objects ...)
     (apply throw key (map sexp->object objects)))))

(define (send-inferior-request exp inferior)
  (write exp (inferior-socket inferior))
  (newline (inferior-socket inferior)))

(define (inferior-eval exp inferior)
  "Evaluate EXP in INFERIOR."
  (send-inferior-request exp inferior)
  (read-inferior-response inferior))

\f
;;;
;;; Inferior packages.
;;;

(define-record-type <inferior-package>
  (inferior-package inferior name version id)
  inferior-package?
  (inferior   inferior-package-inferior)
  (name       inferior-package-name)
  (version    inferior-package-version)
  (id         inferior-package-id))

(define (write-inferior-package package port)
  (match package
    (($ <inferior-package> _ name version)
     (format port "#<inferior-package ~a@~a ~a>"
             name version
             (number->string (object-address package) 16)))))

(set-record-type-printer! <inferior-package> write-inferior-package)

(define (%inferior-packages inferior)
  "Compute the list of inferior packages from INFERIOR."
  (let ((result (inferior-eval
                 '(fold-packages (lambda (package result)
                                   (let ((id (object-address package)))
                                     (hashv-set! %package-table id package)
                                     (cons (list (package-name package)
                                                 (package-version package)
                                                 id)
                                           result)))
                                 '())
                 inferior)))
    (map (match-lambda
           ((name version id)
            (inferior-package inferior name version id)))
         result)))

(define (inferior-packages inferior)
  "Return the list of packages known to INFERIOR."
  (force (inferior-package-promise inferior)))

(define (%inferior-package-table inferior)
  "Compute a package lookup table for INFERIOR."
  (fold (lambda (package table)
          (vhash-cons (inferior-package-name package) package
                      table))
        vlist-null
        (inferior-packages inferior)))

(define* (lookup-inferior-packages inferior name #:optional version)
  "Return the sorted list of inferior packages matching NAME in INFERIOR, with
highest version numbers first.  If VERSION is true, return only packages with
a version number prefixed by VERSION."
  ;; This is the counterpart of 'find-packages-by-name'.
  (sort (filter (lambda (package)
                  (or (not version)
                      (version-prefix? version
                                       (inferior-package-version package))))
                (vhash-fold* cons '() name
                             (force (inferior-package-table inferior))))
        (lambda (p1 p2)
          (version>? (inferior-package-version p1)
                     (inferior-package-version p2)))))

(define (inferior-package-field package getter)
  "Return the field of PACKAGE, an inferior package, accessed with GETTER."
  (let ((inferior (inferior-package-inferior package))
        (id       (inferior-package-id package)))
    (inferior-eval `(,getter (hashv-ref %package-table ,id))
                   inferior)))

(define* (inferior-package-synopsis package #:key (translate? #t))
  "Return the Texinfo synopsis of PACKAGE, an inferior package.  When
TRANSLATE? is true, translate it to the current locale's language."
  (inferior-package-field package
                          (if translate?
                              '(compose (@ (guix ui) P_) package-synopsis)
                              'package-synopsis)))

(define* (inferior-package-description package #:key (translate? #t))
  "Return the Texinfo description of PACKAGE, an inferior package.  When
TRANSLATE? is true, translate it to the current locale's language."
  (inferior-package-field package
                          (if translate?
                              '(compose (@ (guix ui) P_) package-description)
                              'package-description)))

(define (inferior-package-home-page package)
  "Return the home page of PACKAGE."
  (inferior-package-field package 'package-home-page))

(define (inferior-package-location package)
  "Return the source code location of PACKAGE, either #f or a <location>
record."
  (source-properties->location
   (inferior-package-field package
                           '(compose (lambda (loc)
                                       (and loc
                                            (location->source-properties
                                             loc)))
                                     package-location))))

(define (inferior-package-input-field package field)
  "Return the input field FIELD (e.g., 'native-inputs') of PACKAGE, an
inferior package."
  (define field*
    `(compose (lambda (inputs)
                (map (match-lambda
                       ;; XXX: Origins are not handled.
                       ((label (? package? package) rest ...)
                        (let ((id (object-address package)))
                          (hashv-set! %package-table id package)
                          `(,label (package ,id
                                            ,(package-name package)
                                            ,(package-version package))
                                   ,@rest)))
                       (x
                        x))
                     inputs))
              ,field))

  (define inputs
    (inferior-package-field package field*))

  (define inferior
    (inferior-package-inferior package))

  (map (match-lambda
         ((label ('package id name version) . rest)
          ;; XXX: eq?-ness of inferior packages is not preserved here.
          `(,label ,(inferior-package inferior name version id)
                   ,@rest))
         (x x))
       inputs))

(define inferior-package-inputs
  (cut inferior-package-input-field <> 'package-inputs))

(define inferior-package-native-inputs
  (cut inferior-package-input-field <> 'package-native-inputs))

(define inferior-package-propagated-inputs
  (cut inferior-package-input-field <> 'package-propagated-inputs))

(define inferior-package-transitive-propagated-inputs
  (cut inferior-package-input-field <> 'package-transitive-propagated-inputs))

(define (%inferior-package-search-paths package field)
  "Return the list of search path specificiations of PACKAGE, an inferior
package."
  (define paths
    (inferior-package-field package
                            `(compose (lambda (paths)
                                        (map (@ (guix search-paths)
                                                search-path-specification->sexp)
                                             paths))
                                      ,field)))

  (map sexp->search-path-specification paths))

(define inferior-package-native-search-paths
  (cut %inferior-package-search-paths <> 'package-native-search-paths))

(define inferior-package-search-paths
  (cut %inferior-package-search-paths <> 'package-search-paths))

(define inferior-package-transitive-native-search-paths
  (cut %inferior-package-search-paths <> 'package-transitive-native-search-paths))

(define (proxy client backend)                    ;adapted from (guix ssh)
  "Proxy communication between CLIENT and BACKEND until CLIENT closes the
connection, at which point CLIENT is closed (both CLIENT and BACKEND must be
input/output ports.)"
  (define (select* read write except)
    ;; This is a workaround for <https://bugs.gnu.org/30365> in Guile < 2.2.4:
    ;; since 'select' sometimes returns non-empty sets for no good reason,
    ;; call 'select' a second time with a zero timeout to filter out incorrect
    ;; replies.
    (match (select read write except)
      ((read write except)
       (select read write except 0))))

  ;; Use buffered ports so that 'get-bytevector-some' returns up to the
  ;; whole buffer like read(2) would--see <https://bugs.gnu.org/30066>.
  (setvbuf client _IOFBF 65536)
  (setvbuf backend _IOFBF 65536)

  (let loop ()
    (match (select* (list client backend) '() '())
      ((reads () ())
       (when (memq client reads)
         (match (get-bytevector-some client)
           ((? eof-object?)
            (close-port client))
           (bv
            (put-bytevector backend bv)
            (force-output backend))))
       (when (memq backend reads)
         (match (get-bytevector-some backend)
           (bv
            (put-bytevector client bv)
            (force-output client))))
       (unless (port-closed? client)
         (loop))))))

(define (inferior-eval-with-store inferior store code)
  "Evaluate CODE in INFERIOR, passing it STORE as its argument.  CODE must
thus be the code of a one-argument procedure that accepts a store."
  ;; Create a named socket in /tmp and let INFERIOR connect to it and use it
  ;; as its store.  This ensures the inferior uses the same store, with the
  ;; same options, the same per-session GC roots, etc.
  ;; FIXME: This strategy doesn't work for remote inferiors (SSH).
  (call-with-temporary-directory
   (lambda (directory)
     (chmod directory #o700)
     (let* ((name     (string-append directory "/inferior"))
            (socket   (socket AF_UNIX SOCK_STREAM 0))
            (major    (nix-server-major-version store))
            (minor    (nix-server-minor-version store))
            (proto    (logior major minor)))
       (bind socket AF_UNIX name)
       (listen socket 1024)
       (send-inferior-request
        `(let ((proc   ,code)
               (socket (socket AF_UNIX SOCK_STREAM 0)))
           (connect socket AF_UNIX ,name)

           ;; 'port->connection' appeared in June 2018 and we can hardly
           ;; emulate it on older versions.  Thus fall back to
           ;; 'open-connection', at the risk of talking to the wrong daemon or
           ;; having our build result reclaimed (XXX).
           (let ((store (if (defined? 'port->connection)
                            (port->connection socket #:version ,proto)
                            (open-connection))))
             (dynamic-wind
               (const #t)
               (lambda ()
                 (proc store))
               (lambda ()
                 (close-connection store)
                 (close-port socket)))))
        inferior)
       (match (accept socket)
         ((client . address)
          (proxy client (nix-server-socket store))))
       (close-port socket)
       (read-inferior-response inferior)))))

(define* (inferior-package-derivation store package
                                      #:optional
                                      (system (%current-system))
                                      #:key target)
  "Return the derivation for PACKAGE, an inferior package, built for SYSTEM
and cross-built for TARGET if TARGET is true.  The inferior corresponding to
PACKAGE must be live."
  (define proc
    `(lambda (store)
       (let* ((package (hashv-ref %package-table
                                  ,(inferior-package-id package)))
              (drv     ,(if target
                            `(package-cross-derivation store package
                                                       ,target
                                                       ,system)
                            `(package-derivation store package
                                                 ,system))))
         (derivation-file-name drv))))

  (and=> (inferior-eval-with-store (inferior-package-inferior package) store
                                   proc)
         read-derivation-from-file))

(define inferior-package->derivation
  (store-lift inferior-package-derivation))

(define-gexp-compiler (package-compiler (package <inferior-package>) system
                                        target)
  ;; Compile PACKAGE for SYSTEM, optionally cross-building for TARGET.
  (inferior-package->derivation package system #:target target))

\f
;;;
;;; Manifest entries.
;;;

(define* (inferior-package->manifest-entry package
                                           #:optional (output "out")
                                           #:key (parent (delay #f))
                                           (properties '()))
  "Return a manifest entry for the OUTPUT of package PACKAGE."
  ;; For each dependency, keep a promise pointing to its "parent" entry.
  (letrec* ((deps  (map (match-lambda
                          ((label package)
                           (inferior-package->manifest-entry package
                                                             #:parent (delay entry)))
                          ((label package output)
                           (inferior-package->manifest-entry package output
                                                             #:parent (delay entry))))
                        (inferior-package-propagated-inputs package)))
            (entry (manifest-entry
                     (name (inferior-package-name package))
                     (version (inferior-package-version package))
                     (output output)
                     (item package)
                     (dependencies (delete-duplicates deps))
                     (search-paths
                      (inferior-package-transitive-native-search-paths package))
                     (parent parent)
                     (properties properties))))
    entry))

\f
;;;
;;; Cached inferiors.
;;;

(define %inferior-cache-directory
  ;; Directory for cached inferiors (GC roots).
  (make-parameter (string-append (cache-directory #:ensure? #f)
                                 "/inferiors")))

(define* (inferior-for-channels channels
                                #:key
                                (cache-directory (%inferior-cache-directory))
                                (ttl (* 3600 24 30)))
  "Return an inferior for CHANNELS, a list of channels.  Use the cache at
CACHE-DIRECTORY, where entries can be reclaimed after TTL seconds.  This
procedure opens a new connection to the build daemon.

This is a convenience procedure that people may use in manifests passed to
'guix package -m', for instance."
  (with-store store
    (let ()
      (define instances
        (latest-channel-instances store channels))

      (define key
        (bytevector->base32-string
         (sha256
          (string->utf8
           (string-concatenate (map channel-instance-commit instances))))))

      (define cached
        (string-append cache-directory "/" key))

      (define (base32-encoded-sha256? str)
        (= (string-length str) 52))

      (define (cache-entries directory)
        (map (lambda (file)
               (string-append directory "/" file))
             (scandir directory base32-encoded-sha256?)))

      (define symlink*
        (lift2 symlink %store-monad))

      (define add-indirect-root*
        (store-lift add-indirect-root))

      (mkdir-p cache-directory)
      (maybe-remove-expired-cache-entries cache-directory
                                          cache-entries
                                          #:entry-expiration
                                          (file-expiration-time ttl))

      (if (file-exists? cached)
          (open-inferior cached)
          (run-with-store store
            (mlet %store-monad ((profile
                                 (channel-instances->derivation instances)))
              (mbegin %store-monad
                (show-what-to-build* (list profile))
                (built-derivations (list profile))
                (symlink* (derivation->output-path profile) cached)
                (add-indirect-root* cached)
                (return (open-inferior cached)))))))))
Commit	Line	Data
2ca299ca	1	;;; GNU Guix --- Functional package management for GNU
a65177a6	2	;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
2ca299ca LC	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)
9daf046c LC	22	#:use-module ((guix utils)
	23	#:select (%current-system
	24	source-properties->location
e1a4ffda	25	call-with-temporary-directory
2dad0313 LC	26	version>? version-prefix?
2dad0313 LC	27	cache-directory))
9daf046c LC	28	#:use-module ((guix store)
	29	#:select (nix-server-socket
	30	nix-server-major-version
	31	nix-server-minor-version
	32	store-lift))
	33	#:use-module ((guix derivations)
	34	#:select (read-derivation-from-file))
	35	#:use-module (guix gexp)
eee8b303	36	#:use-module (guix search-paths)
2e6d64e1	37	#:use-module (guix profiles)
2dad0313 LC	38	#:use-module (guix channels)
	39	#:use-module (guix monads)
	40	#:use-module (guix store)
	41	#:use-module (guix derivations)
	42	#:use-module (guix base32)
	43	#:use-module (gcrypt hash)
	44	#:autoload (guix cache) (maybe-remove-expired-cache-entries)
	45	#:autoload (guix ui) (show-what-to-build*)
	46	#:autoload (guix build utils) (mkdir-p)
e1a4ffda	47	#:use-module (srfi srfi-1)
6030396a	48	#:use-module (srfi srfi-26)
2dad0313	49	#:autoload (ice-9 ftw) (scandir)
2ca299ca LC	50	#:use-module (ice-9 match)
2ca299ca LC	51	#:use-module (ice-9 popen)
e1a4ffda	52	#:use-module (ice-9 vlist)
9daf046c	53	#:use-module (ice-9 binary-ports)
2dad0313	54	#:use-module ((rnrs bytevectors) #:select (string->utf8))
2ca299ca LC	55	#:export (inferior?
2ca299ca LC	56	open-inferior
af15fe13	57	port->inferior
2ca299ca LC	58	close-inferior
2ca299ca LC	59	inferior-eval
94c0e61f	60	inferior-eval-with-store
2ca299ca LC	61	inferior-object?
2ca299ca LC	62
2e6d64e1 LC	63	inferior-packages
	64	lookup-inferior-packages
	65
2ca299ca LC	66	inferior-package?
	67	inferior-package-name
	68	inferior-package-version
2ca299ca	69	inferior-package-synopsis
7e1d2290 LC	70	inferior-package-description
7e1d2290 LC	71	inferior-package-home-page
9daf046c	72	inferior-package-location
6030396a LC	73	inferior-package-inputs
	74	inferior-package-native-inputs
	75	inferior-package-propagated-inputs
	76	inferior-package-transitive-propagated-inputs
eee8b303 LC	77	inferior-package-native-search-paths
	78	inferior-package-transitive-native-search-paths
	79	inferior-package-search-paths
2e6d64e1 LC	80	inferior-package-derivation
2e6d64e1 LC	81
2dad0313 LC	82	inferior-package->manifest-entry
	83
	84	%inferior-cache-directory
	85	inferior-for-channels))
2ca299ca LC	86
	87	;;; Commentary:
	88	;;;
	89	;;; This module provides a way to spawn Guix "inferior" processes and to talk
	90	;;; to them. It allows us, from one instance of Guix, to interact with
	91	;;; another instance of Guix coming from a different commit.
	92	;;;
	93	;;; Code:
	94
	95	;; Inferior Guix process.
	96	(define-record-type <inferior>
af15fe13	97	(inferior pid socket close version packages table)
2ca299ca LC	98	inferior?
	99	(pid inferior-pid)
	100	(socket inferior-socket)
af15fe13	101	(close inferior-close-socket) ;procedure
e1a4ffda LC	102	(version inferior-version) ;REPL protocol version
	103	(packages inferior-package-promise) ;promise of inferior packages
	104	(table inferior-package-table)) ;promise of vhash
2ca299ca LC	105
	106	(define (inferior-pipe directory command)
	107	"Return an input/output pipe on the Guix instance in DIRECTORY. This runs
	108	'DIRECTORY/COMMAND repl' if it exists, or falls back to some other method if
	109	it's an old Guix."
	110	(let ((pipe (with-error-to-port (%make-void-port "w")
	111	(lambda ()
	112	(open-pipe* OPEN_BOTH
	113	(string-append directory "/" command)
	114	"repl" "-t" "machine")))))
	115	(if (eof-object? (peek-char pipe))
	116	(begin
	117	(close-pipe pipe)
	118
	119	;; Older versions of Guix didn't have a 'guix repl' command, so
	120	;; emulate it.
	121	(open-pipe* OPEN_BOTH "guile"
	122	"-L" (string-append directory "/share/guile/site/"
	123	(effective-version))
	124	"-C" (string-append directory "/share/guile/site/"
	125	(effective-version))
	126	"-C" (string-append directory "/lib/guile/"
	127	(effective-version) "/site-ccache")
	128	"-c"
	129	(object->string
	130	`(begin
	131	(primitive-load ,(search-path %load-path
	132	"guix/scripts/repl.scm"))
	133	((@ (guix scripts repl) machine-repl))))))
	134	pipe)))
	135
af15fe13 LC	136	(define* (port->inferior pipe #:optional (close close-port))
	137	"Given PIPE, an input/output port, return an inferior that talks over PIPE.
	138	PIPE is closed with CLOSE when 'close-inferior' is called on the returned
	139	inferior."
a65177a6	140	(setvbuf pipe 'line)
a81b59b1	141
2ca299ca LC	142	(match (read pipe)
2ca299ca LC	143	(('repl-version 0 rest ...)
af15fe13	144	(letrec ((result (inferior 'pipe pipe close (cons 0 rest)
e1a4ffda LC	145	(delay (%inferior-packages result))
e1a4ffda LC	146	(delay (%inferior-package-table result)))))
2ca299ca LC	147	(inferior-eval '(use-modules (guix)) result)
2ca299ca LC	148	(inferior-eval '(use-modules (gnu)) result)
6030396a	149	(inferior-eval '(use-modules (ice-9 match)) result)
2ca299ca LC	150	(inferior-eval '(define %package-table (make-hash-table))
	151	result)
	152	result))
	153	(_
	154	#f)))
	155
af15fe13 LC	156	(define* (open-inferior directory #:key (command "bin/guix"))
	157	"Open the inferior Guix in DIRECTORY, running 'DIRECTORY/COMMAND repl' or
	158	equivalent. Return #f if the inferior could not be launched."
	159	(define pipe
	160	(inferior-pipe directory command))
	161
	162	(port->inferior pipe close-pipe))
	163
2ca299ca LC	164	(define (close-inferior inferior)
2ca299ca LC	165	"Close INFERIOR."
af15fe13 LC	166	(let ((close (inferior-close-socket inferior)))
af15fe13 LC	167	(close (inferior-socket inferior))))
2ca299ca LC	168
	169	;; Non-self-quoting object of the inferior.
	170	(define-record-type <inferior-object>
	171	(inferior-object address appearance)
	172	inferior-object?
	173	(address inferior-object-address)
	174	(appearance inferior-object-appearance))
	175
	176	(define (write-inferior-object object port)
	177	(match object
	178	(($ <inferior-object> _ appearance)
	179	(format port "#<inferior-object ~a>" appearance))))
	180
	181	(set-record-type-printer! <inferior-object> write-inferior-object)
	182
9daf046c	183	(define (read-inferior-response inferior)
2ca299ca LC	184	(define sexp->object
	185	(match-lambda
	186	(('value value)
	187	value)
	188	(('non-self-quoting address string)
	189	(inferior-object address string))))
	190
2ca299ca LC	191	(match (read (inferior-socket inferior))
	192	(('values objects ...)
	193	(apply values (map sexp->object objects)))
	194	(('exception key objects ...)
	195	(apply throw key (map sexp->object objects)))))
	196
9daf046c LC	197	(define (send-inferior-request exp inferior)
	198	(write exp (inferior-socket inferior))
	199	(newline (inferior-socket inferior)))
	200
	201	(define (inferior-eval exp inferior)
	202	"Evaluate EXP in INFERIOR."
	203	(send-inferior-request exp inferior)
	204	(read-inferior-response inferior))
	205
2ca299ca LC	206	\f
	207	;;;
	208	;;; Inferior packages.
	209	;;;
	210
	211	(define-record-type <inferior-package>
	212	(inferior-package inferior name version id)
	213	inferior-package?
	214	(inferior inferior-package-inferior)
	215	(name inferior-package-name)
	216	(version inferior-package-version)
	217	(id inferior-package-id))
	218
	219	(define (write-inferior-package package port)
	220	(match package
	221	(($ <inferior-package> _ name version)
	222	(format port "#<inferior-package ~a@~a ~a>"
	223	name version
	224	(number->string (object-address package) 16)))))
	225
	226	(set-record-type-printer! <inferior-package> write-inferior-package)
	227
e1a4ffda LC	228	(define (%inferior-packages inferior)
e1a4ffda LC	229	"Compute the list of inferior packages from INFERIOR."
2ca299ca LC	230	(let ((result (inferior-eval
	231	'(fold-packages (lambda (package result)
	232	(let ((id (object-address package)))
	233	(hashv-set! %package-table id package)
	234	(cons (list (package-name package)
	235	(package-version package)
	236	id)
	237	result)))
	238	'())
	239	inferior)))
	240	(map (match-lambda
	241	((name version id)
	242	(inferior-package inferior name version id)))
	243	result)))
	244
e1a4ffda LC	245	(define (inferior-packages inferior)
	246	"Return the list of packages known to INFERIOR."
	247	(force (inferior-package-promise inferior)))
	248
	249	(define (%inferior-package-table inferior)
	250	"Compute a package lookup table for INFERIOR."
	251	(fold (lambda (package table)
	252	(vhash-cons (inferior-package-name package) package
	253	table))
	254	vlist-null
	255	(inferior-packages inferior)))
	256
	257	(define* (lookup-inferior-packages inferior name #:optional version)
	258	"Return the sorted list of inferior packages matching NAME in INFERIOR, with
	259	highest version numbers first. If VERSION is true, return only packages with
	260	a version number prefixed by VERSION."
	261	;; This is the counterpart of 'find-packages-by-name'.
	262	(sort (filter (lambda (package)
	263	(or (not version)
	264	(version-prefix? version
	265	(inferior-package-version package))))
	266	(vhash-fold* cons '() name
	267	(force (inferior-package-table inferior))))
	268	(lambda (p1 p2)
	269	(version>? (inferior-package-version p1)
	270	(inferior-package-version p2)))))
	271
2ca299ca LC	272	(define (inferior-package-field package getter)
	273	"Return the field of PACKAGE, an inferior package, accessed with GETTER."
	274	(let ((inferior (inferior-package-inferior package))
	275	(id (inferior-package-id package)))
	276	(inferior-eval `(,getter (hashv-ref %package-table ,id))
	277	inferior)))
	278
	279	(define* (inferior-package-synopsis package #:key (translate? #t))
	280	"Return the Texinfo synopsis of PACKAGE, an inferior package. When
	281	TRANSLATE? is true, translate it to the current locale's language."
	282	(inferior-package-field package
	283	(if translate?
	284	'(compose (@ (guix ui) P_) package-synopsis)
	285	'package-synopsis)))
	286
	287	(define* (inferior-package-description package #:key (translate? #t))
	288	"Return the Texinfo description of PACKAGE, an inferior package. When
	289	TRANSLATE? is true, translate it to the current locale's language."
	290	(inferior-package-field package
	291	(if translate?
	292	'(compose (@ (guix ui) P_) package-description)
	293	'package-description)))
7e1d2290 LC	294
	295	(define (inferior-package-home-page package)
	296	"Return the home page of PACKAGE."
	297	(inferior-package-field package 'package-home-page))
	298
	299	(define (inferior-package-location package)
	300	"Return the source code location of PACKAGE, either #f or a <location>
	301	record."
	302	(source-properties->location
	303	(inferior-package-field package
	304	'(compose (lambda (loc)
	305	(and loc
	306	(location->source-properties
	307	loc)))
	308	package-location))))
9daf046c	309
6030396a LC	310	(define (inferior-package-input-field package field)
	311	"Return the input field FIELD (e.g., 'native-inputs') of PACKAGE, an
	312	inferior package."
	313	(define field*
	314	`(compose (lambda (inputs)
	315	(map (match-lambda
	316	;; XXX: Origins are not handled.
	317	((label (? package? package) rest ...)
	318	(let ((id (object-address package)))
	319	(hashv-set! %package-table id package)
	320	`(,label (package ,id
	321	,(package-name package)
	322	,(package-version package))
	323	,@rest)))
	324	(x
	325	x))
	326	inputs))
	327	,field))
	328
	329	(define inputs
	330	(inferior-package-field package field*))
	331
	332	(define inferior
	333	(inferior-package-inferior package))
	334
	335	(map (match-lambda
	336	((label ('package id name version) . rest)
	337	;; XXX: eq?-ness of inferior packages is not preserved here.
	338	`(,label ,(inferior-package inferior name version id)
	339	,@rest))
	340	(x x))
	341	inputs))
	342
	343	(define inferior-package-inputs
	344	(cut inferior-package-input-field <> 'package-inputs))
	345
	346	(define inferior-package-native-inputs
	347	(cut inferior-package-input-field <> 'package-native-inputs))
	348
	349	(define inferior-package-propagated-inputs
	350	(cut inferior-package-input-field <> 'package-propagated-inputs))
	351
	352	(define inferior-package-transitive-propagated-inputs
	353	(cut inferior-package-input-field <> 'package-transitive-propagated-inputs))
	354
eee8b303 LC	355	(define (%inferior-package-search-paths package field)
	356	"Return the list of search path specificiations of PACKAGE, an inferior
	357	package."
	358	(define paths
	359	(inferior-package-field package
	360	`(compose (lambda (paths)
	361	(map (@ (guix search-paths)
	362	search-path-specification->sexp)
	363	paths))
	364	,field)))
	365
	366	(map sexp->search-path-specification paths))
	367
	368	(define inferior-package-native-search-paths
	369	(cut %inferior-package-search-paths <> 'package-native-search-paths))
	370
	371	(define inferior-package-search-paths
	372	(cut %inferior-package-search-paths <> 'package-search-paths))
	373
	374	(define inferior-package-transitive-native-search-paths
	375	(cut %inferior-package-search-paths <> 'package-transitive-native-search-paths))
	376
9daf046c LC	377	(define (proxy client backend) ;adapted from (guix ssh)
	378	"Proxy communication between CLIENT and BACKEND until CLIENT closes the
	379	connection, at which point CLIENT is closed (both CLIENT and BACKEND must be
	380	input/output ports.)"
	381	(define (select* read write except)
	382	;; This is a workaround for <https://bugs.gnu.org/30365> in Guile < 2.2.4:
	383	;; since 'select' sometimes returns non-empty sets for no good reason,
	384	;; call 'select' a second time with a zero timeout to filter out incorrect
	385	;; replies.
	386	(match (select read write except)
	387	((read write except)
	388	(select read write except 0))))
	389
	390	;; Use buffered ports so that 'get-bytevector-some' returns up to the
	391	;; whole buffer like read(2) would--see <https://bugs.gnu.org/30066>.
	392	(setvbuf client _IOFBF 65536)
	393	(setvbuf backend _IOFBF 65536)
	394
	395	(let loop ()
	396	(match (select* (list client backend) '() '())
	397	((reads () ())
	398	(when (memq client reads)
	399	(match (get-bytevector-some client)
	400	((? eof-object?)
	401	(close-port client))
	402	(bv
	403	(put-bytevector backend bv)
	404	(force-output backend))))
	405	(when (memq backend reads)
	406	(match (get-bytevector-some backend)
	407	(bv
	408	(put-bytevector client bv)
	409	(force-output client))))
	410	(unless (port-closed? client)
	411	(loop))))))
	412
94c0e61f LC	413	(define (inferior-eval-with-store inferior store code)
	414	"Evaluate CODE in INFERIOR, passing it STORE as its argument. CODE must
	415	thus be the code of a one-argument procedure that accepts a store."
	416	;; Create a named socket in /tmp and let INFERIOR connect to it and use it
	417	;; as its store. This ensures the inferior uses the same store, with the
	418	;; same options, the same per-session GC roots, etc.
af15fe13	419	;; FIXME: This strategy doesn't work for remote inferiors (SSH).
9daf046c LC	420	(call-with-temporary-directory
	421	(lambda (directory)
	422	(chmod directory #o700)
	423	(let* ((name (string-append directory "/inferior"))
	424	(socket (socket AF_UNIX SOCK_STREAM 0))
9daf046c LC	425	(major (nix-server-major-version store))
	426	(minor (nix-server-minor-version store))
	427	(proto (logior major minor)))
	428	(bind socket AF_UNIX name)
	429	(listen socket 1024)
	430	(send-inferior-request
94c0e61f LC	431	`(let ((proc ,code)
94c0e61f LC	432	(socket (socket AF_UNIX SOCK_STREAM 0)))
9daf046c LC	433	(connect socket AF_UNIX ,name)
	434
	435	;; 'port->connection' appeared in June 2018 and we can hardly
	436	;; emulate it on older versions. Thus fall back to
	437	;; 'open-connection', at the risk of talking to the wrong daemon or
	438	;; having our build result reclaimed (XXX).
94c0e61f LC	439	(let ((store (if (defined? 'port->connection)
	440	(port->connection socket #:version ,proto)
	441	(open-connection))))
	442	(dynamic-wind
	443	(const #t)
	444	(lambda ()
	445	(proc store))
	446	(lambda ()
	447	(close-connection store)
	448	(close-port socket)))))
9daf046c LC	449	inferior)
	450	(match (accept socket)
	451	((client . address)
	452	(proxy client (nix-server-socket store))))
	453	(close-port socket)
94c0e61f LC	454	(read-inferior-response inferior)))))
	455
	456	(define* (inferior-package-derivation store package
	457	#:optional
	458	(system (%current-system))
	459	#:key target)
	460	"Return the derivation for PACKAGE, an inferior package, built for SYSTEM
	461	and cross-built for TARGET if TARGET is true. The inferior corresponding to
	462	PACKAGE must be live."
	463	(define proc
	464	`(lambda (store)
	465	(let* ((package (hashv-ref %package-table
	466	,(inferior-package-id package)))
	467	(drv ,(if target
	468	`(package-cross-derivation store package
	469	,target
	470	,system)
	471	`(package-derivation store package
	472	,system))))
	473	(derivation-file-name drv))))
	474
	475	(and=> (inferior-eval-with-store (inferior-package-inferior package) store
	476	proc)
	477	read-derivation-from-file))
9daf046c LC	478
	479	(define inferior-package->derivation
	480	(store-lift inferior-package-derivation))
	481
	482	(define-gexp-compiler (package-compiler (package <inferior-package>) system
	483	target)
	484	;; Compile PACKAGE for SYSTEM, optionally cross-building for TARGET.
	485	(inferior-package->derivation package system #:target target))
2e6d64e1 LC	486
	487	\f
	488	;;;
	489	;;; Manifest entries.
	490	;;;
	491
	492	(define* (inferior-package->manifest-entry package
	493	#:optional (output "out")
	494	#:key (parent (delay #f))
	495	(properties '()))
	496	"Return a manifest entry for the OUTPUT of package PACKAGE."
	497	;; For each dependency, keep a promise pointing to its "parent" entry.
	498	(letrec* ((deps (map (match-lambda
	499	((label package)
	500	(inferior-package->manifest-entry package
	501	#:parent (delay entry)))
	502	((label package output)
	503	(inferior-package->manifest-entry package output
	504	#:parent (delay entry))))
	505	(inferior-package-propagated-inputs package)))
	506	(entry (manifest-entry
	507	(name (inferior-package-name package))
	508	(version (inferior-package-version package))
	509	(output output)
	510	(item package)
	511	(dependencies (delete-duplicates deps))
	512	(search-paths
	513	(inferior-package-transitive-native-search-paths package))
	514	(parent parent)
	515	(properties properties))))
	516	entry))
2dad0313 LC	517
	518	\f
	519	;;;
	520	;;; Cached inferiors.
	521	;;;
	522
	523	(define %inferior-cache-directory
	524	;; Directory for cached inferiors (GC roots).
	525	(make-parameter (string-append (cache-directory #:ensure? #f)
	526	"/inferiors")))
	527
	528	(define* (inferior-for-channels channels
	529	#:key
	530	(cache-directory (%inferior-cache-directory))
	531	(ttl (* 3600 24 30)))
	532	"Return an inferior for CHANNELS, a list of channels. Use the cache at
	533	CACHE-DIRECTORY, where entries can be reclaimed after TTL seconds. This
	534	procedure opens a new connection to the build daemon.
	535
	536	This is a convenience procedure that people may use in manifests passed to
	537	'guix package -m', for instance."
	538	(with-store store
	539	(let ()
	540	(define instances
	541	(latest-channel-instances store channels))
	542
	543	(define key
	544	(bytevector->base32-string
	545	(sha256
	546	(string->utf8
	547	(string-concatenate (map channel-instance-commit instances))))))
	548
	549	(define cached
	550	(string-append cache-directory "/" key))
	551
	552	(define (base32-encoded-sha256? str)
	553	(= (string-length str) 52))
	554
	555	(define (cache-entries directory)
	556	(map (lambda (file)
	557	(string-append directory "/" file))
	558	(scandir directory base32-encoded-sha256?)))
	559
	560	(define symlink*
	561	(lift2 symlink %store-monad))
	562
	563	(define add-indirect-root*
	564	(store-lift add-indirect-root))
	565
	566	(mkdir-p cache-directory)
	567	(maybe-remove-expired-cache-entries cache-directory
	568	cache-entries
	569	#:entry-expiration
	570	(file-expiration-time ttl))
	571
	572	(if (file-exists? cached)
	573	(open-inferior cached)
	574	(run-with-store store
	575	(mlet %store-monad ((profile
	576	(channel-instances->derivation instances)))
	577	(mbegin %store-monad
	578	(show-what-to-build* (list profile))
	579	(built-derivations (list profile))
	580	(symlink* (derivation->output-path profile) cached)
581	(add-indirect-root* cached)
582	(return (open-inferior cached)))))))))