guix/inferior.scm

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