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