Package: guix-patches;
Reported by: Maxim Cournoyer <maxim.cournoyer <at> gmail.com>
Date: Thu, 12 Oct 2023 02:51:01 UTC
Severity: normal
Tags: patch
Done: Maxim Cournoyer <maxim.cournoyer <at> gmail.com>
Bug is archived. No further changes may be made.
View this message in rfc822 format
From: Maxim Cournoyer <maxim.cournoyer <at> gmail.com> To: 66475 <at> debbugs.gnu.org Cc: Maxim Cournoyer <maxim.cournoyer <at> gmail.com>, Maxim Cournoyer <maxim.cournoyer <at> gmail.com>, Christopher Baines <guix <at> cbaines.net>, Josselin Poiret <dev <at> jpoiret.xyz>, Ludovic Courtès <ludo <at> gnu.org>, Mathieu Othacehe <othacehe <at> gnu.org>, Ricardo Wurmus <rekado <at> elephly.net>, Simon Tournier <zimon.toutoune <at> gmail.com>, Tobias Geerinckx-Rice <me <at> tobias.gr> Subject: [bug#66475] [PATCH 2/2] git-download: Add support for Git Large File Storage (LFS). Date: Wed, 11 Oct 2023 23:02:04 -0400
* guix/git-download.scm (<git-reference>) [lfs?]: New field.
(git-fetch/in-band): New #:git-lfs argument.
<inputs>: Remove labels. Conditionally add git-lfs.
<build>: Read "git lfs?" environment
variable and pass its value to the #:lfs? argument of git-fetch-with-fallback.
Use INPUTS directly; update comment.
<gexp->derivation>: Add "git lfs?" to #:env-vars.
(git-fetch/built-in): Add "lfs?" to #:env-vars.
* guix/build/git.scm (git-fetch) [lfs?]: New argument, doc and setup code.
(git-fetch-with-fallback) [lfs?]: New argument. Pass it to git-fetch.
* guix/scripts/perform-download.scm (perform-git-download): Honor the 'lfs?'
environment variable.
* doc/guix.texi (origin Reference) <git-reference>: Document the new 'lfs?'
field.
(Requirements): Mention the optional 'git-lfs' dependency.
* configure.ac: Add a check for the 'git-lfs' command.
* guix/config.scm.in (%git-lfs): New variable.
* guix/self.scm (%packages): Add git-lfs.
(compiled-guix): Add git-lfs to guix-config.
(make-config.scm): New #:git-lfs argument.
Change-Id: I5b233b8642a7bdb8737b9d9b740e7254a89ccb25
---
configure.ac | 10 ++++++
doc/guix.texi | 9 +++++
guix/build/git.scm | 18 +++++++---
guix/config.scm.in | 4 +++
guix/git-download.scm | 58 ++++++++++++++++++++-----------
guix/scripts/perform-download.scm | 3 ++
guix/self.scm | 10 +++++-
7 files changed, 87 insertions(+), 25 deletions(-)
diff --git a/configure.ac b/configure.ac
index d817f620cf..5342c0f80e 100644
--- a/configure.ac
+++ b/configure.ac
@@ -208,6 +208,16 @@ if test "x$GIT" = "x"; then
fi
AC_SUBST([GIT])
+dnl Git Large File Storage is an optional dependency for the
+dnl "builtin:git-download" derivation builder.
+AC_PATH_PROG([GIT_LFS], [git-lfs])
+if test "x$GIT_LFS" = "x"; then
+ AC_MSG_WARN([Git Large File Storage (git-lfs) is missing;
+ The builtin:git-download derivation builder of the Guix daemon will
+ not be able to use it.])
+fi
+AC_SUBST([GIT_LFS])
+
LIBGCRYPT_LIBDIR="no"
LIBGCRYPT_PREFIX="no"
diff --git a/doc/guix.texi b/doc/guix.texi
index dc16ec1d15..89faaa7b90 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -1020,6 +1020,11 @@ Requirements
The following dependencies are optional:
@itemize
+@item
+The daemon will be able to fetch from Git repositories using the
+@uref{https://git-lfs.com/, Git Large File Storage} extension when the
+@command{git-lfs} command is available.
+
@item
@c Note: We need at least 0.13.0 for #:nodelay.
Support for build offloading (@pxref{Daemon Offload Setup}) and
@@ -8499,6 +8504,10 @@ origin Reference
@command{git describe} style identifier such as
@code{v1.0.1-10-g58d7909c97}.
+@item @code{lfs?} (default: @code{#f})
+This Boolean indicates whether to fetch Git large file storage (LFS)
+files.
+
@item @code{recursive?} (default: @code{#f})
This Boolean indicates whether to recursively fetch Git sub-modules.
@end table
diff --git a/guix/build/git.scm b/guix/build/git.scm
index 0ff263c81b..82c31fabf1 100644
--- a/guix/build/git.scm
+++ b/guix/build/git.scm
@@ -33,10 +33,13 @@ (define-module (guix build git)
;;; Code:
(define* (git-fetch url commit directory
- #:key (git-command "git") recursive?)
+ #:key (git-command "git")
+ lfs? recursive?)
"Fetch COMMIT from URL into DIRECTORY. COMMIT must be a valid Git commit
-identifier. When RECURSIVE? is true, all the sub-modules of URL are fetched,
-recursively. Return #t on success, #f otherwise."
+identifier. When LFS? is true, configure Git to also fetch Large File
+Storage (LFS) files; it assumes that the @code{git-lfs} extension is available
+in the environment. When RECURSIVE? is true, all the sub-modules of URL are
+fetched, recursively. Return #t on success, #f otherwise."
;; Disable TLS certificate verification. The hash of the checkout is known
;; in advance anyway.
@@ -57,6 +60,11 @@ (define* (git-fetch url commit directory
(with-directory-excursion directory
(invoke git-command "init" "--initial-branch=main")
(invoke git-command "remote" "add" "origin" url)
+
+ (when lfs?
+ (setenv "HOME" "/tmp")
+ (invoke git-command "lfs" "install"))
+
(if (zero? (system* git-command "fetch" "--depth" "1" "origin" commit))
(invoke git-command "checkout" "FETCH_HEAD")
(begin
@@ -81,11 +89,13 @@ (define* (git-fetch url commit directory
(define* (git-fetch-with-fallback url commit directory
- #:key (git-command "git") recursive?)
+ #:key (git-command "git")
+ lfs? recursive?)
"Like 'git-fetch', fetch COMMIT from URL into DIRECTORY, but fall back to
alternative methods when fetching from URL fails: attempt to download a nar,
and if that also fails, download from the Software Heritage archive."
(or (git-fetch url commit directory
+ #:lfs? lfs?
#:recursive? recursive?
#:git-command git-command)
(download-nar directory)
diff --git a/guix/config.scm.in b/guix/config.scm.in
index 62e15dd713..4997a1740e 100644
--- a/guix/config.scm.in
+++ b/guix/config.scm.in
@@ -36,6 +36,7 @@ (define-module (guix config)
%system
%git
+ %git-lfs
%gzip
%bzip2
%xz))
@@ -113,6 +114,9 @@ (define %system
(define %git
"@GIT@")
+(define %git-lfs
+ "@GIT_LFS@")
+
(define %gzip
"@GZIP@")
diff --git a/guix/git-download.scm b/guix/git-download.scm
index 5d5d73dc6b..6feeea6428 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -51,6 +51,7 @@ (define-module (guix git-download)
git-reference?
git-reference-url
git-reference-commit
+ git-reference-lfs?
git-reference-recursive?
git-fetch
@@ -71,7 +72,9 @@ (define-record-type* <git-reference>
git-reference?
(url git-reference-url)
(commit git-reference-commit)
- (recursive? git-reference-recursive? ; whether to recurse into sub-modules
+ (lfs? git-reference-lfs? ;whether to fetch LFS files
+ (default #f))
+ (recursive? git-reference-recursive? ;whether to recurse into sub-modules
(default #f)))
(define (git-package)
@@ -79,11 +82,17 @@ (define (git-package)
(let ((distro (resolve-interface '(gnu packages version-control))))
(module-ref distro 'git-minimal)))
+(define (git-lfs-package)
+ "Return the default 'git-lfs' package."
+ (let ((distro (resolve-interface '(gnu packages version-control))))
+ (module-ref distro 'git-lfs)))
+
(define* (git-fetch/in-band ref hash-algo hash
#:optional name
#:key (system (%current-system))
(guile (default-guile))
- (git (git-package)))
+ (git (git-package))
+ (git-lfs (git-lfs-package)))
"Return a fixed-output derivation that performs a Git checkout of REF, using
GIT and GUILE (thus, said derivation depends on GIT and GUILE).
@@ -91,18 +100,22 @@ (define* (git-fetch/in-band ref hash-algo hash
It will be removed when versions of guix-daemon implementing
\"builtin:git-download\" will be sufficiently widespread."
(define inputs
- `(("git" ,(or git (git-package)))
-
- ;; When doing 'git clone --recursive', we need sed, grep, etc. to be
- ;; available so that 'git submodule' works.
+ `(,(or git (git-package))
+ ,@(if (git-reference-lfs? ref)
+ (list (or git-lfs (git-lfs-package)))
+ '())
,@(if (git-reference-recursive? ref)
- (standard-packages)
+ ;; TODO: remove (standard-packages) after
+ ;; 48e528a26f9c019eeaccf5e3de3126aa02c98d3b is merged into master;
+ ;; currently when doing 'git clone --recursive', we need sed, grep,
+ ;; etc. to be available so that 'git submodule' works.
+ (map second (standard-packages))
;; The 'swh-download' procedure requires tar and gzip.
- `(("gzip" ,(module-ref (resolve-interface '(gnu packages compression))
- 'gzip))
- ("tar" ,(module-ref (resolve-interface '(gnu packages base))
- 'tar))))))
+ (list (module-ref (resolve-interface '(gnu packages compression))
+ 'gzip)
+ (module-ref (resolve-interface '(gnu packages base))
+ 'tar)))))
(define guile-json
(module-ref (resolve-interface '(gnu packages guile)) 'guile-json-4))
@@ -126,7 +139,7 @@ (define* (git-fetch/in-band ref hash-algo hash
(define build
(with-imported-modules modules
- (with-extensions (list guile-json gnutls ;for (guix swh)
+ (with-extensions (list guile-json gnutls ;for (guix swh)
guile-lzlib)
#~(begin
(use-modules (guix build git)
@@ -134,6 +147,9 @@ (define* (git-fetch/in-band ref hash-algo hash
#:select (set-path-environment-variable))
(ice-9 match))
+ (define lfs?
+ (call-with-input-string (getenv "git lfs?") read))
+
(define recursive?
(call-with-input-string (getenv "git recursive?") read))
@@ -144,18 +160,17 @@ (define* (git-fetch/in-band ref hash-algo hash
#+(file-append glibc-locales "/lib/locale"))
(setlocale LC_ALL "en_US.utf8")
- ;; The 'git submodule' commands expects Coreutils, sed,
- ;; grep, etc. to be in $PATH.
- (set-path-environment-variable "PATH" '("bin")
- (match '#+inputs
- (((names dirs outputs ...) ...)
- dirs)))
+ ;; The 'git submodule' commands expects Coreutils, sed, grep,
+ ;; etc. to be in $PATH. This also ensures that git extensions are
+ ;; found.
+ (set-path-environment-variable "PATH" '("bin") '#+inputs)
(setvbuf (current-output-port) 'line)
(setvbuf (current-error-port) 'line)
(git-fetch-with-fallback (getenv "git url") (getenv "git commit")
#$output
+ #:lfs? lfs?
#:recursive? recursive?
#:git-command "git")))))
@@ -175,13 +190,15 @@ (define* (git-fetch/in-band ref hash-algo hash
(git-reference-url ref))))
("git commit" . ,(git-reference-commit ref))
("git recursive?" . ,(object->string
- (git-reference-recursive? ref))))
+ (git-reference-recursive? ref)))
+ ("git lfs?" . ,(object->string
+ (git-reference-lfs? ref))))
#:leaked-env-vars '("http_proxy" "https_proxy"
"LC_ALL" "LC_MESSAGES" "LANG"
"COLUMNS")
#:system system
- #:local-build? #t ;don't offload repo cloning
+ #:local-build? #t ;don't offload repo cloning
#:hash-algo hash-algo
#:hash hash
#:recursive? #t
@@ -209,6 +226,7 @@ (define* (git-fetch/built-in ref hash-algo hash
(_
(git-reference-url ref)))))
("commit" . ,(git-reference-commit ref))
+ ("lfs?" . ,(object->string (git-reference-lfs? ref)))
("recursive?" . ,(object->string
(git-reference-recursive? ref))))
#:leaked-env-vars '("http_proxy" "https_proxy"
diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm
index 9aa0e61e9d..37904941d1 100644
--- a/guix/scripts/perform-download.scm
+++ b/guix/scripts/perform-download.scm
@@ -96,6 +96,7 @@ (define* (perform-git-download drv output
'bmRepair' builds."
(derivation-let drv ((url "url")
(commit "commit")
+ (lfs? "lfs?")
(recursive? "recursive?"))
(unless url
(leave (G_ "~a: missing Git URL~%") (derivation-file-name drv)))
@@ -103,6 +104,7 @@ (define* (perform-git-download drv output
(leave (G_ "~a: missing Git commit~%") (derivation-file-name drv)))
(let* ((url (call-with-input-string url read))
+ (lfs? (and lfs? (call-with-input-string lfs? read)))
(recursive? (and recursive?
(call-with-input-string recursive? read)))
(drv-output (assoc-ref (derivation-outputs drv) "out"))
@@ -115,6 +117,7 @@ (define* (perform-git-download drv output
(setenv "PATH" "/run/current-system/profile/bin:/bin:/usr/bin")
(git-fetch-with-fallback url commit output
+ #:lfs? lfs?
#:recursive? recursive?
#:git-command %git))))
diff --git a/guix/self.scm b/guix/self.scm
index a1f235659d..96021be6f6 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -69,6 +69,7 @@ (define %packages
("gzip" . ,(ref 'compression 'gzip))
("bzip2" . ,(ref 'compression 'bzip2))
("xz" . ,(ref 'compression 'xz))
+ ("git-lfs" . ,(ref 'version-control 'git-lfs))
("git-minimal" . ,(ref 'version-control 'git-minimal))
("po4a" . ,(ref 'gettext 'po4a))
("gettext-minimal" . ,(ref 'gettext 'gettext-minimal))
@@ -830,6 +831,9 @@ (define* (compiled-guix source #:key
(define git
(specification->package "git-minimal"))
+ (define git-lfs
+ (specification->package "git-lfs"))
+
(define dependencies
(append-map transitive-package-dependencies
(list guile-gcrypt guile-gnutls guile-git guile-avahi
@@ -1004,6 +1008,7 @@ (define* (compiled-guix source #:key
#:bzip2 bzip2
#:xz xz
#:git git
+ #:git-lfs git-lfs
#:package-name
%guix-package-name
#:package-version
@@ -1109,7 +1114,7 @@ (define %default-config-variables
(%storedir . "/gnu/store")
(%sysconfdir . "/etc")))
-(define* (make-config.scm #:key gzip xz bzip2 git
+(define* (make-config.scm #:key gzip xz bzip2 git git-lfs
(package-name "GNU Guix")
(package-version "0")
(channel-metadata #f)
@@ -1140,6 +1145,7 @@ (define* (make-config.scm #:key gzip xz bzip2 git
%store-database-directory
%config-directory
%git
+ %git-lfs
%gzip
%bzip2
%xz))
@@ -1184,6 +1190,8 @@ (define* (make-config.scm #:key gzip xz bzip2 git
(define %git
#+(and git (file-append git "/bin/git")))
+ (define %git-lfs
+ #+(and git-lfs (file-append git-lfs "/bin/git-lfs")))
(define %gzip
#+(and gzip (file-append gzip "/bin/gzip")))
(define %bzip2
--
2.41.0
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.