1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
| | ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; 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 git)
#:use-module (git)
#:use-module (git object)
#:use-module (guix base32)
#:use-module (guix hash)
#:use-module (guix build utils)
#:use-module (guix store)
#:use-module (guix utils)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:export (%repository-cache-path
latest-repository-commit))
(define %repository-cache-path
(make-parameter "/var/cache/guix/checkouts"))
(define-syntax-rule (with-libgit2 thunk ...)
(dynamic-wind
(lambda ()
(libgit2-init!))
(lambda ()
thunk ...)
(lambda ()
(libgit2-shutdown))))
(define (repository-cache-directory url)
"Return the directory associated to URL in %repository-cache-path."
(string-append
(%repository-cache-path) "/"
(bytevector->base32-string (sha256 (string->utf8 url)))))
(define (clone-with-error-handling url path)
"Clone git repository at URL into PATH with error handling."
(catch 'git-error
(lambda ()
(mkdir-p path)
(clone url path))
(lambda (key . parameters)
(rmdir path)
(error "Clone error: " parameters))))
(define (repository->head-sha1 repo)
"Return the sha1 of the HEAD commit in REPOSITORY as a string."
(let ((oid (reference-target (repository-head repo))))
(oid->string (commit-id (commit-lookup repo oid)))))
(define (url+commit->name url sha1)
"Return the string \"<REPO-NAME>-<SHA1:7>\" where REPO-NAME is the name of
the git repository, extracted from URL and SHA1:7 the seven first digits
of SHA1 string."
(string-append
(string-replace-substring
(last (string-split url #\/)) ".git" "")
"-" (string-take sha1 7)))
(define* (copy-to-store cache-path #:key url repository)
"Copy items in cache-path to store. URL and REPOSITORY are used
to forge store directory name."
(let* ((commit (repository->head-sha1 repository))
(name (url+commit->name url commit)))
(with-store store
(values (add-to-store store name #t "sha256" cache-path) commit))))
(define (switch-to-ref repository ref)
"Switch to REPOSITORY's branch, commit or tag specified by REF."
(let* ((oid (match ref
(('branch . branch)
(reference-target
(branch-lookup repository branch BRANCH-REMOTE)))
(('commit . commit)
(string->oid commit))
(('tag . tag)
(reference-name->oid repository
(string-append "refs/tags/" tag)))))
(obj (object-lookup repository oid)))
;; guile-git checkout binding seems broken.
(reset repository obj RESET_HARD)))
(define (switch-to-ref* repository ref)
"Switch to REF in REPOSITORY with error handling."
(catch 'git-error
(lambda ()
(switch-to-ref repository ref))
(lambda (key . parameters)
(error
(format #f "Failed to switch to ref ~s: ~s" ref parameters)))))
(define (remote-fetch* repository remote-name)
"Fetch REMOTE-NAME of REPOSITORY with error handling."
(catch 'git-error
(lambda ()
(remote-fetch (remote-lookup repository remote-name)))
(lambda (key . parameters)
(error
(format #f "Failed to fetch remote ~a: ~a" remote-name parameters)))))
(define* (latest-repository-commit url
#:key
(ref '(branch . "origin/master")))
"Return two values: the content of the git repository at URL copied into a
store directory and the sha1 of the top level commit in this directory. The
reference to be checkout, once the repository is fetched, is specified by REF.
REF is pair whose key is [branch | commit | tag] and value the associated
data, respectively [<branch name> | <sha1> | <tag name>].
Git repositories are kept in the cache directory specified by
%repository-cache-path parameter."
(with-libgit2
(let* ((cache-dir (repository-cache-directory url))
(cache-exists? (openable-repository? cache-dir))
(repository (if cache-exists?
(repository-open cache-dir)
(clone-with-error-handling url cache-dir))))
;; Only fetch remote if it has not been cloned just before.
(when cache-exists?
(remote-fetch* repository "origin"))
(switch-to-ref* repository ref)
(copy-to-store cache-dir
#:url url
#:repository repository))))
|