Package: guix-patches;
Reported by: jgart <jgart <at> dismail.de>
Date: Mon, 30 Aug 2021 16:41:02 UTC
Severity: normal
Tags: patch
View this message in rfc822 format
From: jgart <jgart <at> dismail.de> To: 50274 <at> debbugs.gnu.org Cc: Julien Lepiller <julien <at> lepiller.eu> Subject: [bug#50274] [PATCH] guix: git: Adds feature to download git repository to the store. Date: Mon, 30 Aug 2021 12:39:19 -0400
From: Julien Lepiller <julien <at> lepiller.eu>
* guix/git.scm (download-git-to-store): Download Git repository from
URL at COMMIT to STORE, either under NAME or URL's basename if omitted.
Write progress reports to LOG. RECURSIVE? has the same effect as the
same-named parameter of 'git-fetch'.
* guix/scripts/download.scm (download-git-to-store*): Adds cli option.
Examples:
guix download --git-commit=v0.1.1 github.com/anaseto/gruid-tcell
guix download -c v0.1.1 https://github.com/anaseto/gruid-tcell
---
guix/git.scm | 24 +++++++++++++++++-
guix/scripts/download.scm | 51 ++++++++++++++++++++++++++++++++-------
2 files changed, 65 insertions(+), 10 deletions(-)
diff --git a/guix/git.scm b/guix/git.scm
index 9c6f326c36..4c70782b97 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -28,6 +28,7 @@
#:use-module (gcrypt hash)
#:use-module ((guix build utils)
#:select (mkdir-p delete-file-recursively))
+ #:use-module ((guix build git) #:select (git-fetch))
#:use-module (guix store)
#:use-module (guix utils)
#:use-module (guix records)
@@ -43,6 +44,7 @@
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
+ #:use-module (web uri)
#:export (%repository-cache-directory
honor-system-x509-certificates!
@@ -61,7 +63,9 @@
git-checkout-url
git-checkout-branch
git-checkout-commit
- git-checkout-recursive?))
+ git-checkout-recursive?
+
+ download-git-to-store))
(define %repository-cache-directory
(make-parameter (string-append (cache-directory #:ensure? #f)
@@ -614,6 +618,24 @@ objects: 'ancestor (meaning that OLD is an ancestor of NEW), 'descendant, or
#:recursive? recursive?
#:log-port (current-error-port)))))
+(define* (download-git-to-store store url commit
+ #:optional (name (basename url))
+ #:key (log (current-error-port)) recursive?)
+ "Download Git repository from URL at COMMIT to STORE, either under NAME or
+URL's basename if omitted. Write progress reports to LOG. RECURSIVE? has the
+same effect as the same-named parameter of 'git-fetch'."
+ (define uri
+ (string->uri url))
+
+ (call-with-temporary-directory
+ (lambda (temp)
+ (let ((result
+ (parameterize ((current-output-port log))
+ (git-fetch url commit temp
+ #:recursive? recursive?))))
+ (and result
+ (add-to-store store name #t "sha256" temp))))))
+
;; Local Variables:
;; eval: (put 'with-repository 'scheme-indent-function 2)
;; End:
diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm
index 5a91390358..6253ecaa5c 100644
--- a/guix/scripts/download.scm
+++ b/guix/scripts/download.scm
@@ -26,15 +26,19 @@
#:use-module (guix base32)
#:autoload (guix base64) (base64-encode)
#:use-module ((guix download) #:hide (url-fetch))
+ #:use-module ((guix git) #:select (download-git-to-store))
#:use-module ((guix build download)
#:select (url-fetch))
#:use-module ((guix progress)
#:select (current-terminal-columns))
+ #:use-module ((guix serialization)
+ #:select (write-file))
#:use-module ((guix build syscalls)
#:select (terminal-columns))
#:use-module (web uri)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
#:use-module (srfi srfi-14)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-37)
@@ -76,12 +80,20 @@
(ensure-valid-store-file-name (basename url))
#:verify-certificate? verify-certificate?)))
+(define* (download-git-to-store* url commit #:key recursive?)
+ (with-store store
+ (download-git-to-store store url commit
+ (ensure-valid-store-file-name (basename url))
+ #:recursive? recursive?)))
+
(define %default-options
;; Alist of default option values.
`((format . ,bytevector->nix-base32-string)
(hash-algorithm . ,(hash-algorithm sha256))
(verify-certificate? . #t)
- (download-proc . ,download-to-store*)))
+ (download-proc . ,download-to-store*)
+ (git-download-proc . ,download-git-to-store*)
+ (commit . #f)))
(define (show-help)
(display (G_ "Usage: guix download [OPTION] URL
@@ -100,6 +112,9 @@ and 'base16' ('hex' and 'hexadecimal' can be used as well).\n"))
do not validate the certificate of HTTPS servers "))
(format #t (G_ "
-o, --output=FILE download to FILE"))
+ (format #t (G_ "
+ -c, --git-commit=COMMIT
+ download a Git repository"))
(newline)
(display (G_ "
-h, --help display this help and exit"))
@@ -143,6 +158,9 @@ and 'base16' ('hex' and 'hexadecimal' can be used as well).\n"))
(lambda* (url #:key verify-certificate?)
(download-to-file url arg))
(alist-delete 'download result))))
+ (option '(#\c "git-commit") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'commit arg result)))
(option '(#\h "help") #f #f
(lambda args
@@ -182,16 +200,31 @@ and 'base16' ('hex' and 'hexadecimal' can be used as well).\n"))
(leave (G_ "~a: failed to parse URI~%")
arg)))
(fetch (assq-ref opts 'download-proc))
+ (git-fetch (assq-ref opts 'git-download-proc))
+ (commit (assq-ref opts 'commit))
(path (parameterize ((current-terminal-columns
(terminal-columns)))
- (fetch (uri->string uri)
- #:verify-certificate?
- (assq-ref opts 'verify-certificate?))))
- (hash (call-with-input-file
- (or path
- (leave (G_ "~a: download failed~%")
- arg))
- (cute port-hash (assoc-ref opts 'hash-algorithm) <>)))
+ (if commit
+ (git-fetch (uri->string uri) commit)
+ (fetch (uri->string uri)
+ #:verify-certificate?
+ (assq-ref opts 'verify-certificate?)))))
+ (hash (if (or (assq-ref opts 'recursive) commit)
+ (let-values (((port get-hash)
+ (open-hash-port
+ (assoc-ref opts 'hash-algorithm))))
+ (write-file path port
+ #:select?
+ (if commit
+ (lambda (file stat) (not (equal? (basename file) ".git")))
+ (const #t)))
+ (force-output port)
+ (get-hash))
+ (call-with-input-file
+ (or path
+ (leave (G_ "~a: download failed~%")
+ arg))
+ (cute port-hash (assoc-ref opts 'hash-algorithm) <>))))
(fmt (assq-ref opts 'format)))
(format #t "~a~%~a~%" path (fmt hash))
#t)))
--
2.33.0
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.