[bug#50274] [PATCH] guix: git: Adds feature to download git repository to the store.

[jgart]

From: Julien Lepiller <julien@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