[bug#68405] [PATCH v2] guix: download: Add support for git repositories.

[Maxim Cournoyer]

Hello,

Romain GARBAGE <romain.garbage@inria.fr> writes:

> Added `--recursive' option.

I still see a TODO about supporting recursive repos in the code.  Is
that still the case?

> Removed `pk' call.
>
> * guix/scripts/download.scm (git-download-to-store*): Add new variable.
>   (copy-recursively-without-dot-git): New variable.
>   (git-download-to-file): Add new variable.
>   (show-help): Add 'git', 'commit', 'branch' and 'recursive'options
>   help message.
>   (%default-options): Add default value for 'git-reference' and
>   'recursive' options.
>   (%options): Add 'git', 'commit', 'branch' and 'recursive' 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', `branch' and `recursive' options. Add a paragraph in
>   the introduction.
> * tests/guix-download.sh: New tests.

This sounds good and is something that I'm many many of us have wanted
for some time.  Thank you for working on it!

Nitpick about the commit message: the convention seems to be to not use
a hanging indent when writing GNU ChangeLog messages.

> ---
>  doc/guix.texi             |  23 ++++++
>  guix/scripts/download.scm | 146 ++++++++++++++++++++++++++++++++++----
>  tests/guix-download.sh    |  42 +++++++++++
>  3 files changed, 199 insertions(+), 12 deletions(-)
>
> diff --git a/doc/guix.texi b/doc/guix.texi
> index 3002cdfa13..d3b40e878b 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,26 @@ 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.
> +
> +@item --recursive
> +@itemx -r
> +Recursively clone the Git repository.
>  @end table
>
>  @node Invoking guix hash
> diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm
> index 19052d5652..50c9a43791 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?'.

Is a #:select? planned for copy-recursively?  (in the works?)

> +(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 recursive?)
> +  "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 url* #:ref reference #:recursive? recursive?)
> +     file))
> +  file)
> +
>  (define (ensure-valid-store-file-name name)
>    "Replace any character not allowed in a store name by an underscore."
>
> @@ -67,17 +124,36 @@ (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 recursive? #: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? recursive? #:ref 
> reference))))
> +

Some lines look like > 80 chars here.  Please break long lines
accordingly.

>  (define %default-options
>    ;; Alist of default option values.
>    `((format . ,bytevector->nix-base32-string)
>      (hash-algorithm . ,(hash-algorithm sha256))
>      (verify-certificate? . #t)
> +    (git-reference . #f)
> +    (recursive? . #f)
>      (download-proc . ,download-to-store*)))
>
>  (define (show-help)
> @@ -97,6 +173,19 @@ (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"))
> +  (format #t (G_ "
> +  -r, --recursive        download a git repository recursively"))
> +
>    (newline)
>    (display (G_ "
>    -h, --help             display this help and exit"))
> @@ -105,6 +194,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 recursive?)
> +                (git-download-to-store* url ref recursive?))
> +              (alist-delete 'download result)))
> +
>  (define %options
>    ;; Specifications of the command-line options.
>    (list (option '(#\f "format") #t #f
> @@ -136,11 +232,36 @@ (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 recursive?)
> +                                      (git-download-to-file url arg 
> (assoc-ref result 'git-reference) recursive?))
> +                                    (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 '(#\r "recursive") #f #f
> +                (lambda (opt name arg result)
> +                  (alist-cons 'recursive? #t result)))
>          (option '(#\h "help") #f #f
>                  (lambda args
>                    (leave-on-EPIPE (show-help))
> @@ -183,12 +304,13 @@ (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)
> +                           #:recursive? (assq-ref opts 'recursive?))))
> +           (hash  (let* ((path* (or path
> +                                  (leave (G_ "~a: download failed~%")
> +                                         arg))))
> +                   (file-hash* path* #:algorithm (assoc-ref opts 
> 'hash-algorithm))))

Here also there are some too long lines in the above hunks; please break
long lines so they fit within the 80 characters limit.

>             (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

Nitpick: please punctuate standalone comments (here, a missing period).

> +test_directory="$(mktemp -d)"
> +trap 'chmod -Rf +w "$test_directory"; rm -rf "$test_directory" ; rm -f 
> "$output"' EXIT

the 'chmod' doesn't seem to be useful; since we force removing with -f ?
And where did the $output variable come from?

> +
> +# 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"
> +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

It'd look nicer if there was a single global trap call at the top of
these tests.  Don't forget to  punctuate your comments :-).

Otherwise, it looks good to me, although I haven't tried it.

-- 
Thanks,
Maxim