1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
4 ;;; This file is part of GNU Guix.
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.
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.
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/>.
19 (define-module (guix tests 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)
27 with-temporary-git-repository
31 (make-parameter "git"))
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:
37 (add \"foo.txt\" \"hi!\")
39 Return DIRECTORY on success."
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
47 (call-with-output-file (string-append home "/.gitconfig")
50 email = charlie@example.org\n name = Charlie Guix\n"
53 (with-environment-variables
54 `(("GIT_CONFIG_NOSYSTEM" "1")
55 ("GIT_ATTR_NOSYSTEM" "1")
57 (apply invoke (git-command) "-C" directory
63 (let loop ((directives directives))
67 ((('add file contents) rest ...)
68 (let ((file (string-append directory "/" file)))
69 (mkdir-p (dirname file))
70 (call-with-output-file file
72 (display (if (string? contents)
74 (with-repository directory repository
75 (contents repository)))
79 ((('remove file) rest ...)
82 ((('commit text) rest ...)
83 (git "commit" "-m" text)
85 ((('commit text ('signer fingerprint)) rest ...)
86 (git "commit" "-m" text (string-append "--gpg-sign=" fingerprint))
88 ((('tag name) rest ...)
91 ((('branch name) rest ...)
94 ((('checkout branch) rest ...)
95 (git "checkout" branch)
97 ((('merge branch message) rest ...)
98 (git "merge" branch "-m" message)
100 ((('merge branch message ('signer fingerprint)) rest ...)
101 (git "merge" branch "-m" message
102 (string-append "--gpg-sign=" fingerprint))
105 (define (call-with-temporary-git-repository directives proc)
106 (call-with-temporary-directory
108 (populate-git-repository directory directives)
111 (define-syntax-rule (with-temporary-git-repository directory
113 "Evaluate EXP in a context where DIRECTORY contains a checkout populated as
115 (call-with-temporary-git-repository directives
119 (define (find-commit repository message)
120 "Return the commit in REPOSITORY whose message includes MESSAGE, a string."
122 (fold-commits (lambda (commit _)
123 (and (string-contains (commit-message commit)
128 (error "commit not found" message)))