guix/inferior.scm

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