guix/tests/git.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix tests git)
  20   #:use-module (git)
  21   #:use-module ((guix git) #:select (with-repository))
  22   #:use-module (guix utils)
  23   #:use-module (guix build utils)
  24   #:use-module (ice-9 match)
  25   #:use-module (ice-9 control)
  26   #:export (git-command
  27             with-temporary-git-repository
  28             find-commit))
  29
  30 (define git-command
  31   (make-parameter "git"))
  32
  33 (define (populate-git-repository directory directives)
  34   "Initialize a new Git checkout and repository in DIRECTORY and apply
  35 DIRECTIVES.  Each element of DIRECTIVES is an sexp like:
  36
  37   (add \"foo.txt\" \"hi!\")
  38
  39 Return DIRECTORY on success."
  40
  41   ;; Note: As of version 0.2.0, Guile-Git lacks the necessary bindings to do
  42   ;; all this, so resort to the "git" command.
  43   (define (git command . args)
  44     ;; Make sure Git doesn't rely on the user's config.
  45     (call-with-temporary-directory
  46      (lambda (home)
  47        (call-with-output-file (string-append home "/.gitconfig")
  48          (lambda (port)
  49            (display "[user]
  50   email = charlie@example.org\n  name = Charlie Guix\n"
  51                     port)))
  52
  53        (with-environment-variables
  54         `(("GIT_CONFIG_NOSYSTEM" "1")
  55           ("GIT_ATTR_NOSYSTEM" "1")
  56           ("HOME" ,home))
  57         (apply invoke (git-command) "-C" directory
  58                command args)))))
  59
  60   (mkdir-p directory)
  61   (git "init")
  62
  63   (let loop ((directives directives))
  64     (match directives
  65       (()
  66        directory)
  67       ((('add file contents) rest ...)
  68        (let ((file (string-append directory "/" file)))
  69          (mkdir-p (dirname file))
  70          (call-with-output-file file
  71            (lambda (port)
  72              (display (if (string? contents)
  73                           contents
  74                           (with-repository directory repository
  75                             (contents repository)))
  76                       port)))
  77          (git "add" file)
  78          (loop rest)))
  79       ((('commit text) rest ...)
  80        (git "commit" "-m" text)
  81        (loop rest))
  82       ((('commit text ('signer fingerprint)) rest ...)
  83        (git "commit" "-m" text (string-append "--gpg-sign=" fingerprint))
  84        (loop rest))
  85       ((('tag name) rest ...)
  86        (git "tag" name)
  87        (loop rest))
  88       ((('branch name) rest ...)
  89        (git "branch" name)
  90        (loop rest))
  91       ((('checkout branch) rest ...)
  92        (git "checkout" branch)
  93        (loop rest))
  94       ((('merge branch message) rest ...)
  95        (git "merge" branch "-m" message)
  96        (loop rest))
  97       ((('merge branch message ('signer fingerprint)) rest ...)
  98        (git "merge" branch "-m" message
  99             (string-append "--gpg-sign=" fingerprint))
 100        (loop rest)))))
 101
 102 (define (call-with-temporary-git-repository directives proc)
 103   (call-with-temporary-directory
 104    (lambda (directory)
 105      (populate-git-repository directory directives)
 106      (proc directory))))
 107
 108 (define-syntax-rule (with-temporary-git-repository directory
 109                                                    directives exp ...)
 110   "Evaluate EXP in a context where DIRECTORY contains a checkout populated as
 111 per DIRECTIVES."
 112   (call-with-temporary-git-repository directives
 113                                       (lambda (directory)
 114                                         exp ...)))
 115
 116 (define (find-commit repository message)
 117   "Return the commit in REPOSITORY whose message includes MESSAGE, a string."
 118   (let/ec return
 119     (fold-commits (lambda (commit _)
 120                     (and (string-contains (commit-message commit)
 121                                           message)
 122                          (return commit)))
 123                   #f
 124                   repository)
 125     (error "commit not found" message)))