guix/inferior.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018, 2019 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 ((guix utils)
  23                 #:select (%current-system
  24                           source-properties->location
  25                           call-with-temporary-directory
  26                           version>? version-prefix?
  27                           cache-directory))
  28   #:use-module ((guix store)
  29                 #:select (nix-server-socket
  30                           nix-server-major-version
  31                           nix-server-minor-version
  32                           store-lift))
  33   #:use-module ((guix derivations)
  34                 #:select (read-derivation-from-file))
  35   #:use-module (guix gexp)
  36   #:use-module (guix search-paths)
  37   #:use-module (guix profiles)
  38   #:use-module (guix channels)
  39   #:use-module (guix monads)
  40   #:use-module (guix store)
  41   #:use-module (guix derivations)
  42   #:use-module (guix base32)
  43   #:use-module (gcrypt hash)
  44   #:autoload   (guix cache) (maybe-remove-expired-cache-entries)
  45   #:autoload   (guix ui) (show-what-to-build*)
  46   #:autoload   (guix build utils) (mkdir-p)
  47   #:use-module (srfi srfi-1)
  48   #:use-module (srfi srfi-26)
  49   #:autoload   (ice-9 ftw) (scandir)
  50   #:use-module (ice-9 match)
  51   #:use-module (ice-9 popen)
  52   #:use-module (ice-9 vlist)
  53   #:use-module (ice-9 binary-ports)
  54   #:use-module ((rnrs bytevectors) #:select (string->utf8))
  55   #:export (inferior?
  56             open-inferior
  57             port->inferior
  58             close-inferior
  59             inferior-eval
  60             inferior-eval-with-store
  61             inferior-object?
  62
  63             inferior-packages
  64             lookup-inferior-packages
  65
  66             inferior-package?
  67             inferior-package-name
  68             inferior-package-version
  69             inferior-package-synopsis
  70             inferior-package-description
  71             inferior-package-home-page
  72             inferior-package-location
  73             inferior-package-inputs
  74             inferior-package-native-inputs
  75             inferior-package-propagated-inputs
  76             inferior-package-transitive-propagated-inputs
  77             inferior-package-native-search-paths
  78             inferior-package-transitive-native-search-paths
  79             inferior-package-search-paths
  80             inferior-package-derivation
  81
  82             inferior-package->manifest-entry
  83
  84             gexp->derivation-in-inferior
  85
  86             %inferior-cache-directory
  87             inferior-for-channels))
  88
  89 ;;; Commentary:
  90 ;;;
  91 ;;; This module provides a way to spawn Guix "inferior" processes and to talk
  92 ;;; to them.  It allows us, from one instance of Guix, to interact with
  93 ;;; another instance of Guix coming from a different commit.
  94 ;;;
  95 ;;; Code:
  96
  97 ;; Inferior Guix process.
  98 (define-record-type <inferior>
  99   (inferior pid socket close version packages table)
 100   inferior?
 101   (pid      inferior-pid)
 102   (socket   inferior-socket)
 103   (close    inferior-close-socket)               ;procedure
 104   (version  inferior-version)                    ;REPL protocol version
 105   (packages inferior-package-promise)            ;promise of inferior packages
 106   (table    inferior-package-table))             ;promise of vhash
 107
 108 (define (inferior-pipe directory command)
 109   "Return an input/output pipe on the Guix instance in DIRECTORY.  This runs
 110 'DIRECTORY/COMMAND repl' if it exists, or falls back to some other method if
 111 it's an old Guix."
 112   (let ((pipe (with-error-to-port (%make-void-port "w")
 113                 (lambda ()
 114                   (open-pipe* OPEN_BOTH
 115                               (string-append directory "/" command)
 116                               "repl" "-t" "machine")))))
 117     (if (eof-object? (peek-char pipe))
 118         (begin
 119           (close-pipe pipe)
 120
 121           ;; Older versions of Guix didn't have a 'guix repl' command, so
 122           ;; emulate it.
 123           (open-pipe* OPEN_BOTH "guile"
 124                       "-L" (string-append directory "/share/guile/site/"
 125                                           (effective-version))
 126                       "-C" (string-append directory "/share/guile/site/"
 127                                           (effective-version))
 128                       "-C" (string-append directory "/lib/guile/"
 129                                           (effective-version) "/site-ccache")
 130                       "-c"
 131                       (object->string
 132                        `(begin
 133                           (primitive-load ,(search-path %load-path
 134                                                         "guix/scripts/repl.scm"))
 135                           ((@ (guix scripts repl) machine-repl))))))
 136         pipe)))
 137
 138 (define* (port->inferior pipe #:optional (close close-port))
 139   "Given PIPE, an input/output port, return an inferior that talks over PIPE.
 140 PIPE is closed with CLOSE when 'close-inferior' is called on the returned
 141 inferior."
 142   (setvbuf pipe 'line)
 143
 144   (match (read pipe)
 145     (('repl-version 0 rest ...)
 146      (letrec ((result (inferior 'pipe pipe close (cons 0 rest)
 147                                 (delay (%inferior-packages result))
 148                                 (delay (%inferior-package-table result)))))
 149        (inferior-eval '(use-modules (guix)) result)
 150        (inferior-eval '(use-modules (gnu)) result)
 151        (inferior-eval '(use-modules (ice-9 match)) result)
 152        (inferior-eval '(define %package-table (make-hash-table))
 153                       result)
 154        result))
 155     (_
 156      #f)))
 157
 158 (define* (open-inferior directory #:key (command "bin/guix"))
 159   "Open the inferior Guix in DIRECTORY, running 'DIRECTORY/COMMAND repl' or
 160 equivalent.  Return #f if the inferior could not be launched."
 161   (define pipe
 162     (inferior-pipe directory command))
 163
 164   (port->inferior pipe close-pipe))
 165
 166 (define (close-inferior inferior)
 167   "Close INFERIOR."
 168   (let ((close (inferior-close-socket inferior)))
 169     (close (inferior-socket inferior))))
 170
 171 ;; Non-self-quoting object of the inferior.
 172 (define-record-type <inferior-object>
 173   (inferior-object address appearance)
 174   inferior-object?
 175   (address     inferior-object-address)
 176   (appearance  inferior-object-appearance))
 177
 178 (define (write-inferior-object object port)
 179   (match object
 180     (($ <inferior-object> _ appearance)
 181      (format port "#<inferior-object ~a>" appearance))))
 182
 183 (set-record-type-printer! <inferior-object> write-inferior-object)
 184
 185 (define (read-inferior-response inferior)
 186   (define sexp->object
 187     (match-lambda
 188       (('value value)
 189        value)
 190       (('non-self-quoting address string)
 191        (inferior-object address string))))
 192
 193   (match (read (inferior-socket inferior))
 194     (('values objects ...)
 195      (apply values (map sexp->object objects)))
 196     (('exception key objects ...)
 197      (apply throw key (map sexp->object objects)))))
 198
 199 (define (send-inferior-request exp inferior)
 200   (write exp (inferior-socket inferior))
 201   (newline (inferior-socket inferior)))
 202
 203 (define (inferior-eval exp inferior)
 204   "Evaluate EXP in INFERIOR."
 205   (send-inferior-request exp inferior)
 206   (read-inferior-response inferior))
 207
 208 \f
 209 ;;;
 210 ;;; Inferior packages.
 211 ;;;
 212
 213 (define-record-type <inferior-package>
 214   (inferior-package inferior name version id)
 215   inferior-package?
 216   (inferior   inferior-package-inferior)
 217   (name       inferior-package-name)
 218   (version    inferior-package-version)
 219   (id         inferior-package-id))
 220
 221 (define (write-inferior-package package port)
 222   (match package
 223     (($ <inferior-package> _ name version)
 224      (format port "#<inferior-package ~a@~a ~a>"
 225              name version
 226              (number->string (object-address package) 16)))))
 227
 228 (set-record-type-printer! <inferior-package> write-inferior-package)
 229
 230 (define (%inferior-packages inferior)
 231   "Compute the list of inferior packages from INFERIOR."
 232   (let ((result (inferior-eval
 233                  '(fold-packages (lambda (package result)
 234                                    (let ((id (object-address package)))
 235                                      (hashv-set! %package-table id package)
 236                                      (cons (list (package-name package)
 237                                                  (package-version package)
 238                                                  id)
 239                                            result)))
 240                                  '())
 241                  inferior)))
 242     (map (match-lambda
 243            ((name version id)
 244             (inferior-package inferior name version id)))
 245          result)))
 246
 247 (define (inferior-packages inferior)
 248   "Return the list of packages known to INFERIOR."
 249   (force (inferior-package-promise inferior)))
 250
 251 (define (%inferior-package-table inferior)
 252   "Compute a package lookup table for INFERIOR."
 253   (fold (lambda (package table)
 254           (vhash-cons (inferior-package-name package) package
 255                       table))
 256         vlist-null
 257         (inferior-packages inferior)))
 258
 259 (define* (lookup-inferior-packages inferior name #:optional version)
 260   "Return the sorted list of inferior packages matching NAME in INFERIOR, with
 261 highest version numbers first.  If VERSION is true, return only packages with
 262 a version number prefixed by VERSION."
 263   ;; This is the counterpart of 'find-packages-by-name'.
 264   (sort (filter (lambda (package)
 265                   (or (not version)
 266                       (version-prefix? version
 267                                        (inferior-package-version package))))
 268                 (vhash-fold* cons '() name
 269                              (force (inferior-package-table inferior))))
 270         (lambda (p1 p2)
 271           (version>? (inferior-package-version p1)
 272                      (inferior-package-version p2)))))
 273
 274 (define (inferior-package-field package getter)
 275   "Return the field of PACKAGE, an inferior package, accessed with GETTER."
 276   (let ((inferior (inferior-package-inferior package))
 277         (id       (inferior-package-id package)))
 278     (inferior-eval `(,getter (hashv-ref %package-table ,id))
 279                    inferior)))
 280
 281 (define* (inferior-package-synopsis package #:key (translate? #t))
 282   "Return the Texinfo synopsis of PACKAGE, an inferior package.  When
 283 TRANSLATE? is true, translate it to the current locale's language."
 284   (inferior-package-field package
 285                           (if translate?
 286                               '(compose (@ (guix ui) P_) package-synopsis)
 287                               'package-synopsis)))
 288
 289 (define* (inferior-package-description package #:key (translate? #t))
 290   "Return the Texinfo description of PACKAGE, an inferior package.  When
 291 TRANSLATE? is true, translate it to the current locale's language."
 292   (inferior-package-field package
 293                           (if translate?
 294                               '(compose (@ (guix ui) P_) package-description)
 295                               'package-description)))
 296
 297 (define (inferior-package-home-page package)
 298   "Return the home page of PACKAGE."
 299   (inferior-package-field package 'package-home-page))
 300
 301 (define (inferior-package-location package)
 302   "Return the source code location of PACKAGE, either #f or a <location>
 303 record."
 304   (source-properties->location
 305    (inferior-package-field package
 306                            '(compose (lambda (loc)
 307                                        (and loc
 308                                             (location->source-properties
 309                                              loc)))
 310                                      package-location))))
 311
 312 (define (inferior-package-input-field package field)
 313   "Return the input field FIELD (e.g., 'native-inputs') of PACKAGE, an
 314 inferior package."
 315   (define field*
 316     `(compose (lambda (inputs)
 317                 (map (match-lambda
 318                        ;; XXX: Origins are not handled.
 319                        ((label (? package? package) rest ...)
 320                         (let ((id (object-address package)))
 321                           (hashv-set! %package-table id package)
 322                           `(,label (package ,id
 323                                             ,(package-name package)
 324                                             ,(package-version package))
 325                                    ,@rest)))
 326                        (x
 327                         x))
 328                      inputs))
 329               ,field))
 330
 331   (define inputs
 332     (inferior-package-field package field*))
 333
 334   (define inferior
 335     (inferior-package-inferior package))
 336
 337   (map (match-lambda
 338          ((label ('package id name version) . rest)
 339           ;; XXX: eq?-ness of inferior packages is not preserved here.
 340           `(,label ,(inferior-package inferior name version id)
 341                    ,@rest))
 342          (x x))
 343        inputs))
 344
 345 (define inferior-package-inputs
 346   (cut inferior-package-input-field <> 'package-inputs))
 347
 348 (define inferior-package-native-inputs
 349   (cut inferior-package-input-field <> 'package-native-inputs))
 350
 351 (define inferior-package-propagated-inputs
 352   (cut inferior-package-input-field <> 'package-propagated-inputs))
 353
 354 (define inferior-package-transitive-propagated-inputs
 355   (cut inferior-package-input-field <> 'package-transitive-propagated-inputs))
 356
 357 (define (%inferior-package-search-paths package field)
 358   "Return the list of search path specificiations of PACKAGE, an inferior
 359 package."
 360   (define paths
 361     (inferior-package-field package
 362                             `(compose (lambda (paths)
 363                                         (map (@ (guix search-paths)
 364                                                 search-path-specification->sexp)
 365                                              paths))
 366                                       ,field)))
 367
 368   (map sexp->search-path-specification paths))
 369
 370 (define inferior-package-native-search-paths
 371   (cut %inferior-package-search-paths <> 'package-native-search-paths))
 372
 373 (define inferior-package-search-paths
 374   (cut %inferior-package-search-paths <> 'package-search-paths))
 375
 376 (define inferior-package-transitive-native-search-paths
 377   (cut %inferior-package-search-paths <> 'package-transitive-native-search-paths))
 378
 379 (define (proxy client backend)                    ;adapted from (guix ssh)
 380   "Proxy communication between CLIENT and BACKEND until CLIENT closes the
 381 connection, at which point CLIENT is closed (both CLIENT and BACKEND must be
 382 input/output ports.)"
 383   (define (select* read write except)
 384     ;; This is a workaround for <https://bugs.gnu.org/30365> in Guile < 2.2.4:
 385     ;; since 'select' sometimes returns non-empty sets for no good reason,
 386     ;; call 'select' a second time with a zero timeout to filter out incorrect
 387     ;; replies.
 388     (match (select read write except)
 389       ((read write except)
 390        (select read write except 0))))
 391
 392   ;; Use buffered ports so that 'get-bytevector-some' returns up to the
 393   ;; whole buffer like read(2) would--see <https://bugs.gnu.org/30066>.
 394   (setvbuf client 'block 65536)
 395   (setvbuf backend 'block 65536)
 396
 397   (let loop ()
 398     (match (select* (list client backend) '() '())
 399       ((reads () ())
 400        (when (memq client reads)
 401          (match (get-bytevector-some client)
 402            ((? eof-object?)
 403             (close-port client))
 404            (bv
 405             (put-bytevector backend bv)
 406             (force-output backend))))
 407        (when (memq backend reads)
 408          (match (get-bytevector-some backend)
 409            (bv
 410             (put-bytevector client bv)
 411             (force-output client))))
 412        (unless (port-closed? client)
 413          (loop))))))
 414
 415 (define (inferior-eval-with-store inferior store code)
 416   "Evaluate CODE in INFERIOR, passing it STORE as its argument.  CODE must
 417 thus be the code of a one-argument procedure that accepts a store."
 418   ;; Create a named socket in /tmp and let INFERIOR connect to it and use it
 419   ;; as its store.  This ensures the inferior uses the same store, with the
 420   ;; same options, the same per-session GC roots, etc.
 421   ;; FIXME: This strategy doesn't work for remote inferiors (SSH).
 422   (call-with-temporary-directory
 423    (lambda (directory)
 424      (chmod directory #o700)
 425      (let* ((name     (string-append directory "/inferior"))
 426             (socket   (socket AF_UNIX SOCK_STREAM 0))
 427             (major    (nix-server-major-version store))
 428             (minor    (nix-server-minor-version store))
 429             (proto    (logior major minor)))
 430        (bind socket AF_UNIX name)
 431        (listen socket 1024)
 432        (send-inferior-request
 433         `(let ((proc   ,code)
 434                (socket (socket AF_UNIX SOCK_STREAM 0)))
 435            (connect socket AF_UNIX ,name)
 436
 437            ;; 'port->connection' appeared in June 2018 and we can hardly
 438            ;; emulate it on older versions.  Thus fall back to
 439            ;; 'open-connection', at the risk of talking to the wrong daemon or
 440            ;; having our build result reclaimed (XXX).
 441            (let ((store (if (defined? 'port->connection)
 442                             (port->connection socket #:version ,proto)
 443                             (open-connection))))
 444              (dynamic-wind
 445                (const #t)
 446                (lambda ()
 447                  (proc store))
 448                (lambda ()
 449                  (close-connection store)
 450                  (close-port socket)))))
 451         inferior)
 452        (match (accept socket)
 453          ((client . address)
 454           (proxy client (nix-server-socket store))))
 455        (close-port socket)
 456        (read-inferior-response inferior)))))
 457
 458 (define* (inferior-package-derivation store package
 459                                       #:optional
 460                                       (system (%current-system))
 461                                       #:key target)
 462   "Return the derivation for PACKAGE, an inferior package, built for SYSTEM
 463 and cross-built for TARGET if TARGET is true.  The inferior corresponding to
 464 PACKAGE must be live."
 465   (define proc
 466     `(lambda (store)
 467        (let* ((package (hashv-ref %package-table
 468                                   ,(inferior-package-id package)))
 469               (drv     ,(if target
 470                             `(package-cross-derivation store package
 471                                                        ,target
 472                                                        ,system)
 473                             `(package-derivation store package
 474                                                  ,system))))
 475          (derivation-file-name drv))))
 476
 477   (and=> (inferior-eval-with-store (inferior-package-inferior package) store
 478                                    proc)
 479          read-derivation-from-file))
 480
 481 (define inferior-package->derivation
 482   (store-lift inferior-package-derivation))
 483
 484 (define-gexp-compiler (package-compiler (package <inferior-package>) system
 485                                         target)
 486   ;; Compile PACKAGE for SYSTEM, optionally cross-building for TARGET.
 487   (inferior-package->derivation package system #:target target))
 488
 489 (define* (gexp->derivation-in-inferior name exp guix
 490                                        #:rest rest)
 491   "Return a derivation that evaluates EXP with GUIX, an instance of Guix as
 492 returned for example by 'channel-instances->derivation'.  Other arguments are
 493 passed as-is to 'gexp->derivation'."
 494   (define trampoline
 495     ;; This is a crude way to run EXP on GUIX.  TODO: use 'raw-derivation' and
 496     ;; make 'guix repl' the "builder"; this will require "opening up" the
 497     ;; mechanisms behind 'gexp->derivation', and adding '-l' to 'guix repl'.
 498     #~(begin
 499         (use-modules (ice-9 popen))
 500
 501         (let ((pipe (open-pipe* OPEN_WRITE
 502                                 #+(file-append guix "/bin/guix")
 503                                 "repl" "-t" "machine")))
 504           ;; Unquote EXP right here so that its references to #$output
 505           ;; propagate to the surrounding gexp.
 506           (write '#$exp pipe)                     ;XXX: load path for EXP?
 507
 508           (unless (zero? (close-pipe pipe))
 509             (error "inferior failed" #+guix)))))
 510
 511   (apply gexp->derivation name trampoline rest))
 512
 513 \f
 514 ;;;
 515 ;;; Manifest entries.
 516 ;;;
 517
 518 (define* (inferior-package->manifest-entry package
 519                                            #:optional (output "out")
 520                                            #:key (parent (delay #f))
 521                                            (properties '()))
 522   "Return a manifest entry for the OUTPUT of package PACKAGE."
 523   ;; For each dependency, keep a promise pointing to its "parent" entry.
 524   (letrec* ((deps  (map (match-lambda
 525                           ((label package)
 526                            (inferior-package->manifest-entry package
 527                                                              #:parent (delay entry)))
 528                           ((label package output)
 529                            (inferior-package->manifest-entry package output
 530                                                              #:parent (delay entry))))
 531                         (inferior-package-propagated-inputs package)))
 532             (entry (manifest-entry
 533                      (name (inferior-package-name package))
 534                      (version (inferior-package-version package))
 535                      (output output)
 536                      (item package)
 537                      (dependencies (delete-duplicates deps))
 538                      (search-paths
 539                       (inferior-package-transitive-native-search-paths package))
 540                      (parent parent)
 541                      (properties properties))))
 542     entry))
 543
 544 \f
 545 ;;;
 546 ;;; Cached inferiors.
 547 ;;;
 548
 549 (define %inferior-cache-directory
 550   ;; Directory for cached inferiors (GC roots).
 551   (make-parameter (string-append (cache-directory #:ensure? #f)
 552                                  "/inferiors")))
 553
 554 (define* (inferior-for-channels channels
 555                                 #:key
 556                                 (cache-directory (%inferior-cache-directory))
 557                                 (ttl (* 3600 24 30)))
 558   "Return an inferior for CHANNELS, a list of channels.  Use the cache at
 559 CACHE-DIRECTORY, where entries can be reclaimed after TTL seconds.  This
 560 procedure opens a new connection to the build daemon.
 561
 562 This is a convenience procedure that people may use in manifests passed to
 563 'guix package -m', for instance."
 564   (with-store store
 565     (let ()
 566       (define instances
 567         (latest-channel-instances store channels))
 568
 569       (define key
 570         (bytevector->base32-string
 571          (sha256
 572           (string->utf8
 573            (string-concatenate (map channel-instance-commit instances))))))
 574
 575       (define cached
 576         (string-append cache-directory "/" key))
 577
 578       (define (base32-encoded-sha256? str)
 579         (= (string-length str) 52))
 580
 581       (define (cache-entries directory)
 582         (map (lambda (file)
 583                (string-append directory "/" file))
 584              (scandir directory base32-encoded-sha256?)))
 585
 586       (define symlink*
 587         (lift2 symlink %store-monad))
 588
 589       (define add-indirect-root*
 590         (store-lift add-indirect-root))
 591
 592       (mkdir-p cache-directory)
 593       (maybe-remove-expired-cache-entries cache-directory
 594                                           cache-entries
 595                                           #:entry-expiration
 596                                           (file-expiration-time ttl))
 597
 598       (if (file-exists? cached)
 599           (open-inferior cached)
 600           (run-with-store store
 601             (mlet %store-monad ((profile
 602                                  (channel-instances->derivation instances)))
 603               (mbegin %store-monad
 604                 (show-what-to-build* (list profile))
 605                 (built-derivations (list profile))
 606                 (symlink* (derivation->output-path profile) cached)
 607                 (add-indirect-root* cached)
 608                 (return (open-inferior cached)))))))))