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 6b685ec..7782087 100644 (file)
--- a/guix/inferior.scm
+++ b/guix/inferior.scm
@@ -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))
@@ -66,6 +67,7 @@
             inferior-exception?
             inferior-exception-arguments
             inferior-exception-inferior
+            inferior-exception-stack
             read-repl-response
 
             inferior-packages
@@ -159,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)
@@ -202,7 +213,8 @@ equivalent.  Return #f if the inferior could not be launched."
 (define-condition-type &inferior-exception &error
   inferior-exception?
   (arguments  inferior-exception-arguments)       ;key + arguments
-  (inferior   inferior-exception-inferior))       ;<inferior> | #f
+  (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.
@@ -217,10 +229,19 @@ Raise '&inferior-exception' when an exception is read from PORT."
   (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 ...)
+     ;; Protocol (0 0).
      (raise (condition (&inferior-exception
                         (arguments (cons key (map sexp->object objects)))
-                        (inferior inferior)))))))
+                        (inferior inferior)
+                        (stack '())))))))
 
 (define (read-inferior-response inferior)
   (read-repl-response (inferior-socket inferior)
@@ -667,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
@@ -712,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))))))