diff mbox series

[bug#68404] guix: download: Add support for git repositories.

Message ID 20240112102154.1901-1-romain.garbage@inria.fr
State New
Headers show
Series [bug#68404] guix: download: Add support for git repositories. | expand

Commit Message

Romain GARBAGE Jan. 12, 2024, 10:21 a.m. UTC
* guix/scripts/download.scm (git-download-to-store*): Add new variable.
  (copy-recursively-without-git-folder): New variable.
  (git-download-to-file): Add new variable.
  (show-help): Add 'git', 'commit' and 'branch' options help message.
  (%default-options): Add default value for 'git-reference' option.
  (%options): Add 'git', 'commit' and 'branch' command line options.
  (guix-download) [hash]: Compute hash with 'file-hash*' instead of
  'port-hash' from (gcrypt hash) module. This allows us to compute
  hashes for directories.
* doc/guix.texi (Invoking guix-download): Add @item entries for
  `git', `commit' and `branch' options. Add a paragraph in the
* tests/guix-download.sh: New tests

Change-Id: I6acd362ddff4b6d9e456a0a5a6466eba1ff77c2a
 doc/guix.texi             |  19 ++++++
 guix/scripts/download.scm | 137 +++++++++++++++++++++++++++++++++++---
 tests/guix-download.sh    |  42 ++++++++++++
 3 files changed, 187 insertions(+), 11 deletions(-)
diff mbox series


diff --git a/doc/guix.texi b/doc/guix.texi
index 3002cdfa13..dd5b42cff2 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -13983,6 +13983,9 @@  the certificates of X.509 authorities from the directory pointed to by
 the @env{SSL_CERT_DIR} environment variable (@pxref{X.509
 Certificates}), unless @option{--no-check-certificate} is used.
+Alternatively, @command{guix download} can also retrieve a Git
+repository, possibly a specific commit, tag, or branch.
 The following options are available:
 @table @code
@@ -14007,6 +14010,22 @@  URL, which makes you vulnerable to ``man-in-the-middle'' attacks.
 @itemx -o @var{file}
 Save the downloaded file to @var{file} instead of adding it to the
+@item --git
+@itemx -g
+Checkout the Git repository at the latest commit on the default branch.
+@item --commit=@var{commit-or-tag}
+Checkout the Git repository at @var{commit-or-tag}.
+@var{commit-or-tag} can be either a tag or a commit defined in the Git
+@item --branch=@var{branch}
+Checkout the Git repository at @var{branch}.
+The repository will be checked out at the latest commit of @var{branch},
+which must be a valid branch of the Git repository.
 @end table
 @node Invoking guix hash
diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm
index 19052d5652..8dbbd7a007 100644
--- a/guix/scripts/download.scm
+++ b/guix/scripts/download.scm
@@ -22,17 +22,23 @@  (define-module (guix scripts download)
   #:use-module (guix scripts)
   #:use-module (guix store)
   #:use-module (gcrypt hash)
+  #:use-module (guix hash)
   #:use-module (guix base16)
   #:use-module (guix base32)
   #:autoload   (guix base64) (base64-encode)
   #:use-module ((guix download) #:hide (url-fetch))
+  #:use-module ((guix git)
+                #:select (latest-repository-commit
+                          update-cached-checkout))
   #:use-module ((guix build download)
                 #:select (url-fetch))
+  #:use-module (guix build utils)
   #:use-module ((guix progress)
                 #:select (current-terminal-columns))
   #:use-module ((guix build syscalls)
                 #:select (terminal-columns))
   #:use-module (web uri)
+  #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
@@ -54,6 +60,57 @@  (define (download-to-file url file)
        (url-fetch url file #:mirrors %mirrors)))
+;; This is a simplified version of 'copy-recursively'.
+;; It allows us to filter out the ".git" subfolder.
+;; TODO: Remove when 'copy-recursively' supports '#:select?'.
+(define (copy-recursively-without-dot-git source destination)
+  (define strip-source
+    (let ((len (string-length source)))
+      (lambda (file)
+        (substring file len))))
+  (file-system-fold (lambda (file stat result) ; enter?
+                      (not (string-suffix? "/.git" file)))
+                    (lambda (file stat result) ; leaf
+                      (let ((dest (string-append destination
+                                                 (strip-source file))))
+                        (case (stat:type stat)
+                          ((symlink)
+                           (let ((target (readlink file)))
+                             (symlink target dest)))
+                          (else
+                           (copy-file file dest)))))
+                    (lambda (dir stat result) ; down
+                      (let ((target (string-append destination
+                                                   (strip-source dir))))
+                        (mkdir-p target)))
+                    (const #t)          ; up
+                    (const #t)          ; skip
+                    (lambda (file stat errno result)
+                      (format (current-error-port) "i/o error: ~a: ~a~%"
+                              file (strerror errno))
+                      #f)
+                    #t
+                    source))
+(define (git-download-to-file url file reference)
+  "Download the git repo at URL to file, checked out at REFERENCE.
+REFERENCE must be a pair argument as understood by 'latest-repository-commit'.
+Return FILE."
+  ;; TODO: Support recursive repos.
+  ;; 'libgit2' doesn't support the URL format generated by 'uri->string' so
+  ;; we have to do a little fixup. Dropping completely the 'file:' protocol
+  ;; part gives better performance.
+  (let ((url* (cond ((string-prefix? "file://" url)
+                     (string-drop url (string-length "file://")))
+                    ((string-prefix? "file:" url)
+                     (string-drop url (string-length "file:")))
+                    (else url))))
+    (copy-recursively-without-dot-git
+     (update-cached-checkout (pk 'url* url*) #:ref reference #:recursive? #f)
+     file))
+  file)
 (define (ensure-valid-store-file-name name)
   "Replace any character not allowed in a store name by an underscore."
@@ -67,17 +124,35 @@  (define valid
-(define* (download-to-store* url #:key (verify-certificate? #t))
+(define* (download-to-store* url #:key (verify-certificate? #t) #:allow-other-keys)
   (with-store store
     (download-to-store store url
                        (ensure-valid-store-file-name (basename url))
                        #:verify-certificate? verify-certificate?)))
+(define* (git-download-to-store* url reference #:key (verify-certificate? #t))
+  "Download the git repository at URL to the store, checked out at REFERENCE.
+URL must specify a protocol (i.e https:// or file://), REFERENCE must be a
+pair argument as understood by 'latest-repository-commit'."
+  ;; Ensure the URL string is properly formatted  when using the 'file' protocol:
+  ;; URL is generated using 'uri->string', which returns "file:/path/to/file" instead of
+  ;; "file:///path/to/file", which in turn makes 'git-download-to-store' fail.
+  (let* ((file? (string-prefix? "file:" url))
+         (url* (if (and file?
+                        (not (string-prefix? "file:///" url)))
+                   (string-append "file://" (string-replace url "" 0 (string-length "file:")))
+                   url)))
+    (with-store store
+      ;; TODO: Support recursive repos.
+      ;; TODO: Verify certificate support and deactivation.
+      (latest-repository-commit store url* #:recursive? #f #:ref reference))))
 (define %default-options
   ;; Alist of default option values.
   `((format . ,bytevector->nix-base32-string)
     (hash-algorithm . ,(hash-algorithm sha256))
     (verify-certificate? . #t)
+    (git-reference . #f)
     (download-proc . ,download-to-store*)))
 (define (show-help)
@@ -97,6 +172,16 @@  (define (show-help)
                          do not validate the certificate of HTTPS servers "))
   (format #t (G_ "
   -o, --output=FILE      download to FILE"))
+  (format #t (G_ "
+  -g, --git              download the default branch's latest commit of the
+                         git repository at URL"))
+  (format #t (G_ "
+      --commit=COMMIT_OR_TAG
+                         download the given commit or tag of the git
+                         repository at URL"))
+  (format #t (G_ "
+      --branch=BRANCH    download the given branch of the git repository
+                         at URL"))
   (display (G_ "
   -h, --help             display this help and exit"))
@@ -105,6 +190,13 @@  (define (show-help)
+(define (add-git-download-option result)
+  (alist-cons 'download-proc
+              ;; XXX: #:verify-certificate? currently ignored.
+              (lambda* (url #:key verify-certificate? ref)
+                (git-download-to-store* url ref))
+              (alist-delete 'download result)))
 (define %options
   ;; Specifications of the command-line options.
   (list (option '(#\f "format") #t #f
@@ -136,10 +228,33 @@  (define fmt-proc
                   (alist-cons 'verify-certificate? #f result)))
         (option '(#\o "output") #t #f
                 (lambda (opt name arg result)
-                  (alist-cons 'download-proc
-                              (lambda* (url #:key verify-certificate?)
-                                (download-to-file url arg))
-                              (alist-delete 'download result))))
+                  (let* ((git
+                          (assoc-ref result 'git-reference)))
+                    (if git
+                        (alist-cons 'download-proc
+                                    (lambda* (url #:key verify-certificate? ref)
+                                      (git-download-to-file url arg (assoc-ref result 'git-reference)))
+                                    (alist-delete 'download result))
+                        (alist-cons 'download-proc
+                                    (lambda* (url #:key verify-certificate? #:allow-other-keys)
+                                      (download-to-file url arg))
+                                    (alist-delete 'download result))))))
+        (option '(#\g "git") #f #f
+                (lambda (opt name arg result)
+                  ;; Ignore this option if 'commit' or 'branch' has
+                  ;; already been provided
+                  (if (assoc-ref result 'git-reference)
+                      result
+                      (alist-cons 'git-reference '()
+                                  (add-git-download-option result)))))
+        (option '("commit") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'git-reference `(tag-or-commit . ,arg)
+                              (add-git-download-option result))))
+        (option '("branch") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'git-reference `(branch . ,arg)
+                              (alist-delete 'git-reference result))))
         (option '(#\h "help") #f #f
                 (lambda args
@@ -183,12 +298,12 @@  (define (parse-options)
                     (fetch (uri->string uri)
-                           (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) <>)))
+                           (assq-ref opts 'verify-certificate?)
+                           #:ref (assq-ref opts 'git-reference))))
+           (hash  (let* ((path* (or path
+                                  (leave (G_ "~a: download failed~%")
+                                         arg))))
+                   (file-hash* path* #:algorithm (assoc-ref opts 'hash-algorithm))))
            (fmt   (assq-ref opts 'format)))
       (format #t "~a~%~a~%" path (fmt hash))
diff --git a/tests/guix-download.sh b/tests/guix-download.sh
index f4cb335eef..3bf63c4b12 100644
--- a/tests/guix-download.sh
+++ b/tests/guix-download.sh
@@ -45,4 +45,46 @@  cmp "$output" "$abs_top_srcdir/README"
 # This one should fail.
 guix download "file:///does-not-exist" "file://$abs_top_srcdir/README" && false
+# Test git support with local repository
+test_directory="$(mktemp -d)"
+trap 'chmod -Rf +w "$test_directory"; rm -rf "$test_directory" ; rm -f "$output"' EXIT
+# Create a dummy git repo in the temporary directory
+    cd $test_directory
+    git init
+    touch test
+    git config user.name "User"
+    git config user.email "user@domain"
+    git add test
+    git commit -m "Commit"
+    git tag -a -m "v1" v1
+# Extract commit number
+commit=$((cd $test_directory && git log) | head -n 1 | cut -f2 -d' ')
+# We expect that guix hash is working properly or at least that the output of
+# 'guix download' is consistent with 'guix hash'
+expected_hash=$(guix hash -rx $test_directory)
+# Test the different options
+for option in "" "--commit=$commit" "--commit=v1" "--branch=master"
+    command_output="$(guix download --git $option "file://$test_directory")"
+    computed_hash="$(echo $command_output | cut -f2 -d' ')"
+    store_path="$(echo $command_output | cut -f1 -d' ')"
+    [ "$expected_hash" = "$computed_hash" ]
+    diff -r -x ".git" $test_directory $store_path
+# Should fail
+guix download --git --branch=non_existent "file://$test_directory" && false
+# Same but download to file instead of store
+trap 'chmod -Rf +w "$test_directory"; rm -rf "$test_directory" ; rm -f "$output" ; rm -rf "$tmpdir"' EXIT
+guix download --git "file://$test_directory" -o $tmpdir
+diff -r -x ".git" $test_directory $tmpdir
 exit 0