GNU bug report logs - #68404
[PATCH] guix: download: Add support for git repositories.

Previous Next

To add a comment to this bug, you must first unarchive it, by sending
a message to control AT debbugs.gnu.org, with unarchive 68404 in the body.
You can then email your comments to 68404 AT debbugs.gnu.org in the normal way.

Toggle the display of automated, internal messages from the tracker.

Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):

From: Romain GARBAGE <romain.garbage <at> inria.fr>
To: guix-patches <at> gnu.org
Cc: Romain GARBAGE <romain.garbage <at> inria.fr>
Subject: [PATCH] guix: download: Add support for git repositories.
Date: Fri, 12 Jan 2024 11:21:39 +0100

* 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
  introduction.
* 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 --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
 store.
+
+@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
+repository.
+
+@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)))
     file))
 
+;; 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
               name))
 
 
-(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"))
   (newline)
   (display (G_ "
   -h, --help             display this help and exit"))
@@ -105,6 +190,13 @@ (define (show-help)
   (newline)
   (show-bug-report-information))
 
+(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)
                                   (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) <>)))
+                           (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))
       #t)))
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 <at> 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"
+do
+    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
+done
+
+# Should fail
+guix download --git --branch=non_existent "file://$test_directory" && false
+
+# Same but download to file instead of store
+tmpdir="t-archive-dir-$$"
+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
-- 
2.41.0

Previous Next

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.