From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:4830:134:3::10]:40851) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1fByje-0001Br-CJ for guix-patches@gnu.org; Fri, 27 Apr 2018 04:28:08 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1fByjb-0008C7-2t for guix-patches@gnu.org; Fri, 27 Apr 2018 04:28:06 -0400 Received: from debbugs.gnu.org ([208.118.235.43]:33033) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1fByja-0008Bk-SR for guix-patches@gnu.org; Fri, 27 Apr 2018 04:28:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1fByja-00006k-EP for guix-patches@gnu.org; Fri, 27 Apr 2018 04:28:02 -0400 Subject: [bug#31285] [PATCH 1/1] guix: Add git-fetch/impure. Resent-Message-ID: From: Chris Marusich Date: Fri, 27 Apr 2018 01:26:42 -0700 Message-Id: <20180427082642.28760-1-cmmarusich@gmail.com> In-Reply-To: <20180427081520.28645-1-cmmarusich@gmail.com> References: <20180427081520.28645-1-cmmarusich@gmail.com> MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: 31285@debbugs.gnu.org Cc: Chris Marusich * 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 ;;; 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,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 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 +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