Merge branch 'master' into core-updates

6 files changed, 164 insertions, 49 deletions

diff --git a/guix/build/compile.scm b/guix/build/compile.scm
index ea0c36fa33..8b5a2faf84 100644
--- a/guix/build/compile.scm
+++ b/guix/build/compile.scm
@@ -77,6 +77,12 @@
   "Strip the \".scm\" suffix from FILE, and append \".go\"."
   (string-append (string-drop-right file 4) ".go"))
 
+(define (relative-file directory file)
+  "Return FILE relative to DIRECTORY, if possible."
+  (if (string-prefix? (string-append directory "/") file)
+      (string-drop file (+ 1 (string-length directory)))
+      file))
+
 (define* (load-files directory files
                      #:key
                      (report-load (const #f))
@@ -93,13 +99,14 @@
          (report-load #f total completed))
        *unspecified*)
       ((file files ...)
-       (report-load file total completed)
-       (format debug-port "~%loading '~a'...~%" file)
+       (let ((file (relative-file directory file)))
+         (report-load file total completed)
+         (format debug-port "~%loading '~a'...~%" file)
 
-       (parameterize ((current-warning-port debug-port))
-         (resolve-interface (file-name->module-name file)))
+         (parameterize ((current-warning-port debug-port))
+           (resolve-interface (file-name->module-name file)))
 
-       (loop files (+ 1 completed))))))
+         (loop files (+ 1 completed)))))))
 
 (define-syntax-rule (with-augmented-search-path path item body ...)
   "Within the dynamic extent of BODY, augment PATH by adding ITEM to the
@@ -135,11 +142,12 @@ files are for HOST, a GNU triplet such as \"x86_64-linux-gnu\"."
     (with-fluids ((*current-warning-prefix* ""))
       (with-target host
         (lambda ()
-          (compile-file file
-                        #:output-file (string-append build-directory "/"
-                                                     (scm->go file))
-                        #:opts (append warning-options
-                                       (optimization-options file))))))
+          (let ((relative (relative-file source-directory file)))
+            (compile-file file
+                          #:output-file (string-append build-directory "/"
+                                                       (scm->go relative))
+                          #:opts (append warning-options
+                                         (optimization-options relative)))))))
     (with-mutex progress-lock
       (set! completed (+ 1 completed))))
 
diff --git a/guix/build/download.scm b/guix/build/download.scm
index 61c9c6d3f1..4490d225e6 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -130,7 +130,8 @@ out if the connection could not be established in less than TIMEOUT seconds."
                  (_ (ftp-open (uri-host uri) #:timeout timeout))))
          (size (false-if-exception (ftp-size conn (uri-path uri))))
          (in   (ftp-retr conn (basename (uri-path uri))
-                         (dirname (uri-path uri)))))
+                         (dirname (uri-path uri))
+                         #:timeout timeout)))
     (call-with-output-file file
       (lambda (out)
         (dump-port* in out
@@ -305,6 +306,13 @@ host name without trailing dot."
       ;; never be closed.  So we use `fileno', but keep a weak reference to
       ;; PORT, so the file descriptor gets closed when RECORD is GC'd.
       (register-tls-record-port record port)
+
+      ;; Write HTTP requests line by line rather than byte by byte:
+      ;; <https://bugs.gnu.org/22966>.  This is not possible on Guile 2.0.
+      (cond-expand
+        (guile-2.0 #f)
+        (else (setvbuf record 'line)))
+
       record)))
 
 (define (ensure-uri uri-or-string)                ;XXX: copied from (web http)
@@ -513,6 +521,57 @@ port if PORT is a TLS session record port."
       (let ((declare-relative-uri-header! (variable-ref var)))
         (declare-relative-uri-header! "Location")))))
 
+;; XXX: Work around broken proxy handling on Guile 2.2 <= 2.2.2, fixed in
+;; Guile commits 7d0d9e2c25c1e872cfc7d14ab5139915f1813d56 and
+;; 6ad28ae3bc6a6d9e95ab7d70510d12c97673a143.  See bug report at
+;; <https://lists.gnu.org/archive/html/guix-devel/2017-11/msg00070.html>.
+(cond-expand
+  (guile-2.2
+   (when (<= (string->number (micro-version)) 2)
+     (let ()
+       (define put-symbol (@@ (web http) put-symbol))
+       (define put-non-negative-integer
+         (@@ (web http) put-non-negative-integer))
+       (define write-http-version
+         (@@ (web http) write-http-version))
+
+       (define (write-request-line method uri version port)
+         "Write the first line of an HTTP request to PORT."
+         (put-symbol port method)
+         (put-char port #\space)
+         (when (http-proxy-port? port)
+           (let ((scheme (uri-scheme uri))
+                 (host (uri-host uri))
+                 (host-port (uri-port uri)))
+             (when (and scheme host)
+               (put-symbol port scheme)
+               (put-string port "://")
+               (cond
+                ((string-index host #\:)          ;<---- The fix is here!
+                 (put-char port #\[)              ;<---- And here!
+                 (put-string port host)
+                 (put-char port #\]))
+                (else
+                 (put-string port host)))
+               (unless ((@@ (web uri) default-port?) scheme host-port)
+                 (put-char port #\:)
+                 (put-non-negative-integer port host-port)))))
+         (let ((path (uri-path uri))
+               (query (uri-query uri)))
+           (if (string-null? path)
+               (put-string port "/")
+               (put-string port path))
+           (when query
+             (put-string port "?")
+             (put-string port query)))
+         (put-char port #\space)
+         (write-http-version version port)
+         (put-string port "\r\n"))
+
+       (module-set! (resolve-module '(web http)) 'write-request-line
+                    write-request-line))))
+  (else #t))
+
 (define (resolve-uri-reference ref base)
   "Resolve the URI reference REF, interpreted relative to the BASE URI, into a
 target URI, according to the algorithm specified in RFC 3986 section 5.2.2.
diff --git a/guix/build/go-build-system.scm b/guix/build/go-build-system.scm
index d175f3b76a..eaad9d8751 100644
--- a/guix/build/go-build-system.scm
+++ b/guix/build/go-build-system.scm
@@ -22,6 +22,8 @@
   #:use-module (guix build utils)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
+  #:use-module (rnrs io ports)
+  #:use-module (rnrs bytevectors)
   #:export (%standard-phases
             go-build))
 
@@ -197,13 +199,66 @@ respectively."
 
 (define* (install #:key outputs #:allow-other-keys)
   "Install the compiled libraries. `go install` installs these files to
-$GOPATH/pkg, so we have to copy them into the output direcotry manually.
+$GOPATH/pkg, so we have to copy them into the output directory manually.
 Compiled executable files should have already been installed to the store based
 on $GOBIN in the build phase."
   (when (file-exists? "pkg")
     (copy-recursively "pkg" (string-append (assoc-ref outputs "out") "/pkg")))
   #t)
 
+(define* (remove-store-reference file file-name
+                                  #:optional (store (%store-directory)))
+  "Remove from FILE occurrences of FILE-NAME in STORE; return #t when FILE-NAME
+is encountered in FILE, #f otherwise. This implementation reads FILE one byte at
+a time, which is slow. Instead, we should use the Boyer-Moore string search
+algorithm; there is an example in (guix build grafts)."
+  (define pattern
+    (string-take file-name
+                 (+ 34 (string-length (%store-directory)))))
+
+  (with-fluids ((%default-port-encoding #f))
+    (with-atomic-file-replacement file
+      (lambda (in out)
+        ;; We cannot use `regexp-exec' here because it cannot deal with
+        ;; strings containing NUL characters.
+        (format #t "removing references to `~a' from `~a'...~%" file-name file)
+        (setvbuf in 'block 65536)
+        (setvbuf out 'block 65536)
+        (fold-port-matches (lambda (match result)
+                             (put-bytevector out (string->utf8 store))
+                             (put-u8 out (char->integer #\/))
+                             (put-bytevector out
+                                             (string->utf8
+                                              "eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee-"))
+                             #t)
+                           #f
+                           pattern
+                           in
+                           (lambda (char result)
+                             (put-u8 out (char->integer char))
+                             result))))))
+
+(define* (remove-go-references #:key allow-go-reference?
+                               inputs outputs #:allow-other-keys)
+  "Remove any references to the Go compiler from the compiled Go executable
+files in OUTPUTS."
+;; We remove this spurious reference to save bandwidth when installing Go
+;; executables. It would be better to not embed the reference in the first
+;; place, but I'm not sure how to do that. The subject was discussed at:
+;; <https://lists.gnu.org/archive/html/guix-devel/2017-10/msg00207.html>
+  (if allow-go-reference?
+    #t
+    (let ((go (assoc-ref inputs "go"))
+          (bin "/bin"))
+      (for-each (lambda (output)
+                  (when (file-exists? (string-append (cdr output)
+                                                     bin))
+                    (for-each (lambda (file)
+                                (remove-store-reference file go))
+                              (find-files (string-append (cdr output) bin)))))
+                outputs)
+      #t)))
+
 (define %standard-phases
   (modify-phases gnu:%standard-phases
     (delete 'configure)
@@ -213,7 +268,8 @@ on $GOBIN in the build phase."
     (add-before 'build 'setup-environment setup-environment)
     (replace 'build build)
     (replace 'check check)
-    (replace 'install install)))
+    (replace 'install install)
+    (add-after 'install 'remove-go-references remove-go-references)))
 
 (define* (go-build #:key inputs (phases %standard-phases)
                       #:allow-other-keys #:rest args)
diff --git a/guix/build/graft.scm b/guix/build/graft.scm
index 3dce486adf..e567bff4f4 100644
--- a/guix/build/graft.scm
+++ b/guix/build/graft.scm
@@ -214,6 +214,7 @@ an exception is caught."
           (print-exception port #f key args)
           (primitive-exit 1))))))
 
+;; We need this as long as we support Guile < 2.0.13.
 (define* (mkdir-p* dir #:optional (mode #o755))
   "This is a variant of 'mkdir-p' that works around
 <http://bugs.gnu.org/24659> by passing MODE explicitly in each 'mkdir' call."
diff --git a/guix/build/pull.scm b/guix/build/pull.scm
index 3573241a7e..a011e366f6 100644
--- a/guix/build/pull.scm
+++ b/guix/build/pull.scm
@@ -121,41 +121,32 @@ containing the source code.  Write any debugging output to DEBUG-PORT."
 
     ;; Compile the .scm files.  Hide warnings.
     (parameterize ((current-warning-port (%make-void-port "w")))
-      (with-directory-excursion out
-        ;; Filter out files depending on Guile-SSH when Guile-SSH is missing.
-        (let ((files (filter has-all-its-dependencies?
-                             (all-scheme-files "."))))
-          (compile-files out out
-
-                         ;; XXX: 'compile-files' except ready-to-use relative
-                         ;; file names.
-                         (map (lambda (file)
-                                (if (string-prefix? "./" file)
-                                    (string-drop file 2)
-                                    file))
-                              files)
-
-                         #:workers (parallel-job-count)
-
-                         ;; Disable warnings.
-                         #:warning-options '()
-
-                         #:report-load
-                         (lambda (file total completed)
-                           (display #\cr log-port)
-                           (format log-port
-                                   "loading...\t~5,1f% of ~d files" ;FIXME: i18n
-                                   (* 100. (/ completed total)) total)
-                           (force-output log-port)
-                           (format debug-port "~%loading '~a'...~%" file))
-
-                         #:report-compilation
-                         (lambda (file total completed)
-                           (display #\cr log-port)
-                           (format log-port "compiling...\t~5,1f% of ~d files" ;FIXME: i18n
-                                   (* 100. (/ completed total)) total)
-                           (force-output log-port)
-                           (format debug-port "~%compiling '~a'...~%" file)))))))
+      ;; Filter out files depending on Guile-SSH when Guile-SSH is missing.
+      (let ((files (filter has-all-its-dependencies?
+                           (all-scheme-files out))))
+        (compile-files out out files
+
+                       #:workers (parallel-job-count)
+
+                       ;; Disable warnings.
+                       #:warning-options '()
+
+                       #:report-load
+                       (lambda (file total completed)
+                         (display #\cr log-port)
+                         (format log-port
+                                 "loading...\t~5,1f% of ~d files" ;FIXME: i18n
+                                 (* 100. (/ completed total)) total)
+                         (force-output log-port)
+                         (format debug-port "~%loading '~a'...~%" file))
+
+                       #:report-compilation
+                       (lambda (file total completed)
+                         (display #\cr log-port)
+                         (format log-port "compiling...\t~5,1f% of ~d files" ;FIXME: i18n
+                                 (* 100. (/ completed total)) total)
+                         (force-output log-port)
+                         (format debug-port "~%compiling '~a'...~%" file))))))
 
   (newline)
   #t)
diff --git a/guix/build/texlive-build-system.scm b/guix/build/texlive-build-system.scm
index c0f262a5c0..f6b9b96b87 100644
--- a/guix/build/texlive-build-system.scm
+++ b/guix/build/texlive-build-system.scm
@@ -46,7 +46,7 @@
     ;; Build a modifiable union of all inputs (but exclude bash)
     (match inputs
       (((names . directories) ...)
-       (union-build out directories
+       (union-build out (filter directory-exists? directories)
                     #:create-all-directories? #t
                     #:log-port (%make-void-port "w"))))