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