Merge branch 'ungrafting' into staging

4 files changed, 87 insertions, 60 deletions

diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm
index 20e82ae2ca..4767bc082d 100644
--- a/guix/scripts/import/cran.scm
+++ b/guix/scripts/import/cran.scm
@@ -67,6 +67,10 @@ Import and convert the CRAN package for PACKAGE-NAME.\n"))
                  (lambda (opt name arg result)
                    (alist-cons 'repo (string->symbol arg)
                                (alist-delete 'repo result))))
+         (option '(#\s "style") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'style (string->symbol arg)
+                               (alist-delete 'style result))))
          (option '(#\r "recursive") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'recursive #t result)))
@@ -93,23 +97,24 @@ Import and convert the CRAN package for PACKAGE-NAME.\n"))
                              value)
                             (_ #f))
                            (reverse opts))))
-    (match args
-      ((package-name)
-       (if (assoc-ref opts 'recursive)
-           ;; Recursive import
-           (with-error-handling
-             (map package->definition
-                  (filter identity
-                          (cran-recursive-import package-name
-                                                 #:repo (or (assoc-ref opts 'repo) 'cran)))))
-           ;; Single import
-           (let ((sexp (cran->guix-package package-name
-                                           #:repo (or (assoc-ref opts 'repo) 'cran))))
-             (unless sexp
-               (leave (G_ "failed to download description for package '~a'~%")
-                      package-name))
-             sexp)))
-      (()
-       (leave (G_ "too few arguments~%")))
-      ((many ...)
-       (leave (G_ "too many arguments~%"))))))
+    (parameterize ((%input-style (assoc-ref opts 'style)))
+      (match args
+        ((package-name)
+         (if (assoc-ref opts 'recursive)
+             ;; Recursive import
+             (with-error-handling
+               (map package->definition
+                    (filter identity
+                            (cran-recursive-import package-name
+                                                   #:repo (or (assoc-ref opts 'repo) 'cran)))))
+             ;; Single import
+             (let ((sexp (cran->guix-package package-name
+                                             #:repo (or (assoc-ref opts 'repo) 'cran))))
+               (unless sexp
+                 (leave (G_ "failed to download description for package '~a'~%")
+                        package-name))
+               sexp)))
+        (()
+         (leave (G_ "too few arguments~%")))
+        ((many ...)
+         (leave (G_ "too many arguments~%")))))))
diff --git a/guix/scripts/import/crate.scm b/guix/scripts/import/crate.scm
index 9252c52dfa..3a96defb86 100644
--- a/guix/scripts/import/crate.scm
+++ b/guix/scripts/import/crate.scm
@@ -42,7 +42,7 @@
 
 (define (show-help)
   (display (G_ "Usage: guix import crate PACKAGE-NAME
-Import and convert the crate.io package for PACKAGE-NAME.\n"))
+Import and convert the crates.io package for PACKAGE-NAME.\n"))
   (display (G_ "
   -r, --recursive        import packages recursively"))
   (newline)
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index 58ee53e85c..835078cb97 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -634,7 +634,8 @@ daemon is not running."
                            (and add-text-to-store 'alright))
                         node)
     ('alright #t)
-    (_ (report-module-error name)))
+    (_ (leave (G_ "(guix) module not usable on remote host '~a'")
+              name)))
 
   (match (inferior-eval '(begin
                            (use-modules (guix))
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 38702d0c4b..8084c89ae5 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -514,12 +514,18 @@ return its MAX-LENGTH first elements and its tail."
 
 (define* (http-multiple-get base-uri proc seed requests
                             #:key port (verify-certificate? #t)
+                            (open-connection guix:open-connection-for-uri)
+                            (keep-alive? #t)
                             (batch-size 1000))
   "Send all of REQUESTS to the server at BASE-URI.  Call PROC for each
 response, passing it the request object, the response, a port from which to
 read the response body, and the previous result, starting with SEED, à la
-'fold'.  Return the final result.  When PORT is specified, use it as the
-initial connection on which HTTP requests are sent."
+'fold'.  Return the final result.
+
+When PORT is specified, use it as the initial connection on which HTTP
+requests are sent; otherwise call OPEN-CONNECTION to open a new connection for
+a URI.  When KEEP-ALIVE? is false, close the connection port before
+returning."
   (let connect ((port     port)
                 (requests requests)
                 (result   seed))
@@ -528,10 +534,9 @@ initial connection on which HTTP requests are sent."
 
     ;; (format (current-error-port) "connecting (~a requests left)..."
     ;;         (length requests))
-    (let ((p (or port (guix:open-connection-for-uri
-                       base-uri
-                       #:verify-certificate?
-                       verify-certificate?))))
+    (let ((p (or port (open-connection base-uri
+                                       #:verify-certificate?
+                                       verify-certificate?))))
       ;; For HTTPS, P is not a file port and does not support 'setvbuf'.
       (when (file-port? p)
         (setvbuf p 'block (expt 2 16)))
@@ -556,7 +561,8 @@ initial connection on which HTTP requests are sent."
           (()
            (match (drop requests processed)
              (()
-              (close-port p)
+              (unless keep-alive?
+                (close-port p))
               (reverse result))
              (remainder
               (connect p remainder result))))
@@ -598,18 +604,18 @@ if file doesn't exist, and the narinfo otherwise."
 
 (define* (open-connection-for-uri/maybe uri
                                         #:key
-                                        (verify-certificate? #f)
+                                        fresh?
                                         (time %fetch-timeout))
-  "Open a connection to URI and return a port to it, or, if connection failed,
-print a warning and return #f."
+  "Open a connection to URI via 'open-connection-for-uri/cached' and return a
+port to it, or, if connection failed, print a warning and return #f.  Pass
+#:fresh? to 'open-connection-for-uri/cached'."
   (define host
     (uri-host uri))
 
   (catch #t
     (lambda ()
-      (guix:open-connection-for-uri uri
-                                    #:verify-certificate? verify-certificate?
-                                    #:timeout time))
+      (open-connection-for-uri/cached uri #:timeout time
+                                      #:fresh? fresh?))
     (match-lambda*
       (('getaddrinfo-error error)
        (unless (hash-ref %unreachable-hosts host)
@@ -683,23 +689,26 @@ print a warning and return #f."
   (define (do-fetch uri)
     (case (and=> uri uri-scheme)
       ((http https)
-       (let ((requests (map (cut narinfo-request url <>) paths)))
-         (match (open-connection-for-uri/maybe uri)
-           (#f
-            '())
-           (port
-            (update-progress!)
-            ;; Note: Do not check HTTPS server certificates to avoid depending
-            ;; on the X.509 PKI.  We can do it because we authenticate
-            ;; narinfos, which provides a much stronger guarantee.
-            (let ((result (http-multiple-get uri
-                                             handle-narinfo-response '()
-                                             requests
-                                             #:verify-certificate? #f
-                                             #:port port)))
-              (close-port port)
-              (newline (current-error-port))
-              result)))))
+       ;; Note: Do not check HTTPS server certificates to avoid depending
+       ;; on the X.509 PKI.  We can do it because we authenticate
+       ;; narinfos, which provides a much stronger guarantee.
+       (let* ((requests (map (cut narinfo-request url <>) paths))
+              (result   (call-with-cached-connection uri
+                          (lambda (port)
+                            (if port
+                                (begin
+                                  (update-progress!)
+                                  (http-multiple-get uri
+                                                     handle-narinfo-response '()
+                                                     requests
+                                                     #:open-connection
+                                                     open-connection-for-uri/cached
+                                                     #:verify-certificate? #f
+                                                     #:port port))
+                                '()))
+                          open-connection-for-uri/maybe)))
+         (newline (current-error-port))
+         result))
       ((file #f)
        (let* ((base  (string-append (uri-path uri) "/"))
               (files (map (compose (cut string-append base <> ".narinfo")
@@ -990,10 +999,14 @@ the URI, its compression method (a string), and the compressed file size."
 
 (define open-connection-for-uri/cached
   (let ((cache '()))
-    (lambda* (uri #:key fresh?)
+    (lambda* (uri #:key fresh? timeout verify-certificate?)
       "Return a connection for URI, possibly reusing a cached connection.
-When FRESH? is true, delete any cached connections for URI and open a new
-one.  Return #f if URI's scheme is 'file' or #f."
+When FRESH? is true, delete any cached connections for URI and open a new one.
+Return #f if URI's scheme is 'file' or #f.
+
+When true, TIMEOUT is the maximum number of milliseconds to wait for
+connection establishment.  When VERIFY-CERTIFICATE? is true, verify HTTPS
+server certificates."
       (define host (uri-host uri))
       (define scheme (uri-scheme uri))
       (define key (list host scheme (uri-port uri)))
@@ -1005,7 +1018,9 @@ one.  Return #f if URI's scheme is 'file' or #f."
               ;; CACHE, if any.
               (let-values (((socket)
                             (guix:open-connection-for-uri
-                             uri #:verify-certificate? #f))
+                             uri
+                             #:verify-certificate? verify-certificate?
+                             #:timeout timeout))
                            ((new-cache evicted)
                             (at-most (- %max-cached-connections 1) cache)))
                 (for-each (match-lambda
@@ -1019,14 +1034,19 @@ one.  Return #f if URI's scheme is 'file' or #f."
                   (begin
                     (false-if-exception (close-port socket))
                     (set! cache (alist-delete key cache))
-                    (open-connection-for-uri/cached uri))
+                    (open-connection-for-uri/cached uri #:timeout timeout
+                                                    #:verify-certificate?
+                                                    verify-certificate?))
                   (begin
                     ;; Drain input left from the previous use.
                     (drain-input socket)
                     socket))))))))
 
-(define (call-with-cached-connection uri proc)
-  (let ((port (open-connection-for-uri/cached uri)))
+(define* (call-with-cached-connection uri proc
+                                      #:optional
+                                      (open-connection
+                                       open-connection-for-uri/cached))
+  (let ((port (open-connection uri)))
     (catch #t
       (lambda ()
         (proc port))
@@ -1038,7 +1058,7 @@ one.  Return #f if URI's scheme is 'file' or #f."
         (if (or (and (eq? key 'system-error)
                      (= EPIPE (system-error-errno `(,key ,@args))))
                 (memq key '(bad-response bad-header bad-header-component)))
-            (proc (open-connection-for-uri/cached uri #:fresh? #t))
+            (proc (open-connection uri #:fresh? #t))
             (apply throw key args))))))
 
 (define-syntax-rule (with-cached-connection uri port exp ...)
@@ -1341,6 +1361,7 @@ default value."
 ;;; Local Variables:
 ;;; eval: (put 'with-timeout 'scheme-indent-function 1)
 ;;; eval: (put 'with-cached-connection 'scheme-indent-function 2)
+;;; eval: (put 'call-with-cached-connection 'scheme-indent-function 1)
 ;;; End:
 
 ;;; substitute.scm ends here