guix-fork/guix/tests/git.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix tests git)
  #:use-module (git)
  #:use-module ((guix git) #:select (with-repository))
  #:use-module (guix utils)
  #:use-module (guix build utils)
  #:use-module (ice-9 match)
  #:use-module ((ice-9 control) #:select (let/ec))
  #:export (git-command
            with-temporary-git-repository
            with-git-repository
            serve-git-repository
            with-served-git-repository
            with-served-temporary-git-repository
            find-commit))

(define git-command
  (make-parameter "git"))

(define (populate-git-repository directory directives)
  "Initialize a new Git checkout and repository in DIRECTORY and apply
DIRECTIVES.  Each element of DIRECTIVES is an sexp like:

  (add \"foo.txt\" \"hi!\")

Return DIRECTORY on success."

  ;; Note: As of version 0.2.0, Guile-Git lacks the necessary bindings to do
  ;; all this, so resort to the "git" command.
  (define (git command . args)
    ;; Make sure Git doesn't rely on the user's config.
    (call-with-temporary-directory
     (lambda (home)
       (call-with-output-file (string-append home "/.gitconfig")
         (lambda (port)
           (display "[user]
  email = charlie@example.org\n  name = Charlie Guix\n"
                    port)))

       (with-environment-variables
        `(("GIT_CONFIG_NOSYSTEM" "1")
          ("GIT_ATTR_NOSYSTEM" "1")
          ("GIT_CONFIG_GLOBAL" ,(string-append home "/.gitconfig"))
          ("HOME" ,home))
        (apply invoke (git-command) "-C" directory
               command args)))))

  (unless (directory-exists? (string-append directory "/.git"))
    (mkdir-p directory)
    (git "init"))

  (let loop ((directives directives))
    (match directives
      (()
       directory)
      ((('add file contents) rest ...)
       (let ((file (string-append directory "/" file)))
         (mkdir-p (dirname file))
         (call-with-output-file file
           (lambda (port)
             (set-port-encoding! port "UTF-8")
             (display (if (string? contents)
                          contents
                          (with-repository directory repository
                            (contents repository)))
                      port)))
         (git "add" file)
         (loop rest)))
      ((('add file-name-and-content) rest ...)
       (loop (cons `(add ,file-name-and-content ,file-name-and-content)
                   rest)))
      ((('remove file) rest ...)
       (git "rm" "-f" file)
       (loop rest))
      ((('commit text) rest ...)
       (git "commit" "-m" text)
       (loop rest))
      ((('commit text ('signer fingerprint)) rest ...)
       (git "commit" "-m" text (string-append "--gpg-sign=" fingerprint))
       (loop rest))
      ((('tag name) rest ...)
       (git "tag" name)
       (loop rest))
      ((('tag name text) rest ...)
       (git "tag" "-m" text name)
       (loop rest))
      ((('branch name) rest ...)
       (git "branch" name)
       (loop rest))
      ((('checkout branch) rest ...)
       (git "checkout" branch)
       (loop rest))
      ((('checkout branch 'orphan) rest ...)
       (git "checkout" "--orphan" branch)
       (loop rest))
      ((('merge branch message) rest ...)
       (git "merge" branch "-m" message)
       (loop rest))
      ((('merge branch message ('signer fingerprint)) rest ...)
       (git "merge" branch "-m" message
            (string-append "--gpg-sign=" fingerprint))
       (loop rest))
      ((('reset to) rest ...)
       (git "reset" "--hard" to)
       (loop rest)))))

(define (call-with-temporary-git-repository directives proc)
  (call-with-temporary-directory
   (lambda (directory)
     (populate-git-repository directory directives)
     (proc directory))))

(define-syntax-rule (with-temporary-git-repository directory
                                                   directives exp ...)
  "Evaluate EXP in a context where DIRECTORY contains a checkout populated as
per DIRECTIVES."
  (call-with-temporary-git-repository directives
                                      (lambda (directory)
                                        exp ...)))

(define-syntax-rule (with-git-repository directory
                                         directives exp ...)
  "Evaluate EXP in a context where DIRECTORY is (further) populated as
per DIRECTIVES."
  (begin
    (populate-git-repository directory directives)
    exp ...))

(define (find-commit repository message)
  "Return the commit in REPOSITORY whose message includes MESSAGE, a string."
  (let/ec return
    (fold-commits (lambda (commit _)
                    (and (string-contains (commit-message commit)
                                          message)
                         (return commit)))
                  #f
                  repository)
    (error "commit not found" message)))

(define* (serve-git-repository directory #:optional port)
  "Run \"git daemon\" to serve the bare git repository at DIRECTORY as the
root resource on PORT on the loopback interface.  If PORT isn't provided or is
#f, select an arbitrary unused port instead.

Return two values: the PID of the newly-spawned process and the port it is
listening on."
  (let ((port (or port
                  ;; XXX: race between when it's closed and 'git daemon' binds
                  ;; the same port.
                  (call-with-port (socket AF_INET SOCK_STREAM 0)
                    (lambda (sock)
                      (bind sock AF_INET INADDR_LOOPBACK 0)
                      (sockaddr:port (getsockname sock)))))))
    (values
     (spawn (git-command)
            (list (basename (git-command))
                  "daemon"
                  (string-append "--base-path=" directory)
                  "--listen=127.0.0.1"
                  "--listen=::1"
                  (string-append "--port=" (number->string port))
                  "--export-all" ;; don't require git-daemon-export-ok file
                  "--strict-paths"
                  "--"
                  ;; with --strict-paths this limits requests to exactly this
                  ;; directory.  The client can't fetch an empty string,
                  ;; though (has to be at least "/"), so add a trailing slash.
                  (if (string-suffix? "/" directory)
                      directory
                      (string-append directory "/"))))
     port)))

(define* (call-with-served-git-repository directory proc #:key port)
  "Serve DIRECTORY as the root resource \"/\" on the loopback interface during
the dynamic extent of a single invocation of PROC.  PROC is called with a
single integer argument indicating which port of the loopback interface \"git
daemon\" is listening on.  If PORT is specified, that port will be used,
otherwise a random unused port will be chosen."
  (call-with-values (lambda ()
                      (serve-git-repository directory port))
    (lambda (pid port)
      (dynamic-wind
        (const #t)
        (lambda ()
          (proc port))
        (lambda ()
          (kill pid SIGTERM)
          (waitpid pid))))))

(define-syntax-rule (with-served-git-repository directory port exp ...)
  "Evaluate EXP in a context where the identifier PORT is bound to a port
number on which \"git daemon\" is serving DIRECTORY as the root resource
\"/\"."
  (call-with-served-git-repository directory
                                   (lambda (port)
                                     exp ...)))

(define-syntax-rule (with-served-temporary-git-repository directory port
                                                          directives exp ...)
  (with-temporary-git-repository directory directives
    (with-served-git-repository (string-append directory "/.git") port
      exp ...)))