[PATCH 2/2] git-download: Respect current-http-proxy when downloading.

[Jookia]

Enable the use of HTTP proxies for Git and add a helper program for proxying
the non-HTTP git:// protocol. The program connects standard input/output to a
remote server. To accomplish this for now, socat is used.

* guix/build/git.scm (module): Export git-proxy.
  (git-fetch): Take a proxy parameter for the proxy program.
  (git-fetch): Set GIT_PROXY_COMMAND to the proxy if current-http-proxy is set.
  (git-proxy): Add git-proxy command to be used as an executable.
  (git-proxy): Pass standard input through socat, bail if unable to parse proxy.
* guix/git-download.scm (git-fetch): Add socat parameter.
  (git-fetch): Add proxy program-file that runs git-proxy.
  (git-fetch): Leak the http_proxy environmental variable.
---
 guix/build/git.scm    | 37 +++++++++++++++++++++++++++++++++++--
 guix/git-download.scm | 24 ++++++++++++++++++++++--
 2 files changed, 57 insertions(+), 4 deletions(-)

diff --git a/guix/build/git.scm b/guix/build/git.scm
index c1af545..ea911c8 100644
--- a/guix/build/git.scm
+++ b/guix/build/git.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014, 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2016 Jookia <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -17,8 +18,14 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix build git)
+  #:use-module (ice-9 regex)
+  #:use-module (ice-9 format)
+  #:use-module (srfi srfi-2)
+  #:use-module (web uri)
+  #:use-module (web client)
   #:use-module (guix build utils)
-  #:export (git-fetch))
+  #:export (git-fetch
+            git-proxy))
 
 ;;; Commentary:
 ;;;
@@ -28,7 +35,7 @@
 ;;; Code:
 
 (define* (git-fetch url commit directory
-                    #:key (git-command "git") recursive?)
+                    #:key (git-command "git") proxy recursive?)
   "Fetch COMMIT from URL into DIRECTORY.  COMMIT must be a valid Git commit
 identifier.  When RECURSIVE? is true, all the sub-modules of URL are fetched,
 recursively.  Return #t on success, #f otherwise."
@@ -37,6 +44,11 @@ recursively.  Return #t on success, #f otherwise."
   ;; in advance anyway.
   (setenv "GIT_SSL_NO_VERIFY" "true")
 
+  ;; Set up Git to proxy git:// URLs over the http_proxy if needed.
+  (if (current-http-proxy)
+      (setenv "GIT_PROXY_COMMAND" proxy)
+      '())
+
   ;; We cannot use "git clone --recursive" since the following "git checkout"
   ;; effectively removes sub-module checkouts as of Git 2.6.3.
   (and (zero? (system* git-command "clone" url directory))
@@ -60,5 +72,26 @@ recursively.  Return #t on success, #f otherwise."
                 ;; directory needs to be taken out.
                 (delete-file-recursively ".git")
                 #t)))))
+
+;;;
+;;; Network.
+;;;
+
+(define* (git-proxy #:key socat)
+  "Use SOCAT and the environment's HTTP_PROXY variable to tunnel traffic
+between the standard input/output and the proxy."
+  (or (and-let* ((proxy-uri   (string->uri (current-http-proxy)))
+                 (proxy-host  (uri-host proxy-uri))
+                 (proxy-port  (number->string (uri-port proxy-uri)))
+                 (remote-host (list-ref (command-line) 1))
+                 (remote-port (list-ref (command-line) 2)))
+        (or (zero? (system* socat "STDIO"
+                           (string-append "PROXY:" proxy-host ":"
+                                          remote-host ":" remote-port ","
+                                          "proxyport=" proxy-port)))
+            (format (current-error-port)
+                    "socat exited with a non-zero exit code!~%")))
+      (format (current-error-port)
+              "Unable to parse current-http-proxy ~s~%" (current-http-proxy))))
 
 ;;; git.scm ends here
diff --git a/guix/git-download.scm b/guix/git-download.scm
index 1e5c845..bf3b67a 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014, 2015 Ludovic Courtès <address@hidden>
+;;; Copyright © 2016 Jookia <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -48,15 +49,24 @@
   (recursive? git-reference-recursive?   ; whether to recurse into sub-modules
               (default #f)))
 
+;;; These two -package functions are needed to avoid circular module imports.
+
 (define (git-package)
   "Return the default Git package."
   (let ((distro (resolve-interface '(gnu packages version-control))))
     (module-ref distro 'git)))
 
+(define (socat-package)
+  "Return the default socat package."
+  (let ((distro (resolve-interface '(gnu packages networking))))
+    (module-ref distro 'socat)))
+
+
 (define* (git-fetch ref hash-algo hash
                     #:optional name
                     #:key (system (%current-system)) (guile (default-guile))
-                    (git (git-package)))
+                    (git (git-package))
+                    (socat (socat-package)))
   "Return a fixed-output derivation that fetches REF, a <git-reference>
 object.  The output is expected to have recursive hash HASH of type
 HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
@@ -67,6 +77,14 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a 
generic name if #f."
         (standard-packages)
         '()))
 
+  (define proxy-script
+      (program-file "git-proxy"
+        #~(begin
+            (use-modules (guix build git))
+            (git-proxy #:socat (string-append #$socat "/bin/socat")))
+        #:modules '((guix build git)
+                    (guix build utils))))
+
   (define build
     #~(begin
         (use-modules (guix build git)
@@ -84,7 +102,8 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a 
generic name if #f."
                    '#$(git-reference-commit ref)
                    #$output
                    #:recursive? '#$(git-reference-recursive? ref)
-                   #:git-command (string-append #+git "/bin/git"))))
+                   #:git-command (string-append #+git "/bin/git")
+                   #:proxy #$proxy-script)))
 
   (mlet %store-monad ((guile (package->derivation guile system)))
     (gexp->derivation (or name "git-checkout") build
@@ -95,6 +114,7 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a 
generic name if #f."
                       #:recursive? #t
                       #:modules '((guix build git)
                                   (guix build utils))
+                      #:leaked-env-vars '("http_proxy")
                       #:guile-for-build guile
                       #:local-build? #t)))
 
-- 
2.7.0