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

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 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
            close-inferior
            inferior-eval
            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 version packages table)
  inferior?
  (pid      inferior-pid)
  (socket   inferior-socket)
  (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* (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))

  (cond-expand
    ((and guile-2 (not guile-2.2)) #t)
    (else (setvbuf pipe 'line)))

  (match (read pipe)
    (('repl-version 0 rest ...)
     (letrec ((result (inferior 'pipe pipe (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 (close-inferior inferior)
  "Close INFERIOR."
  (close-pipe (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-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."
  ;; Create a named socket in /tmp and let the inferior of PACKAGE 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.
  (call-with-temporary-directory
   (lambda (directory)
     (chmod directory #o700)
     (let* ((name     (string-append directory "/inferior"))
            (socket   (socket AF_UNIX SOCK_STREAM 0))
            (inferior (inferior-package-inferior package))
            (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 ((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)))
                  (package (hashv-ref %package-table
                                      ,(inferior-package-id package)))
                  (drv     ,(if target
                                `(package-cross-derivation store package
                                                           ,target
                                                           ,system)
                                `(package-derivation store package
                                                     ,system))))
             (close-connection store)
             (close-port socket)
             (derivation-file-name drv)))
        inferior)
       (match (accept socket)
         ((client . address)
          (proxy client (nix-server-socket store))))
       (close-port socket)
       (read-derivation-from-file (read-inferior-response inferior))))))

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