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