Toggle diff (227 lines)
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
