me
/
guix
Archived
1
0
Fork 0
Code

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
264fdbcaff.  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
master
Christopher Baines 2024-05-11 17:40:42 +01:00
parent 275f279891
commit 0daa72e34d
No known key found for this signature in database
GPG Key ID: 5E28A33B0B84F577
1 changed files with 64 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

111
guix/git-download.scm
View File

@ -48,6 +48,7 @@
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-34) #:use-module (srfi srfi-34)
#:use-module (srfi srfi-35) #:use-module (srfi srfi-35)
#:use-module (rnrs bytevectors)
#:export (git-reference #:export (git-reference
git-reference? git-reference?
git-reference-url git-reference-url
@ -86,20 +87,13 @@
(let ((distro (resolve-interface '(gnu packages version-control)))) (let ((distro (resolve-interface '(gnu packages version-control))))
(module-ref distro 'git-lfs))) (module-ref distro 'git-lfs)))
(define* (git-fetch/in-band* ref hash-algo hash (define (git-fetch-builder git git-lfs git-ref-recursive? hash-algo)
#: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 inputs (define inputs
`(,(or git (git-package)) `(,(or git (git-package))
,@(if git-lfs ,@(if git-lfs
(list git-lfs) (list git-lfs)
'()) '())
,@(if (git-reference-recursive? ref) ,@(if git-ref-recursive?
;; TODO: remove (standard-packages) after ;; TODO: remove (standard-packages) after
;; 48e528a26f9c019eeaccf5e3de3126aa02c98d3b is merged into master; ;; 48e528a26f9c019eeaccf5e3de3126aa02c98d3b is merged into master;
;; currently when doing 'git clone --recursive', we need sed, grep, ;; currently when doing 'git clone --recursive', we need sed, grep,
@ -132,59 +126,82 @@ respective documentation."
(source-module-closure '((guix build git) (source-module-closure '((guix build git)
(guix build utils))))) (guix build utils)))))
(define build (with-imported-modules modules
(with-imported-modules modules (with-extensions (list guile-json gnutls ;for (guix swh)
(with-extensions (list guile-json gnutls ;for (guix swh) guile-lzlib)
guile-lzlib) #~(begin
#~(begin (use-modules (guix build git)
(use-modules (guix build git) ((guix build utils)
((guix build utils) #:select (set-path-environment-variable))
#:select (set-path-environment-variable)) (ice-9 match)
(ice-9 match)) (rnrs bytevectors))
(define lfs? (define lfs?
(call-with-input-string (getenv "git lfs?") read)) (call-with-input-string (getenv "git lfs?") read))
(define recursive? (define recursive?
(call-with-input-string (getenv "git recursive?") read)) (call-with-input-string (getenv "git recursive?") read))
;; Let Guile interpret file names as UTF-8, otherwise ;; Let Guile interpret file names as UTF-8, otherwise
;; 'delete-file-recursively' might fail to delete all of ;; 'delete-file-recursively' might fail to delete all of
;; '.git'--see <https://issues.guix.gnu.org/54893>. ;; '.git'--see <https://issues.guix.gnu.org/54893>.
(setenv "GUIX_LOCPATH" (setenv "GUIX_LOCPATH"
#+(file-append glibc-locales "/lib/locale")) #+(file-append glibc-locales "/lib/locale"))
(setlocale LC_ALL "en_US.utf8") (setlocale LC_ALL "en_US.utf8")
;; The 'git submodule' commands expects Coreutils, sed, grep, ;; The 'git submodule' commands expects Coreutils, sed, grep,
;; etc. to be in $PATH. This also ensures that git extensions are ;; etc. to be in $PATH. This also ensures that git extensions are
;; found. ;; found.
(set-path-environment-variable "PATH" '("bin") '#+inputs) (set-path-environment-variable "PATH" '("bin") '#+inputs)
(setvbuf (current-output-port) 'line) (setvbuf (current-output-port) 'line)
(setvbuf (current-error-port) 'line) (setvbuf (current-error-port) 'line)
(git-fetch-with-fallback (getenv "git url") (getenv "git commit") (git-fetch-with-fallback (getenv "git url") (getenv "git commit")
#$output #$output
#:hash #$hash #:hash (u8-list->bytevector
#:hash-algorithm '#$hash-algo (map
#:lfs? lfs? string->number
#:recursive? recursive? (string-split (getenv "hash") #\,)))
#:git-command "git"))))) #: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)) (mlet %store-monad ((guile (package->derivation (or guile (default-guile))
system))) system)))
(gexp->derivation (or name "git-checkout") build (gexp->derivation (or name "git-checkout")
;; Avoid the builder differing for every single use as
;; Use environment variables and a fixed script name so ;; having less builder is more efficient for computing
;; there's only one script in store for all the ;; derivations.
;; downloads. ;;
;; 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" #:script-name "git-download"
#:env-vars #:env-vars
`(("git url" . ,(git-reference-url ref)) `(("git url" . ,(git-reference-url ref))
("git commit" . ,(git-reference-commit ref)) ("git commit" . ,(git-reference-commit ref))
("git recursive?" . ,(object->string ("git recursive?" . ,(object->string
(git-reference-recursive? ref))) (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" #:leaked-env-vars '("http_proxy" "https_proxy"
"LC_ALL" "LC_MESSAGES" "LANG" "LC_ALL" "LC_MESSAGES" "LANG"
"COLUMNS") "COLUMNS")