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