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