mirror/guix
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/guix.git synced 2025-02-07 19:39:34 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

git-download: Download from Software Heritage as a last resort.

Browse source 
* guix/git-download.scm (git-fetch)[inputs]: Add gzip and tar when
'git-reference-recursive?' is false.
[guile-json, gnutls]: New variables.
[modules]: Add (guix swh).
[build]: Wrap in 'with-extensions'.  Add call to 'swh-download'.
This commit is contained in:
Ludovic Courtès 2018-11-19 15:46:50 +01:00 • committed by Ludovic Courtès
parent de2bfe9029
commit 608d3dca89
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 44 additions and 20 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

36
guix/git-download.scm
View file

@ -74,11 +74,22 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
;; available so that 'git submodule' works. ;; available so that 'git submodule' works.
(if (git-reference-recursive? ref) (if (git-reference-recursive? ref)
(standard-packages) (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)))))
(define zlib (define zlib
(module-ref (resolve-interface '(gnu packages compression)) 'zlib)) (module-ref (resolve-interface '(gnu packages compression)) 'zlib))
(define guile-json
(module-ref (resolve-interface '(gnu packages guile)) 'guile-json))
(define gnutls
(module-ref (resolve-interface '(gnu packages tls)) 'gnutls))
(define config.scm (define config.scm
(scheme-file "config.scm" (scheme-file "config.scm"
#~(begin #~(begin
@ -93,16 +104,22 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
(delete '(guix config) (delete '(guix config)
(source-module-closure '((guix build git) (source-module-closure '((guix build git)
(guix build utils) (guix build utils)
(guix build download-nar)))))) (guix build download-nar)
(guix swh))))))
(define build (define build
(with-imported-modules modules (with-imported-modules modules
(with-extensions (list guile-json gnutls) ;for (guix swh)
#~(begin #~(begin
(use-modules (guix build git) (use-modules (guix build git)
(guix build utils) (guix build utils)
(guix build download-nar) (guix build download-nar)
(guix swh)
(ice-9 match)) (ice-9 match))
(define recursive?
(call-with-input-string (getenv "git recursive?") read))
;; The 'git submodule' commands expects Coreutils, sed, ;; The 'git submodule' commands expects Coreutils, sed,
;; grep, etc. to be in $PATH. ;; grep, etc. to be in $PATH.
(set-path-environment-variable "PATH" '("bin") (set-path-environment-variable "PATH" '("bin")
@ -110,13 +127,20 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
(((names dirs outputs ...) ...) (((names dirs outputs ...) ...)
dirs))) dirs)))
(setvbuf (current-output-port) 'line)
(setvbuf (current-error-port) 'line)
(or (git-fetch (getenv "git url") (getenv "git commit") (or (git-fetch (getenv "git url") (getenv "git commit")
#$output #$output
#:recursive? (call-with-input-string #:recursive? recursive?
(getenv "git recursive?")
read)
#:git-command (string-append #+git "/bin/git")) #:git-command (string-append #+git "/bin/git"))
(download-nar #$output))))) (download-nar #$output)
;; As a last resort, attempt to download from Software Heritage.
;; XXX: Currently recursive checkouts are not supported.
(and (not recursive?)
(swh-download (getenv "git url") (getenv "git commit")
#$output)))))))
(mlet %store-monad ((guile (package->derivation guile system))) (mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name "git-checkout") build (gexp->derivation (or name "git-checkout") build