From 0daa72e34d7fafc927e2d476ef613c582107781d Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sat, 11 May 2024 17:40:42 +0100 Subject: [PATCH] git-download: Reduce builder duplication. Rather than creating a different builder in the store for every different download (by hash), remove the hash from the builder and pass it in via an environment variable. This means that when git-fetch is used by two different package sources, the derivations will still differ but the builder will be shared. It used to be this way, but changed with 264fdbcaff9c078642355bace0c61c094b3581fc. I noticed this through looking at the same problem with svn-multi-fetch. To try and make the effects of introducing variance in to the builder script more obvious, separate it out in to it's own procedure, so that it's clearer when there's new data going in that could cause variance. * guix/git-download.scm (git-fetch/in-band*): Extract out builder script, include hash in the derivation as an environment variable and update the comment to be more directive. (git-fetch-builder): New procedure. Change-Id: I59c9fc445667c0e7dc44bcb706818300c394a1e5 --- guix/git-download.scm | 111 ++++++++++++++++++++++++------------------ 1 file changed, 64 insertions(+), 47 deletions(-) diff --git a/guix/git-download.scm b/guix/git-download.scm index d26a814e07..ce40701563 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -48,6 +48,7 @@ (define-module (guix git-download) #:use-module (srfi srfi-1) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (rnrs bytevectors) #:export (git-reference git-reference? git-reference-url @@ -86,20 +87,13 @@ (define (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-lfs) - "Shared implementation code for git-fetch/in-band & friends. Refer to their -respective documentation." +(define (git-fetch-builder git git-lfs git-ref-recursive? hash-algo) (define inputs `(,(or git (git-package)) ,@(if git-lfs (list git-lfs) '()) - ,@(if (git-reference-recursive? ref) + ,@(if git-ref-recursive? ;; TODO: remove (standard-packages) after ;; 48e528a26f9c019eeaccf5e3de3126aa02c98d3b is merged into master; ;; currently when doing 'git clone --recursive', we need sed, grep, @@ -132,59 +126,82 @@ (define modules (source-module-closure '((guix build git) (guix build utils))))) - (define build - (with-imported-modules modules - (with-extensions (list guile-json gnutls ;for (guix swh) - guile-lzlib) - #~(begin - (use-modules (guix build git) - ((guix build utils) - #:select (set-path-environment-variable)) - (ice-9 match)) + (with-imported-modules modules + (with-extensions (list guile-json gnutls ;for (guix swh) + guile-lzlib) + #~(begin + (use-modules (guix build git) + ((guix build utils) + #:select (set-path-environment-variable)) + (ice-9 match) + (rnrs bytevectors)) - (define lfs? - (call-with-input-string (getenv "git lfs?") read)) + (define lfs? + (call-with-input-string (getenv "git lfs?") read)) - (define recursive? - (call-with-input-string (getenv "git recursive?") read)) + (define recursive? + (call-with-input-string (getenv "git recursive?") read)) - ;; Let Guile interpret file names as UTF-8, otherwise - ;; 'delete-file-recursively' might fail to delete all of - ;; '.git'--see . - (setenv "GUIX_LOCPATH" - #+(file-append glibc-locales "/lib/locale")) - (setlocale LC_ALL "en_US.utf8") + ;; Let Guile interpret file names as UTF-8, otherwise + ;; 'delete-file-recursively' might fail to delete all of + ;; '.git'--see . + (setenv "GUIX_LOCPATH" + #+(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. This also ensures that git extensions are - ;; found. - (set-path-environment-variable "PATH" '("bin") '#+inputs) + ;; 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) + (setvbuf (current-output-port) 'line) + (setvbuf (current-error-port) 'line) - (git-fetch-with-fallback (getenv "git url") (getenv "git commit") - #$output - #:hash #$hash - #:hash-algorithm '#$hash-algo - #:lfs? lfs? - #:recursive? recursive? - #:git-command "git"))))) + (git-fetch-with-fallback (getenv "git url") (getenv "git commit") + #$output + #:hash (u8-list->bytevector + (map + string->number + (string-split (getenv "hash") #\,))) + #:hash-algorithm '#$hash-algo + #:lfs? lfs? + #:recursive? recursive? + #:git-command "git"))))) +(define* (git-fetch/in-band* ref hash-algo hash + #:optional name + #:key (system (%current-system)) + (guile (default-guile)) + (git (git-package)) + git-lfs) + "Shared implementation code for git-fetch/in-band & friends. Refer to their +respective documentation." (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) system))) - (gexp->derivation (or name "git-checkout") build - - ;; Use environment variables and a fixed script name so - ;; there's only one script in store for all the - ;; downloads. + (gexp->derivation (or name "git-checkout") + ;; Avoid the builder differing for every single use as + ;; having less builder is more efficient for computing + ;; derivations. + ;; + ;; Don't pass package specific data in to the following + ;; procedure, use #:env-vars below instead. + (git-fetch-builder git git-lfs + (git-reference-recursive? ref) + hash-algo) #:script-name "git-download" #:env-vars `(("git url" . ,(git-reference-url ref)) ("git commit" . ,(git-reference-commit ref)) ("git recursive?" . ,(object->string (git-reference-recursive? ref))) - ("git lfs?" . ,(if git-lfs "#t" "#f"))) + ("git lfs?" . ,(if git-lfs "#t" "#f")) + ;; To avoid pulling in (guix base32) in the builder + ;; script, use bytevector->u8-list from (rnrs + ;; bytevectors) + ("hash" . ,(string-join + (map number->string + (bytevector->u8-list hash)) + ","))) #:leaked-env-vars '("http_proxy" "https_proxy" "LC_ALL" "LC_MESSAGES" "LANG" "COLUMNS")