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