guix/inferior.scm

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