guix/tests/git.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2019 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     (apply invoke (git-command) "-C" directory
  45            command args))
  46
  47   (mkdir-p directory)
  48   (git "init")
  49
  50   (let loop ((directives directives))
  51     (match directives
  52       (()
  53        directory)
  54       ((('add file contents) rest ...)
  55        (let ((file (string-append directory "/" file)))
  56          (mkdir-p (dirname file))
  57          (call-with-output-file file
  58            (lambda (port)
  59              (display (if (string? contents)
  60                           contents
  61                           (with-repository directory repository
  62                             (contents repository)))
  63                       port)))
  64          (git "add" file)
  65          (loop rest)))
  66       ((('commit text) rest ...)
  67        (git "commit" "-m" text)
  68        (loop rest))
  69       ((('tag name) rest ...)
  70        (git "tag" name)
  71        (loop rest))
  72       ((('branch name) rest ...)
  73        (git "branch" name)
  74        (loop rest))
  75       ((('checkout branch) rest ...)
  76        (git "checkout" branch)
  77        (loop rest))
  78       ((('merge branch message) rest ...)
  79        (git "merge" branch "-m" message)
  80        (loop rest)))))
  81
  82 (define (call-with-temporary-git-repository directives proc)
  83   (call-with-temporary-directory
  84    (lambda (directory)
  85      (populate-git-repository directory directives)
  86      (proc directory))))
  87
  88 (define-syntax-rule (with-temporary-git-repository directory
  89                                                    directives exp ...)
  90   "Evaluate EXP in a context where DIRECTORY contains a checkout populated as
  91 per DIRECTIVES."
  92   (call-with-temporary-git-repository directives
  93                                       (lambda (directory)
  94                                         exp ...)))
  95
  96 (define (find-commit repository message)
  97   "Return the commit in REPOSITORY whose message includes MESSAGE, a string."
  98   (let/ec return
  99     (fold-commits (lambda (commit _)
 100                     (and (string-contains (commit-message commit)
 101                                           message)
 102                          (return commit)))
 103                   #f
 104                   repository)
 105     (error "commit not found" message)))