guix/inferior.scm

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