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