[bug#31285] [PATCH 1/1] guix: Add git-fetch/impure.

[Chris Marusich <cmmarusich@gmail.com>]

* guix/git-download.scm (clone-to-store, clone-to-store*)
(git-reference->name, git-fetch/impure): New procedures.  Export
git-fetch/impure.
* doc/guix.texi (origin Reference): Document it.
---
 doc/guix.texi         |  24 +++++++
 guix/git-download.scm | 150 ++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 174 insertions(+)

diff --git a/doc/guix.texi b/doc/guix.texi
index 75886e94b..182e15428 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -3553,6 +3553,30 @@ specified in the @code{uri} field as a @code{git-reference} object; a
   (url "git://git.debian.org/git/pkg-shadow/shadow")
   (commit "v4.1.5.1"))
 @end example
+
+@vindex git-fetch/impure
+@item @var{git-fetch/impure} from @code{(guix git-download)}
+This procedure is the same as @code{git-fetch} in spirit; however, it
+explicitly allows impurities from the environment in which it is
+invoked: the @code{ssh} client program currently available via the
+@code{PATH} environment variable, its SSH configuration file (usually
+found at @file{~/.ssh/config}), and any SSH agent that is currently
+running (usually made available via environment variables such as
+@code{SSH_AUTH_SOCK}).  Such impurities may seem concerning at first
+blush; however, because this method will fail unless its content hash
+matches the expected value, a successful git-fetch/impure is guaranteed
+to produce the exact same output as a successful git-fetch for the same
+commit.
+
+This procedure is useful if for example you need to fetch a Git
+repository that is only available via an authenticated SSH connection.
+In this case, an example @code{git-reference} might look like this:
+
+@example
+(git-reference
+  (url "ssh://username@@git.sv.gnu.org:/srv/git/guix.git")
+  (commit "486de7377f25438b0f44fd93f97e9ef822d558b8"))
+@end example
 @end table
 
 @item @code{sha256}
diff --git a/guix/git-download.scm b/guix/git-download.scm
index 33f102bc6..04c90e448 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Mathieu Lirzin <mthl@gnu.org>
 ;;; Copyright © 2017 Christopher Baines <mail@cbaines.net>
+;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -24,14 +25,19 @@
   #:use-module (guix store)
   #:use-module (guix monads)
   #:use-module (guix records)
+  #:use-module (guix derivations)
   #:use-module (guix packages)
   #:use-module (guix modules)
+  #:use-module (guix ui)
+  #:use-module ((guix build git)
+                #:select ((git-fetch . build:git-fetch)))
   #:autoload   (guix build-system gnu) (standard-packages)
   #:use-module (ice-9 match)
   #:use-module (ice-9 popen)
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 vlist)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
   #:export (git-reference
             git-reference?
             git-reference-url
@@ -39,6 +45,7 @@
             git-reference-recursive?
 
             git-fetch
+            git-fetch/impure
             git-version
             git-file-name
             git-predicate))
@@ -140,6 +147,149 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
                       #:recursive? #t
                       #:guile-for-build guile)))
 
+(define (clone-to-store store name git-reference hash runtime-dependencies)
+  "Clone a Git repository and add it to the store.  STORE is an open
+connection to the store.  NAME will be used as the file name.  GIT-REFERENCE
+is a <git-reference> describing the Git repository to clone.  HASH is the
+recursive SHA256 hash value of the Git repository, as produced by \"guix hash
+--recursive\" after the .git directories have been removed; if a fixed output
+derivation has already added content to the store with this HASH, then this
+procedure returns immediately.  RUNTIME-DEPENDENCIES is a list of store paths;
+the \"bin\" directory of the RUNTIME-DEPENDENCIES will be added to the PATH
+environment variable before running the \"git\" program."
+  (define (is-source? name stat)
+    ;; It's source if and only if it isn't a .git directory.
+    (not (and (eq? (stat:type stat) 'directory)
+              (equal? name ".git"))))
+
+  (define (clean staging-directory)
+    (when (file-exists? staging-directory)
+      (info (G_ "Removing staging directory `~a'~%") staging-directory)
+      (delete-file-recursively staging-directory)))
+
+  (define (fetch staging-directory)
+    (info
+     (G_ "Downloading Git repository `~a' to staging directory `~a'~%")
+     (git-reference-url git-reference)
+     staging-directory)
+    (mkdir-p staging-directory)
+    ;; TODO: Make Git print to stderr instead of stdout.
+    (build:git-fetch
+     (git-reference-url git-reference)
+     (git-reference-commit git-reference)
+     staging-directory
+     #:recursive? (git-reference-recursive? git-reference))
+    (info (G_ "Adding `~a' to the store~%") staging-directory)
+    ;; Even when the git fetch was not done recursively, we want to
+    ;; recursively add to the store the results of the git fetch.
+    (add-to-store store name #t "sha256" staging-directory
+                  #:select? is-source?))
+
+  ;; To avoid fetching the repository when it has already been added to the
+  ;; store previously, the name passed to fixed-output-path must be the same
+  ;; as the name used when calling gexp->derivation in git-fetch/ssh.
+  (let* ((already-fetched? (false-if-exception
+                            (valid-path? store (fixed-output-path name hash))))
+         (tmpdir (or (getenv "TMPDIR") "/tmp"))
+         (checkouts-directory (string-append tmpdir "/guix-git-ssh-checkouts"))
+         (staging-directory (string-append checkouts-directory "/" name))
+         (original-path (getenv "PATH")))
+    ;; We might need to clean up before starting.  For example, we would need
+    ;; to do that if Guile crashed during a previous fetch.
+    (clean staging-directory)
+    (unless already-fetched?
+      ;; Put our Guix-managed runtime dependencies at the front of the PATH so
+      ;; they will be used in favor of whatever happens to be in the user's
+      ;; environment (except for SSH, of course).  Redirect stdout to stderr
+      ;; to keep set-path-environment-variable from printing a misleading
+      ;; message about PATH's value, since we immediately change it.
+      (parameterize ((current-output-port (%make-void-port "w")))
+        (set-path-environment-variable "PATH" '("bin") runtime-dependencies))
+      (let ((new-path (if original-path
+                          (string-append (getenv "PATH") ":" original-path)
+                          (getenv "PATH"))))
+        (setenv "PATH" new-path)
+        (info (G_ "Set environment variable PATH to `~a'~%") new-path)
+        (let ((result (fetch staging-directory)))
+          (clean staging-directory)
+          result)))))
+
+(define clone-to-store* (store-lift clone-to-store))
+
+(define (git-reference->name git-reference)
+  (let ((repository-name (basename (git-reference-url git-reference) ".git"))
+        (short-commit (string-take (git-reference-commit git-reference) 9)))
+    (string-append repository-name "-" short-commit "-checkout")))
+
+(define* (git-fetch/impure ref hash-algo hash
+                        #:optional name
+                        #:key
+                        (system (%current-system))
+                        (guile (default-guile)))
+  "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.
+
+This procedure is the same as git-fetch in spirit; however, it explicitly
+allows impurities from the environment in which it is invoked: the \"ssh\"
+client program currently available via the PATH environment variable, its SSH
+configuration file (usually found at ~/.ssh/config), and any SSH agent that is
+currently running (usually made available via environment variables such as
+SSH_AUTH_SOCK).  Such impurities may seem concerning at first blush; however,
+because a fixed-output derivation will fail unless its content hash is
+correct, a successful git-fetch/impure is guaranteed to produce the exact same
+output as a successful git-fetch for the same commit.
+
+This procedure is useful if for example you need to fetch a Git repository
+that is only available via an authenticated SSH connection."
+  ;; Do the Git fetch in the host environment so that it has access to the
+  ;; user's SSH agent, SSH config, and other tools.  This will only work if we
+  ;; are running in an environment with a properly installed and configured
+  ;; SSH.  It is impure because it happens outside of a derivation, but it
+  ;; allows us to fetch a Git repository that is only available over SSH.
+  (mlet* %store-monad
+      ((name -> (or name (git-reference->name ref)))
+       (guile (package->derivation guile system))
+       (git -> `("git" ,(git-package)))
+       ;; When doing 'git clone --recursive', we need sed, grep, etc. to be
+       ;; available so that 'git submodule' works.  We do not add an SSH
+       ;; client to the inputs here, since we explicltly want to use the SSH
+       ;; client, SSH agent, and SSH config from the user's environment.
+       (inputs -> `(,git ,@(if (git-reference-recursive? ref)
+                               (standard-packages)
+                               '())))
+       (input-packages -> (match inputs (((names packages outputs ...) ...)
+                                         packages)))
+       (input-derivations (sequence %store-monad
+                                    (map (cut package->derivation <> system)
+                                         input-packages)))
+       ;; The tools that clone-to-store requires (e.g., Git) must be built
+       ;; before we invoke clone-to-store.
+       (ignored (built-derivations input-derivations))
+       (input-paths -> (map derivation->output-path input-derivations))
+       (checkout (clone-to-store* name ref hash input-paths)))
+    (gexp->derivation
+     ;; To avoid fetching the repository when it's already been added to the
+     ;; store previously, the name used here must be the same as the name used
+     ;; when calling fixed-output-path in clone-to-store.
+     name
+     (with-imported-modules '((guix build utils))
+       #~(begin
+           (use-modules (guix build utils))
+           (copy-recursively #$checkout #$output)))
+     ;; Slashes are not allowed in file names.
+     #:script-name "git-download-ssh"
+     #:system system
+     ;; Fetching a Git repository is usually a network-bound operation, so
+     ;; offloading is unlikely to speed things up.
+     #:local-build? #t
+     #:hash-algo hash-algo
+     #:hash hash
+     ;; Even when the git fetch will not be done recursively, we want to
+     ;; recursively add to the store the results of the git fetch.
+     #:recursive? #t
+     #:guile-for-build guile)))
+
 (define (git-version version revision commit)
   "Return the version string for packages using git-download."
   (string-append version "-" revision "." (string-take commit 7)))
-- 
2.17.0