From b0a6a9713076347c14ee2dd0ea494ab086df2a82 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Fri, 15 Apr 2016 00:10:22 +0200
Subject: [PATCH] substitute: Honor the number of columns of the client
 terminal.

* guix/store.scm (set-build-options): Add #:terminal-columns parameter
and honor it.
* guix/scripts/substitute.scm (client-terminal-columns): New procedure.
(guix-substitute): Use it to parameterize 'current-terminal-columns'.
---
 guix/scripts/substitute.scm | 20 ++++++++++++++++----
 guix/store.scm              | 10 +++++++++-
 2 files changed, 25 insertions(+), 5 deletions(-)

diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 82ce069598..db0416b0c0 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -31,7 +31,8 @@ (define-module (guix scripts substitute)
   #:use-module (guix pki)
   #:use-module ((guix build utils) #:select (mkdir-p dump-port))
   #:use-module ((guix build download)
-                #:select (progress-proc uri-abbreviation
+                #:select (current-terminal-columns
+                          progress-proc uri-abbreviation
                           open-connection-for-uri
                           close-connection
                           store-path-abbreviation byte-count->string))
@@ -973,6 +974,14 @@ (define %cache-urls
      ;; daemon.
      '("http://hydra.gnu.org"))))
 
+(define (client-terminal-columns)
+  "Return the number of columns in the client's terminal, if it is known, or a
+default value."
+  (or (and=> (or (find-daemon-option "untrusted-terminal-columns")
+                 (find-daemon-option "terminal-columns"))
+             string->number)
+      80))
+
 (define (guix-substitute . args)
   "Implement the build daemon's substituter protocol."
   (mkdir-p %narinfo-cache-directory)
@@ -1003,9 +1012,12 @@ (define (guix-substitute . args)
                   (loop (read-line)))))))
        (("--substitute" store-path destination)
         ;; Download STORE-PATH and add store it as a Nar in file DESTINATION.
-        (process-substitution store-path destination
-                              #:cache-urls %cache-urls
-                              #:acl (current-acl)))
+        ;; Specify the number of columns of the terminal so the progress
+        ;; report displays nicely.
+        (parameterize ((current-terminal-columns (client-terminal-columns)))
+          (process-substitution store-path destination
+                                #:cache-urls %cache-urls
+                                #:acl (current-acl))))
        (("--version")
         (show-version-and-exit "guix substitute"))
        (("--help")
diff --git a/guix/store.scm b/guix/store.scm
index 906611658e..af311a0ebd 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -22,6 +22,7 @@ (define-module (guix store)
   #:use-module (guix serialization)
   #:use-module (guix monads)
   #:autoload   (guix base32) (bytevector->base32-string)
+  #:autoload   (guix build syscalls) (terminal-columns)
   #:use-module (rnrs bytevectors)
   #:use-module (rnrs io ports)
   #:use-module (srfi srfi-1)
@@ -530,7 +531,10 @@ (define* (set-build-options server
                             ;; the daemon's settings are used.  Otherwise, it
                             ;; overrides the daemons settings; see 'guix
                             ;; substitute'.
-                            (substitute-urls #f))
+                            (substitute-urls #f)
+
+                            ;; Number of columns in the client's terminal.
+                            (terminal-columns (terminal-columns)))
   ;; Must be called after `open-connection'.
 
   (define socket
@@ -565,6 +569,10 @@ (define socket
                      ,@(if rounds
                            `(("build-repeat"
                               . ,(number->string (max 0 (1- rounds)))))
+                           '())
+                     ,@(if terminal-columns
+                           `(("terminal-columns"
+                              . ,(number->string terminal-columns)))
                            '()))))
         (send (string-pairs pairs))))
     (let loop ((done? (process-stderr server)))