| Message ID | b25aa2dd644ac85ed72dabf3cb2098fd8c6358d0.1694441831.git.ludo@gnu.org |
|---|---|
| State | New |
| Headers | show |
| Series | Add built-in builder for Git checkouts | expand |
Hi Ludovic, Ludovic Courtès <ludo@gnu.org> writes: > * guix/build/git.scm (git-fetch-with-fallback): New procedure, with code > taken from… > * guix/git-download.scm (git-fetch): … here. > [modules]: Remove modules that are no longer directly used in ‘build’. > [build]: Use ‘git-fetch-with-fallback’. [...] > + > +(define* (git-fetch-with-fallback url commit directory > + #:key (git-command "git") 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 > + #:recursive? recursive? > + #:git-command git-command) > + (download-nar directory) > + > + ;; As a last resort, attempt to download from Software Heritage. > + ;; Disable X.509 certificate verification to avoid depending > + ;; on nss-certs--we're authenticating the checkout anyway. > + ;; XXX: Currently recursive checkouts are not supported. > + (and (not recursive?) I know this is code moved from elsewhere, but it seems it'd be useful to fail hard here with a proper error instead of returning #f silently? Or add support for recursive clones; was is missing to enable that? It's at least easy from the git CLI. > + (parameterize ((%verify-swh-certificate? #f)) > + (format (current-error-port) > + "Trying to download from Software Heritage...~%") > + > + (swh-download url commit directory) > + (when (file-exists? > + (string-append directory "/.gitattributes")) > + ;; Perform CR/LF conversion and other changes > + ;; specificied by '.gitattributes'. > + (invoke git-command "-C" directory "init") > + (invoke git-command "-C" directory "config" "--local" > + "user.email" "you@example.org") > + (invoke git-command "-C" directory "config" "--local" > + "user.name" "Your Name") > + (invoke git-command "-C" directory "add" ".") > + (invoke git-command "-C" directory "commit" "-am" "init") > + (invoke git-command "-C" directory "read-tree" "--empty") > + (invoke git-command "-C" directory "reset" "--hard") > + (delete-file-recursively > + (string-append directory "/.git"))))))) I'm not familiar with this code, but was wondering why we need to do this post processing and handle .gitattributes. I never care about this on my GNU/Linux machine when using 'git clone'. Perhaps 'git fetch' is used directly, which is why? Time passes... Ah! I misread -- that's peculiar to Software Heritage. > ;;; git.scm ends here > diff --git a/guix/git-download.scm b/guix/git-download.scm > index d88f4c40ee..8989b1b463 100644 > --- a/guix/git-download.scm > +++ b/guix/git-download.scm > @@ -116,19 +116,16 @@ (define* (git-fetch ref hash-algo hash > (define modules > (delete '(guix config) > (source-module-closure '((guix build git) > - (guix build utils) > - (guix build download-nar) > - (guix swh))))) > + (guix build utils))))) > > (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) > - (guix build utils) > - (guix build download-nar) > - (guix swh) > + ((guix build utils) > + #:select (set-path-environment-variable)) > (ice-9 match)) > > (define recursive? > @@ -151,38 +148,10 @@ (define* (git-fetch ref hash-algo hash > (setvbuf (current-output-port) 'line) > (setvbuf (current-error-port) 'line) > > - (or (git-fetch (getenv "git url") (getenv "git commit") > - #$output > - #:recursive? recursive? > - #:git-command "git") > - (download-nar #$output) > - > - ;; As a last resort, attempt to download from Software Heritage. > - ;; Disable X.509 certificate verification to avoid depending > - ;; on nss-certs--we're authenticating the checkout anyway. > - ;; XXX: Currently recursive checkouts are not supported. > - (and (not recursive?) > - (parameterize ((%verify-swh-certificate? #f)) > - (format (current-error-port) > - "Trying to download from Software Heritage...~%") > - > - (swh-download (getenv "git url") (getenv "git commit") > - #$output) > - (when (file-exists? > - (string-append #$output "/.gitattributes")) > - ;; Perform CR/LF conversion and other changes > - ;; specificied by '.gitattributes'. > - (invoke "git" "-C" #$output "init") > - (invoke "git" "-C" #$output "config" "--local" > - "user.email" "you@example.org") > - (invoke "git" "-C" #$output "config" "--local" > - "user.name" "Your Name") > - (invoke "git" "-C" #$output "add" ".") > - (invoke "git" "-C" #$output "commit" "-am" "init") > - (invoke "git" "-C" #$output "read-tree" "--empty") > - (invoke "git" "-C" #$output "reset" "--hard") > - (delete-file-recursively > - (string-append #$output "/.git")))))))))) > + (git-fetch-with-fallback (getenv "git url") (getenv "git commit") > + #$output > + #:recursive? recursive? > + #:git-command "git"))))) > > (mlet %store-monad ((guile (package->derivation guile system))) > (gexp->derivation (or name "git-checkout") build LGTM.
Hi Maxim, On Wed, 20 Sept 2023 at 18:05, Maxim Cournoyer <maxim.cournoyer@gmail.com> wrote: > > + (parameterize ((%verify-swh-certificate? #f)) > > + (format (current-error-port) > > + "Trying to download from Software Heritage...~%") > > + > > + (swh-download url commit directory) > > + (when (file-exists? > > + (string-append directory "/.gitattributes")) > > + ;; Perform CR/LF conversion and other changes > > + ;; specificied by '.gitattributes'. > > + (invoke git-command "-C" directory "init") > > + (invoke git-command "-C" directory "config" "--local" > > + "user.email" "you@example.org") > > + (invoke git-command "-C" directory "config" "--local" > > + "user.name" "Your Name") > > + (invoke git-command "-C" directory "add" ".") > > + (invoke git-command "-C" directory "commit" "-am" "init") > > + (invoke git-command "-C" directory "read-tree" "--empty") > > + (invoke git-command "-C" directory "reset" "--hard") > > + (delete-file-recursively > > + (string-append directory "/.git"))))))) > > I'm not familiar with this code, but was wondering why we need to do > this post processing and handle .gitattributes. I never care about this > on my GNU/Linux machine when using 'git clone'. Perhaps 'git fetch' is > used directly, which is why? > > Time passes... Ah! I misread -- that's peculiar to Software Heritage. We need to post-process .gitattributes because it depends on how the remote host serves the files. And yeah it mainly comes from SWH. :-) They store the files with an uniform normalization and so without applying .gitattributes, we do not necessary get the correct checksum. To my knowledge, we cannot do better than these sequential Git commands. Cheers, simon
Hi, Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis: >> +(define* (git-fetch-with-fallback url commit directory >> + #:key (git-command "git") 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 >> + #:recursive? recursive? >> + #:git-command git-command) >> + (download-nar directory) >> + >> + ;; As a last resort, attempt to download from Software Heritage. >> + ;; Disable X.509 certificate verification to avoid depending >> + ;; on nss-certs--we're authenticating the checkout anyway. >> + ;; XXX: Currently recursive checkouts are not supported. >> + (and (not recursive?) > > I know this is code moved from elsewhere, but it seems it'd be useful to > fail hard here with a proper error instead of returning #f silently? Or > add support for recursive clones; was is missing to enable that? Note that this is for the SWH fallback. The SWH Vault doesn’t quite support submodules; apparently there’s some work in that direction¹ but it’s not there yet (though perhaps we could still implement it using additional API endpoints, I’m not sure). Ludo’. ¹ https://gitlab.softwareheritage.org/swh/devel/swh-vault/-/issues/4349
diff --git a/guix/build/git.scm b/guix/build/git.scm index deda10fee8..0ff263c81b 100644 --- a/guix/build/git.scm +++ b/guix/build/git.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2016, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2016, 2019, 2023 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,9 +18,12 @@ (define-module (guix build git) #:use-module (guix build utils) + #:autoload (guix build download-nar) (download-nar) + #:autoload (guix swh) (%verify-swh-certificate? swh-download) #:use-module (srfi srfi-34) #:use-module (ice-9 format) - #:export (git-fetch)) + #:export (git-fetch + git-fetch-with-fallback)) ;;; Commentary: ;;; @@ -76,4 +79,41 @@ (define* (git-fetch url commit directory (delete-file-recursively ".git") #t))) + +(define* (git-fetch-with-fallback url commit directory + #:key (git-command "git") 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 + #:recursive? recursive? + #:git-command git-command) + (download-nar directory) + + ;; As a last resort, attempt to download from Software Heritage. + ;; Disable X.509 certificate verification to avoid depending + ;; on nss-certs--we're authenticating the checkout anyway. + ;; XXX: Currently recursive checkouts are not supported. + (and (not recursive?) + (parameterize ((%verify-swh-certificate? #f)) + (format (current-error-port) + "Trying to download from Software Heritage...~%") + + (swh-download url commit directory) + (when (file-exists? + (string-append directory "/.gitattributes")) + ;; Perform CR/LF conversion and other changes + ;; specificied by '.gitattributes'. + (invoke git-command "-C" directory "init") + (invoke git-command "-C" directory "config" "--local" + "user.email" "you@example.org") + (invoke git-command "-C" directory "config" "--local" + "user.name" "Your Name") + (invoke git-command "-C" directory "add" ".") + (invoke git-command "-C" directory "commit" "-am" "init") + (invoke git-command "-C" directory "read-tree" "--empty") + (invoke git-command "-C" directory "reset" "--hard") + (delete-file-recursively + (string-append directory "/.git"))))))) + ;;; git.scm ends here diff --git a/guix/git-download.scm b/guix/git-download.scm index d88f4c40ee..8989b1b463 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -116,19 +116,16 @@ (define* (git-fetch ref hash-algo hash (define modules (delete '(guix config) (source-module-closure '((guix build git) - (guix build utils) - (guix build download-nar) - (guix swh))))) + (guix build utils))))) (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) - (guix build utils) - (guix build download-nar) - (guix swh) + ((guix build utils) + #:select (set-path-environment-variable)) (ice-9 match)) (define recursive? @@ -151,38 +148,10 @@ (define* (git-fetch ref hash-algo hash (setvbuf (current-output-port) 'line) (setvbuf (current-error-port) 'line) - (or (git-fetch (getenv "git url") (getenv "git commit") - #$output - #:recursive? recursive? - #:git-command "git") - (download-nar #$output) - - ;; As a last resort, attempt to download from Software Heritage. - ;; Disable X.509 certificate verification to avoid depending - ;; on nss-certs--we're authenticating the checkout anyway. - ;; XXX: Currently recursive checkouts are not supported. - (and (not recursive?) - (parameterize ((%verify-swh-certificate? #f)) - (format (current-error-port) - "Trying to download from Software Heritage...~%") - - (swh-download (getenv "git url") (getenv "git commit") - #$output) - (when (file-exists? - (string-append #$output "/.gitattributes")) - ;; Perform CR/LF conversion and other changes - ;; specificied by '.gitattributes'. - (invoke "git" "-C" #$output "init") - (invoke "git" "-C" #$output "config" "--local" - "user.email" "you@example.org") - (invoke "git" "-C" #$output "config" "--local" - "user.name" "Your Name") - (invoke "git" "-C" #$output "add" ".") - (invoke "git" "-C" #$output "commit" "-am" "init") - (invoke "git" "-C" #$output "read-tree" "--empty") - (invoke "git" "-C" #$output "reset" "--hard") - (delete-file-recursively - (string-append #$output "/.git")))))))))) + (git-fetch-with-fallback (getenv "git url") (getenv "git commit") + #$output + #:recursive? recursive? + #:git-command "git"))))) (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "git-checkout") build