gnu: r-qtl2: Move to (gnu packages cran).

[jackhill/guix/guix.git] / guix / inferior.scm

diff --git a/guix/inferior.scm b/guix/inferior.scm
index 71dae89..7782087 100644 (file)
--- a/guix/inferior.scm
+++ b/guix/inferior.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -21,9 +21,10 @@
   #:use-module (srfi srfi-9 gnu)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
+  #:use-module ((guix diagnostics)
+                #:select (source-properties->location))
   #:use-module ((guix utils)
                 #:select (%current-system
-                          source-properties->location
                           call-with-temporary-directory
                           version>? version-prefix?
                           cache-directory))
@@ -44,7 +45,8 @@
   #:use-module (guix derivations)
   #:use-module (guix base32)
   #:use-module (gcrypt hash)
-  #:autoload   (guix cache) (maybe-remove-expired-cache-entries)
+  #:autoload   (guix cache) (maybe-remove-expired-cache-entries
+                             file-expiration-time)
   #:autoload   (guix ui) (show-what-to-build*)
   #:autoload   (guix build utils) (mkdir-p)
   #:use-module (srfi srfi-1)
@@ -62,6 +64,10 @@
             inferior-eval
             inferior-eval-with-store
             inferior-object?
+            inferior-exception?
+            inferior-exception-arguments
+            inferior-exception-inferior
+            inferior-exception-stack
             read-repl-response
 
             inferior-packages
@@ -82,6 +88,7 @@
             inferior-package-native-search-paths
             inferior-package-transitive-native-search-paths
             inferior-package-search-paths
+            inferior-package-provenance
             inferior-package-derivation
 
             inferior-package->manifest-entry
@@ -154,6 +161,15 @@ inferior."
      (letrec ((result (inferior 'pipe pipe close (cons 0 rest)
                                 (delay (%inferior-packages result))
                                 (delay (%inferior-package-table result)))))
+
+       ;; For protocol (0 1) and later, send the protocol version we support.
+       (match rest
+         ((n _ ...)
+          (when (>= n 1)
+            (send-inferior-request '(() repl-version 0 1 1) result)))
+         (_
+          #t))
+
        (inferior-eval '(use-modules (guix)) result)
        (inferior-eval '(use-modules (gnu)) result)
        (inferior-eval '(use-modules (ice-9 match)) result)
@@ -193,8 +209,16 @@ equivalent.  Return #f if the inferior could not be launched."
 
 (set-record-type-printer! <inferior-object> write-inferior-object)
 
-(define (read-repl-response port)
-  "Read a (guix repl) response from PORT and return it as a Scheme object."
+;; Reified exception thrown by an inferior.
+(define-condition-type &inferior-exception &error
+  inferior-exception?
+  (arguments  inferior-exception-arguments)       ;key + arguments
+  (inferior   inferior-exception-inferior)        ;<inferior> | #f
+  (stack      inferior-exception-stack))          ;list of (FILE COLUMN LINE)
+
+(define* (read-repl-response port #:optional inferior)
+  "Read a (guix repl) response from PORT and return it as a Scheme object.
+Raise '&inferior-exception' when an exception is read from PORT."
   (define sexp->object
     (match-lambda
       (('value value)
@@ -205,11 +229,23 @@ equivalent.  Return #f if the inferior could not be launched."
   (match (read port)
     (('values objects ...)
      (apply values (map sexp->object objects)))
+    (('exception ('arguments key objects ...)
+                 ('stack frames ...))
+     ;; Protocol (0 1 1) and later.
+     (raise (condition (&inferior-exception
+                        (arguments (cons key (map sexp->object objects)))
+                        (inferior inferior)
+                        (stack frames)))))
     (('exception key objects ...)
-     (apply throw key (map sexp->object objects)))))
+     ;; Protocol (0 0).
+     (raise (condition (&inferior-exception
+                        (arguments (cons key (map sexp->object objects)))
+                        (inferior inferior)
+                        (stack '())))))))
 
 (define (read-inferior-response inferior)
-  (read-repl-response (inferior-socket inferior)))
+  (read-repl-response (inferior-socket inferior)
+                      inferior))
 
 (define (send-inferior-request exp inferior)
   (write exp (inferior-socket inferior))
@@ -416,6 +452,19 @@ package."
 (define inferior-package-transitive-native-search-paths
   (cut %inferior-package-search-paths <> 'package-transitive-native-search-paths))
 
+(define (inferior-package-provenance package)
+  "Return a \"provenance sexp\" for PACKAGE, an inferior package.  The result
+is similar to the sexp returned by 'package-provenance' for regular packages."
+  (inferior-package-field package
+                          '(let* ((describe
+                                   (false-if-exception
+                                    (resolve-interface '(guix describe))))
+                                  (provenance
+                                   (false-if-exception
+                                    (module-ref describe
+                                                'package-provenance))))
+                             (or provenance (const #f)))))
+
 (define (proxy client backend)                    ;adapted from (guix ssh)
   "Proxy communication between CLIENT and BACKEND until CLIENT closes the
 connection, at which point CLIENT is closed (both CLIENT and BACKEND must be
@@ -639,13 +688,16 @@ failing when GUIX is too old and lacks the 'guix repl' command."
 (define* (cached-channel-instance store
                                   channels
                                   #:key
+                                  (authenticate? #t)
                                   (cache-directory (%inferior-cache-directory))
                                   (ttl (* 3600 24 30)))
   "Return a directory containing a guix filetree defined by CHANNELS, a list of channels.
 The directory is a subdirectory of CACHE-DIRECTORY, where entries can be reclaimed after TTL seconds.
-This procedure opens a new connection to the build daemon."
+This procedure opens a new connection to the build daemon.  AUTHENTICATE?
+determines whether CHANNELS are authenticated."
   (define instances
-    (latest-channel-instances store channels))
+    (latest-channel-instances store channels
+                              #:authenticate? authenticate?))
 
   (define key
     (bytevector->base32-string
@@ -684,6 +736,8 @@ This procedure opens a new connection to the build daemon."
           (mbegin %store-monad
             (show-what-to-build* (list profile))
             (built-derivations (list profile))
+            ;; Note: Caching is fine even when AUTHENTICATE? is false because
+            ;; we always call 'latest-channel-instances?'.
             (symlink* (derivation->output-path profile) cached)
             (add-indirect-root* cached)
             (return cached))))))