guix/inferior.scm

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