1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
3 ;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
5 ;;; This file is part of GNU Guix.
7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
8 ;;; under the terms of the GNU General Public License as published by
9 ;;; the Free Software Foundation; either version 3 of the License, or (at
10 ;;; your option) any later version.
12 ;;; GNU Guix is distributed in the hope that it will be useful, but
13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;;; GNU General Public License for more details.
17 ;;; You should have received a copy of the GNU General Public License
18 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
20 (define-module (guix git)
22 #:use-module (git object)
23 #:use-module (guix i18n)
24 #:use-module (guix base32)
25 #:use-module (gcrypt hash)
26 #:use-module ((guix build utils) #:select (mkdir-p))
27 #:use-module (guix store)
28 #:use-module (guix utils)
29 #:use-module (guix records)
30 #:use-module (guix gexp)
31 #:use-module (rnrs bytevectors)
32 #:use-module (ice-9 match)
33 #:use-module (srfi srfi-1)
34 #:use-module (srfi srfi-11)
35 #:use-module (srfi srfi-34)
36 #:use-module (srfi srfi-35)
37 #:export (%repository-cache-directory
38 honor-system-x509-certificates!
40 update-cached-checkout
41 latest-repository-commit
48 ;; XXX: Use this hack instead of #:autoload to avoid compilation errors.
49 ;; See <http://bugs.gnu.org/12202>.
50 (module-autoload! (current-module)
51 '(git submodule) '(repository-submodules))
53 (define %repository-cache-directory
54 (make-parameter (string-append (cache-directory #:ensure? #f)
57 (define (honor-system-x509-certificates!)
58 "Use the system's X.509 certificates for Git checkouts over HTTPS. Honor
59 the 'SSL_CERT_FILE' and 'SSL_CERT_DIR' environment variables."
60 ;; On distros such as CentOS 7, /etc/ssl/certs contains only a couple of
61 ;; files (instead of all the certificates) among which "ca-bundle.crt". On
62 ;; other distros /etc/ssl/certs usually contains the whole set of
63 ;; certificates along with "ca-certificates.crt". Try to choose the right
65 (let ((file (letrec-syntax ((choose
69 (if (and f (file-exists? f))
74 (choose (getenv "SSL_CERT_FILE")
75 "/etc/ssl/certs/ca-certificates.crt"
76 "/etc/ssl/certs/ca-bundle.crt")))
77 (directory (or (getenv "SSL_CERT_DIR") "/etc/ssl/certs")))
79 (and=> (stat directory #f)
81 (> (stat:nlink st) 2))))
83 (set-tls-certificate-locations! directory file)
86 (define %certificates-initialized?
87 ;; Whether 'honor-system-x509-certificates!' has already been called.
90 (define-syntax-rule (with-libgit2 thunk ...)
92 ;; XXX: The right thing to do would be to call (libgit2-shutdown) here,
93 ;; but pointer finalizers used in guile-git may be called after shutdown,
94 ;; resulting in a segfault. Hence, let's skip shutdown call for now.
96 (unless %certificates-initialized?
97 (honor-system-x509-certificates!)
98 (set! %certificates-initialized? #t))
101 (define* (url-cache-directory url
102 #:optional (cache-directory
103 (%repository-cache-directory))
105 "Return the directory associated to URL in %repository-cache-directory."
108 (bytevector->base32-string
109 (sha256 (string->utf8 (if recursive?
110 (string-append "R:" url)
113 (define (clone* url directory)
114 "Clone git repository at URL into DIRECTORY. Upon failure,
115 make sure no empty directory is left behind."
116 (with-throw-handler #t
120 ;; Note: Explicitly pass options to work around the invalid default
121 ;; value in Guile-Git: <https://bugs.gnu.org/29238>.
122 (if (module-defined? (resolve-interface '(git))
124 (clone url directory (clone-init-options))
125 (clone url directory)))
127 (false-if-exception (rmdir directory)))))
129 (define (url+commit->name url sha1)
130 "Return the string \"<REPO-NAME>-<SHA1:7>\" where REPO-NAME is the name of
131 the git repository, extracted from URL and SHA1:7 the seven first digits
134 (string-replace-substring
135 (last (string-split url #\/)) ".git" "")
136 "-" (string-take sha1 7)))
138 (define (switch-to-ref repository ref)
139 "Switch to REPOSITORY's branch, commit or tag specified by REF. Return the
140 OID (roughly the commit hash) corresponding to REF."
142 (let resolve ((ref ref))
145 (let ((oid (reference-target
146 (branch-lookup repository branch BRANCH-REMOTE))))
147 (object-lookup repository oid)))
149 (let ((len (string-length commit)))
150 ;; 'object-lookup-prefix' appeared in Guile-Git in Mar. 2018, so we
151 ;; can't be sure it's available. Furthermore, 'string->oid' used to
152 ;; read out-of-bounds when passed a string shorter than 40 chars,
153 ;; which is why we delay calls to it below.
155 (if (module-defined? (resolve-interface '(git object))
156 'object-lookup-prefix)
157 (object-lookup-prefix repository (string->oid commit) len)
160 (message "long Git object ID is required")))))
161 (object-lookup repository (string->oid commit)))))
162 (('tag-or-commit . str)
163 (if (or (> (string-length str) 40)
164 (not (string-every char-set:hex-digit str)))
165 (resolve `(tag . ,str)) ;definitely a tag
168 (resolve `(tag . ,str)))
170 ;; There's no such tag, so it must be a commit ID.
171 (resolve `(commit . ,str))))))
173 (let ((oid (reference-name->oid repository
174 (string-append "refs/tags/" tag))))
175 ;; Get the commit that the tag at OID refers to. This is not
176 ;; strictly needed, but it's more consistent to always return the
178 (object-lookup repository
179 (tag-target-id (tag-lookup repository oid))))))))
181 (reset repository obj RESET_HARD)
184 (define (call-with-repository directory proc)
185 (let ((repository #f))
188 (set! repository (repository-open directory)))
192 (repository-close! repository)))))
194 (define-syntax-rule (with-repository directory repository exp ...)
195 "Open the repository at DIRECTORY and bind REPOSITORY to it within the
196 dynamic extent of EXP."
197 (call-with-repository directory
198 (lambda (repository) exp ...)))
200 (define* (update-submodules repository
201 #:key (log-port (current-error-port)))
202 "Update the submodules of REPOSITORY, a Git repository object."
203 ;; Guile-Git < 0.2.0 did not have (git submodule).
204 (if (false-if-exception (resolve-interface '(git submodule)))
205 (for-each (lambda (name)
206 (let ((submodule (submodule-lookup repository name)))
207 (format log-port (G_ "updating submodule '~a'...~%")
209 (submodule-update submodule)
211 ;; Recurse in SUBMODULE.
212 (let ((directory (string-append
213 (repository-working-directory repository)
214 "/" (submodule-path submodule))))
215 (with-repository directory repository
216 (update-submodules repository
217 #:log-port log-port)))))
218 (repository-submodules repository))
219 (format (current-error-port)
220 (G_ "Support for submodules is missing; \
221 please upgrade Guile-Git.~%"))))
223 (define* (update-cached-checkout url
225 (ref '(branch . "master"))
227 (log-port (%make-void-port "w"))
230 url (%repository-cache-directory)
231 #:recursive? recursive?)))
232 "Update the cached checkout of URL to REF in CACHE-DIRECTORY. Return two
233 values: the cache directory name, and the SHA1 commit (a string) corresponding
236 REF is pair whose key is [branch | commit | tag | tag-or-commit ] and value
237 the associated data: [<branch name> | <sha1> | <tag name> | <string>].
239 When RECURSIVE? is true, check out submodules as well, if any."
240 (define canonical-ref
241 ;; We used to require callers to specify "origin/" for each branch, which
242 ;; made little sense since the cache should be transparent to them. So
243 ;; here we append "origin/" if it's missing and otherwise keep it.
246 `(branch . ,(if (string-prefix? "origin/" branch)
248 (string-append "origin/" branch))))
252 (let* ((cache-exists? (openable-repository? cache-directory))
253 (repository (if cache-exists?
254 (repository-open cache-directory)
255 (clone* url cache-directory))))
256 ;; Only fetch remote if it has not been cloned just before.
258 (remote-fetch (remote-lookup repository "origin")))
260 (update-submodules repository #:log-port log-port))
261 (let ((oid (switch-to-ref repository canonical-ref)))
263 ;; Reclaim file descriptors and memory mappings associated with
264 ;; REPOSITORY as soon as possible.
265 (when (module-defined? (resolve-interface '(git repository))
267 (repository-close! repository))
269 (values cache-directory (oid->string oid))))))
271 (define* (latest-repository-commit store url
274 (log-port (%make-void-port "w"))
276 (%repository-cache-directory))
277 (ref '(branch . "master")))
278 "Return two values: the content of the git repository at URL copied into a
279 store directory and the sha1 of the top level commit in this directory. The
280 reference to be checkout, once the repository is fetched, is specified by REF.
281 REF is pair whose key is [branch | commit | tag] and value the associated
282 data, respectively [<branch name> | <sha1> | <tag name>].
284 When RECURSIVE? is true, check out submodules as well, if any.
286 Git repositories are kept in the cache directory specified by
287 %repository-cache-directory parameter.
289 Log progress and checkout info to LOG-PORT."
290 (define (dot-git? file stat)
291 (and (string=? (basename file) ".git")
292 (or (eq? 'directory (stat:type stat))
294 ;; Submodule checkouts end up with a '.git' regular file that
295 ;; contains metadata about where their actual '.git' directory
298 (eq? 'regular (stat:type stat))))))
300 (format log-port "updating checkout of '~a'...~%" url)
303 (update-cached-checkout url
304 #:recursive? recursive?
307 (url-cache-directory url cache-directory
310 #:log-port log-port))
312 (url+commit->name url commit)))
313 (format log-port "retrieved commit ~a~%" commit)
314 (values (add-to-store store name #t "sha256" checkout
315 #:select? (negate dot-git?))
318 (define (print-git-error port key args default-printer)
320 (((? git-error? error) . _)
321 (format port (G_ "Git error: ~a~%")
322 (git-error-message error)))))
324 (set-exception-printer! 'git-error print-git-error)
331 ;; Representation of the "latest" checkout of a branch or a specific commit.
332 (define-record-type* <git-checkout>
333 git-checkout make-git-checkout
335 (url git-checkout-url)
336 (branch git-checkout-branch (default "master"))
337 (commit git-checkout-commit (default #f)) ;#f | tag | commit
338 (recursive? git-checkout-recursive? (default #f)))
340 (define* (latest-repository-commit* url #:key ref recursive? log-port)
341 ;; Monadic variant of 'latest-repository-commit'.
343 ;; The caller--e.g., (guix scripts build)--may not handle 'git-error' so
344 ;; translate it into '&message' conditions that we know will be properly
348 (values (latest-repository-commit store url
350 #:recursive? recursive?
353 (lambda (key error . _)
359 (format #f (G_ "cannot fetch commit ~a from ~a: ~a")
360 commit url (git-error-message error)))
362 (format #f (G_ "cannot fetch branch '~a' from ~a: ~a")
363 branch url (git-error-message error)))
365 (format #f (G_ "Git failure while fetching ~a: ~a")
366 url (git-error-message error))))))))))))
368 (define-gexp-compiler (git-checkout-compiler (checkout <git-checkout>)
370 ;; "Compile" CHECKOUT by updating the local checkout and adding it to the
373 (($ <git-checkout> url branch commit recursive?)
374 (latest-repository-commit* url
376 `(tag-or-commit . ,commit)
378 #:recursive? recursive?
379 #:log-port (current-error-port)))))
382 ;; eval: (put 'with-repository 'scheme-indent-function 2)