From 650fb09fc25f78cea23f4db6504a40fd6cb9a10b Mon Sep 17 00:00:00 2001
From: Chris Marusich
Date: Fri, 27 Apr 2018 00:42:45 -0700
Subject: [PATCH] guix: Add git-fetch/impure.
* 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 | 25 +++++++
guix/git-download.scm | 166 ++++++++++++++++++++++++++++++++++++++++++
2 files changed, 191 insertions(+)
diff --git a/doc/guix.texi b/doc/guix.texi
index 75886e94b..68b20e84d 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -3553,6 +3553,31 @@ 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
+
address@hidden git-fetch/impure
address@hidden @var{git-fetch/impure} from @code{(guix git-download)}
+This procedure yields the same result as @code{git-fetch}; however, it
+explicitly allows impurities from the environment in which it is
+invoked: the @code{ssh} client program currently available via the
address@hidden 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
address@hidden).
+
+The @code{git-fetch/impure} fetch method should not be used in package
+origins in the official Guix distribution. Due to its impurity, if two
+people have configured SSH differently, it is possible that the origin
+will work for one person but not for the other. This fetch method is
+intended as a convenience for cases where, due to the circumstances of
+your situation, the Git repository is only available over an
+authenticated SSH connection. In this case, an example
address@hidden might look like this:
+
address@hidden
+(git-reference
+ (url "ssh://username@@git.sv.gnu.org:/srv/git/guix.git")
+ (commit "486de7377f25438b0f44fd93f97e9ef822d558b8"))
address@hidden example
@end table
@item @code{sha256}
diff --git a/guix/git-download.scm b/guix/git-download.scm
index 33f102bc6..68947cf9b 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -2,6 +2,7 @@
;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès
;;; Copyright © 2017 Mathieu Lirzin
;;; Copyright © 2017 Christopher Baines
+;;; Copyright © 2018 Chris Marusich
;;;
;;; 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,165 @@ 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, add it to the store, and return its store path.
+STORE is an open connection to the store. NAME will be used as the file name.
+GIT-REFERENCE is a 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)
+ ;; Git prints some messages to stdout, which is a minor blemish because it
+ ;; interferes with convenient shell idioms like "ls $(guix build
+ ;; my-package)". However, if we try to redirect stdout to stderr using
+ ;; with-output-to-port, and if Git fails because SSH is not available,
+ ;; then mysteriously Git's helpful error messages do not get printed. It
+ ;; seems better to surface useful error messages here than to hide them.
+ (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 ensure the derivation produced by git-fetch/impure does not need to be
+ ;; run, the name passed to fixed-output-path must be the same as the name
+ ;; used when calling gexp->derivation in git-fetch/impure.
+ (let* ((output (fixed-output-path name hash))
+ (already-fetched? (false-if-exception (valid-path? store output)))
+ (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)
+ (if already-fetched?
+ output
+ (begin
+ ;; 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.
+ (with-output-to-port (%make-void-port "w")
+ (lambda ()
+ (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
+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 yields the same result as git-fetch; 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).
+
+This procedure should not be used in package origins in the official Guix
+distribution. Due to its impurity, if two people have configured SSH
+differently, it is possible that the origin will work for one person but not
+for the other. This fetch method is intended as a convenience for cases
+where, due to the circumstances of your situation, the Git repository is only
+available over an authenticated SSH connection."
+ (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 explicitly want to use the SSH
+ ;; client, SSH agent, and SSH config from the current 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)))
+ ;; To ensure that commands like "guix build --source my-package" don't
+ ;; fail, return (as a monadic value) a derivation here. We could just
+ ;; tail-call clone-to-store* instead of going through the effort of
+ ;; returning a derivation here, but then the aforementioned command would
+ ;; fail for the same reason that it fails when the origin is defined with
+ ;; "local-file". This is the ONLY reason why we call gexp->derivation
+ ;; here. In fact, this derivation will never actually be run, since we
+ ;; always fetch its contents via clone-to-store* first.
+ (gexp->derivation
+ ;; To ensure this derivation does not need to be run, the name used here
+ ;; must be the same as the name used when calling fixed-output-path in
+ ;; clone-to-store.
+ name
+ ;; This builder never runs, so the actual builder code doesn't matter.
+ ;; However, we must ungexp the output variable, or the derivation will
+ ;; produce no output path.
+ #~(ungexp output)
+ ;; Slashes are not allowed in file names.
+ #:script-name "git-download-impure"
+ #: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