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 <l...@gnu.org> +;;; Copyright © 2016 Jookia <166...@gmail.com> ;;; ;;; 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 <l...@gnu.org> +;;; Copyright © 2016 Jookia <166...@gmail.com> ;;; ;;; 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
