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