~ruther/guix-local

4f5dd898c9b4ab8eeba2ec49e35bdcff36e5cc35 — Reepca Russelstein 6 months ago 00f186a 
build: git: prevent commit from being treated as a flag.

Git's option parsing is more flexible than its command synopses would lead one
to believe: they can apparently be passed even after positional arguments.
Some of these options can be quite nasty if an attacker is able to choose
them.

Additionally, some commands offer no way of disambiguating the meaning of an
argument.  For example, "git checkout" has no way of specifying that an
argument should be unconditionally treated as a commit specifier instead of,
say, an option or a filespec.

* guix/build/git.scm (git-fetch): pass "--" to every git invocation that
  includes non-constant strings.  Explicitly reject commits that start with
  "-".

Change-Id: I3b1707ff8f8544925d1549472f0bda7954249f89
Signed-off-by: Ludovic Courtès <ludo@gnu.org>
patch browse .tar.gz 
1 files changed, 51 insertions(+), 46 deletions(-)

M guix/build/git.scm

M guix/build/git.scm => guix/build/git.scm +51 -46
@@ 45,52 45,57 @@ identifier.  When LFS? is true, configure Git to also fetch Large File
Storage (LFS) files; it assumes that the @code{git-lfs} extension is available
in the environment.  When RECURSIVE? is true, all the sub-modules of URL are
fetched, recursively.  Return #t on success, #f otherwise."

  ;; Disable TLS certificate verification.  The hash of the checkout is known
  ;; in advance anyway.
  (setenv "GIT_SSL_NO_VERIFY" "true")

  (mkdir-p directory)

  (guard (c ((invoke-error? c)
             (format (current-error-port)
                     "git-fetch: '~a~{ ~a~}' failed with exit code ~a~%"
                     (invoke-error-program c)
                     (invoke-error-arguments c)
                     (or (invoke-error-exit-status c) ;XXX: not quite accurate
                         (invoke-error-stop-signal c)
                         (invoke-error-term-signal c)))
             (delete-file-recursively directory)
             #f))
    (with-directory-excursion directory
      (invoke git-command "init" "--initial-branch=main")
      (invoke git-command "remote" "add" "origin" url)

      (when lfs?
        (setenv "HOME" "/tmp")
        (invoke git-command "lfs" "install"))

      (if (zero? (system* git-command "fetch" "--depth" "1" "origin" commit))
          (invoke git-command "checkout" "FETCH_HEAD")
          (begin
            (setvbuf (current-output-port) 'line)
            (format #t "Failed to do a shallow fetch; retrying a full fetch...~%")
            (invoke git-command "fetch" "origin")
            (invoke git-command "checkout" commit)))
      (when recursive?
        ;; Now is the time to fetch sub-modules.
        (invoke git-command "submodule" "update" "--init" "--recursive")

        ;; In sub-modules, '.git' is a flat file, not a directory,
        ;; so we can use 'find-files' here.
        (for-each delete-file-recursively
                  (find-files directory "^\\.git$")))

      ;; The contents of '.git' vary as a function of the current
      ;; status of the Git repo.  Since we want a fixed output, this
      ;; directory needs to be taken out.
      (delete-file-recursively ".git")
      #t)))
  (cond
   ((string-prefix? "-" commit)
    ;; invalid commit specifier that could potentially be interpreted as an
    ;; option
    #f)
   (else
    ;; Disable TLS certificate verification.  The hash of the checkout is known
    ;; in advance anyway.
    (setenv "GIT_SSL_NO_VERIFY" "true")

    (mkdir-p directory)

    (guard (c ((invoke-error? c)
               (format (current-error-port)
                       "git-fetch: '~a~{ ~a~}' failed with exit code ~a~%"
                       (invoke-error-program c)
                       (invoke-error-arguments c)
                       (or (invoke-error-exit-status c) ;XXX: not quite accurate
                           (invoke-error-stop-signal c)
                           (invoke-error-term-signal c)))
               (delete-file-recursively directory)
               #f))
      (with-directory-excursion directory
        (invoke git-command "init" "--initial-branch=main")
        (invoke git-command "remote" "add" "--" "origin" url)

        (when lfs?
          (setenv "HOME" "/tmp")
          (invoke git-command "lfs" "install"))

        (if (zero? (system* git-command "fetch" "--depth" "1" "--" "origin" commit))
            (invoke git-command "checkout" "FETCH_HEAD")
            (begin
              (setvbuf (current-output-port) 'line)
              (format #t "Failed to do a shallow fetch; retrying a full fetch...~%")
              (invoke git-command "fetch" "--" "origin")
              (invoke git-command "checkout" commit "--")))
        (when recursive?
          ;; Now is the time to fetch sub-modules.
          (invoke git-command "submodule" "update" "--init" "--recursive")

          ;; In sub-modules, '.git' is a flat file, not a directory,
          ;; so we can use 'find-files' here.
          (for-each delete-file-recursively
                    (find-files directory "^\\.git$")))

        ;; The contents of '.git' vary as a function of the current
        ;; status of the Git repo.  Since we want a fixed output, this
        ;; directory needs to be taken out.
        (delete-file-recursively ".git")
        #t)))))


(define* (git-fetch-with-fallback url commit directory