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