[bug#66475] [PATCH 2/2] git-download: Add support for Git Large File Storage (LFS).

[Maxim Cournoyer <maxim.cournoyer@gmail.com>]

* 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