gnu: octave, octave-cli: Update to 5.2.0.
[jackhill/guix/guix.git] / guix / git.scm
CommitLineData
6b7b3ca9 1;;; GNU Guix --- Functional package management for GNU
c3574749 2;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
6a7c4636 3;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
6b7b3ca9
MO
4;;;
5;;; This file is part of GNU Guix.
6;;;
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.
11;;;
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.
16;;;
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/>.
19
20(define-module (guix git)
21 #:use-module (git)
22 #:use-module (git object)
a3d77c51 23 #:use-module (guix i18n)
6b7b3ca9 24 #:use-module (guix base32)
ca719424 25 #:use-module (gcrypt hash)
0ad5f809 26 #:use-module ((guix build utils) #:select (mkdir-p))
6b7b3ca9
MO
27 #:use-module (guix store)
28 #:use-module (guix utils)
49ae3f6d
LC
29 #:use-module (guix records)
30 #:use-module (guix gexp)
873f6f13 31 #:use-module (guix sets)
6b7b3ca9
MO
32 #:use-module (rnrs bytevectors)
33 #:use-module (ice-9 match)
34 #:use-module (srfi srfi-1)
91881986 35 #:use-module (srfi srfi-11)
95bd9f65
LC
36 #:use-module (srfi srfi-34)
37 #:use-module (srfi srfi-35)
6b7b3ca9 38 #:export (%repository-cache-directory
bc041b3e
LC
39 honor-system-x509-certificates!
40
873f6f13 41 with-repository
91881986 42 update-cached-checkout
49ae3f6d 43 latest-repository-commit
873f6f13 44 commit-difference
49ae3f6d
LC
45
46 git-checkout
47 git-checkout?
48 git-checkout-url
49 git-checkout-branch))
6b7b3ca9
MO
50
51(define %repository-cache-directory
e83b2b0f
LC
52 (make-parameter (string-append (cache-directory #:ensure? #f)
53 "/checkouts")))
6b7b3ca9 54
bc041b3e
LC
55(define (honor-system-x509-certificates!)
56 "Use the system's X.509 certificates for Git checkouts over HTTPS. Honor
57the 'SSL_CERT_FILE' and 'SSL_CERT_DIR' environment variables."
58 ;; On distros such as CentOS 7, /etc/ssl/certs contains only a couple of
59 ;; files (instead of all the certificates) among which "ca-bundle.crt". On
60 ;; other distros /etc/ssl/certs usually contains the whole set of
61 ;; certificates along with "ca-certificates.crt". Try to choose the right
62 ;; one.
63 (let ((file (letrec-syntax ((choose
64 (syntax-rules ()
65 ((_ file rest ...)
66 (let ((f file))
67 (if (and f (file-exists? f))
68 f
69 (choose rest ...))))
70 ((_)
71 #f))))
72 (choose (getenv "SSL_CERT_FILE")
73 "/etc/ssl/certs/ca-certificates.crt"
74 "/etc/ssl/certs/ca-bundle.crt")))
75 (directory (or (getenv "SSL_CERT_DIR") "/etc/ssl/certs")))
76 (and (or file
77 (and=> (stat directory #f)
78 (lambda (st)
79 (> (stat:nlink st) 2))))
80 (begin
81 (set-tls-certificate-locations! directory file)
82 #t))))
83
84(define %certificates-initialized?
85 ;; Whether 'honor-system-x509-certificates!' has already been called.
86 #f)
87
6b7b3ca9 88(define-syntax-rule (with-libgit2 thunk ...)
b02469d2
MO
89 (begin
90 ;; XXX: The right thing to do would be to call (libgit2-shutdown) here,
91 ;; but pointer finalizers used in guile-git may be called after shutdown,
92 ;; resulting in a segfault. Hence, let's skip shutdown call for now.
93 (libgit2-init!)
bc041b3e
LC
94 (unless %certificates-initialized?
95 (honor-system-x509-certificates!)
96 (set! %certificates-initialized? #t))
b02469d2 97 thunk ...))
6b7b3ca9
MO
98
99(define* (url-cache-directory url
100 #:optional (cache-directory
60cbc6a8
LC
101 (%repository-cache-directory))
102 #:key recursive?)
6b7b3ca9
MO
103 "Return the directory associated to URL in %repository-cache-directory."
104 (string-append
105 cache-directory "/"
60cbc6a8
LC
106 (bytevector->base32-string
107 (sha256 (string->utf8 (if recursive?
108 (string-append "R:" url)
109 url))))))
6b7b3ca9 110
c3574749
MO
111;; Authentication appeared in Guile-Git 0.3.0, check if it is available.
112(define auth-supported?
113 (false-if-exception (resolve-interface '(git auth))))
114
6b7b3ca9
MO
115(define (clone* url directory)
116 "Clone git repository at URL into DIRECTORY. Upon failure,
117make sure no empty directory is left behind."
118 (with-throw-handler #t
119 (lambda ()
120 (mkdir-p directory)
195f0d05
LC
121
122 ;; Note: Explicitly pass options to work around the invalid default
123 ;; value in Guile-Git: <https://bugs.gnu.org/29238>.
b1488c76
LC
124 (if (module-defined? (resolve-interface '(git))
125 'clone-init-options)
c3574749
MO
126 (let ((auth-method (and auth-supported?
127 (%make-auth-ssh-agent))))
128 (clone url directory
129 (if auth-supported?
130 (make-clone-options
131 #:fetch-options (make-fetch-options auth-method))
132 (clone-init-options))))
b1488c76 133 (clone url directory)))
6b7b3ca9
MO
134 (lambda _
135 (false-if-exception (rmdir directory)))))
136
6b7b3ca9
MO
137(define (url+commit->name url sha1)
138 "Return the string \"<REPO-NAME>-<SHA1:7>\" where REPO-NAME is the name of
139the git repository, extracted from URL and SHA1:7 the seven first digits
140of SHA1 string."
141 (string-append
142 (string-replace-substring
143 (last (string-split url #\/)) ".git" "")
144 "-" (string-take sha1 7)))
145
6b7b3ca9 146(define (switch-to-ref repository ref)
91881986
LC
147 "Switch to REPOSITORY's branch, commit or tag specified by REF. Return the
148OID (roughly the commit hash) corresponding to REF."
95bd9f65 149 (define obj
c4c2449f
LC
150 (let resolve ((ref ref))
151 (match ref
152 (('branch . branch)
153 (let ((oid (reference-target
154 (branch-lookup repository branch BRANCH-REMOTE))))
155 (object-lookup repository oid)))
156 (('commit . commit)
157 (let ((len (string-length commit)))
158 ;; 'object-lookup-prefix' appeared in Guile-Git in Mar. 2018, so we
159 ;; can't be sure it's available. Furthermore, 'string->oid' used to
160 ;; read out-of-bounds when passed a string shorter than 40 chars,
161 ;; which is why we delay calls to it below.
162 (if (< len 40)
163 (if (module-defined? (resolve-interface '(git object))
164 'object-lookup-prefix)
165 (object-lookup-prefix repository (string->oid commit) len)
166 (raise (condition
167 (&message
168 (message "long Git object ID is required")))))
169 (object-lookup repository (string->oid commit)))))
170 (('tag-or-commit . str)
171 (if (or (> (string-length str) 40)
172 (not (string-every char-set:hex-digit str)))
173 (resolve `(tag . ,str)) ;definitely a tag
174 (catch 'git-error
175 (lambda ()
176 (resolve `(tag . ,str)))
177 (lambda _
178 ;; There's no such tag, so it must be a commit ID.
179 (resolve `(commit . ,str))))))
180 (('tag . tag)
181 (let ((oid (reference-name->oid repository
182 (string-append "refs/tags/" tag))))
10a8c2bb
LC
183 ;; Get the commit that the tag at OID refers to. This is not
184 ;; strictly needed, but it's more consistent to always return the
185 ;; OID of a commit.
186 (object-lookup repository
187 (tag-target-id (tag-lookup repository oid))))))))
95bd9f65 188
91881986
LC
189 (reset repository obj RESET_HARD)
190 (object-id obj))
191
60cbc6a8
LC
192(define (call-with-repository directory proc)
193 (let ((repository #f))
194 (dynamic-wind
195 (lambda ()
196 (set! repository (repository-open directory)))
197 (lambda ()
198 (proc repository))
199 (lambda ()
200 (repository-close! repository)))))
201
202(define-syntax-rule (with-repository directory repository exp ...)
203 "Open the repository at DIRECTORY and bind REPOSITORY to it within the
204dynamic extent of EXP."
205 (call-with-repository directory
206 (lambda (repository) exp ...)))
207
6a7c4636
LC
208(define (load-git-submodules)
209 "Attempt to load (git submodules), which was missing until Guile-Git 0.2.0.
210Return true on success, false on failure."
211 (match (false-if-exception (resolve-interface '(git submodule)))
212 (#f
213 (set! load-git-submodules (const #f))
214 #f)
215 (iface
058d0251 216 (module-use! (resolve-module '(guix git)) iface)
6a7c4636
LC
217 (set! load-git-submodules (const #t))
218 #t)))
219
60cbc6a8
LC
220(define* (update-submodules repository
221 #:key (log-port (current-error-port)))
222 "Update the submodules of REPOSITORY, a Git repository object."
223 ;; Guile-Git < 0.2.0 did not have (git submodule).
6a7c4636 224 (if (load-git-submodules)
60cbc6a8
LC
225 (for-each (lambda (name)
226 (let ((submodule (submodule-lookup repository name)))
227 (format log-port (G_ "updating submodule '~a'...~%")
228 name)
229 (submodule-update submodule)
230
231 ;; Recurse in SUBMODULE.
232 (let ((directory (string-append
233 (repository-working-directory repository)
234 "/" (submodule-path submodule))))
235 (with-repository directory repository
236 (update-submodules repository
237 #:log-port log-port)))))
238 (repository-submodules repository))
239 (format (current-error-port)
240 (G_ "Support for submodules is missing; \
241please upgrade Guile-Git.~%"))))
242
a78dcb3d
LC
243(define (reference-available? repository ref)
244 "Return true if REF, a reference such as '(commit . \"cabba9e\"), is
245definitely available in REPOSITORY, false otherwise."
246 (match ref
247 (('commit . commit)
248 (catch 'git-error
249 (lambda ()
250 (->bool (commit-lookup repository (string->oid commit))))
251 (lambda (key error . rest)
252 (if (= GIT_ENOTFOUND (git-error-code error))
253 #f
254 (apply throw key error rest)))))
255 (_
256 #f)))
257
91881986
LC
258(define* (update-cached-checkout url
259 #:key
37a6cdbf 260 (ref '(branch . "master"))
60cbc6a8
LC
261 recursive?
262 (log-port (%make-void-port "w"))
91881986 263 (cache-directory
ffc3fcad 264 (url-cache-directory
60cbc6a8
LC
265 url (%repository-cache-directory)
266 #:recursive? recursive?)))
91881986
LC
267 "Update the cached checkout of URL to REF in CACHE-DIRECTORY. Return two
268values: the cache directory name, and the SHA1 commit (a string) corresponding
269to REF.
270
c4c2449f
LC
271REF is pair whose key is [branch | commit | tag | tag-or-commit ] and value
272the associated data: [<branch name> | <sha1> | <tag name> | <string>].
60cbc6a8
LC
273
274When RECURSIVE? is true, check out submodules as well, if any."
37a6cdbf
LC
275 (define canonical-ref
276 ;; We used to require callers to specify "origin/" for each branch, which
277 ;; made little sense since the cache should be transparent to them. So
278 ;; here we append "origin/" if it's missing and otherwise keep it.
279 (match ref
280 (('branch . branch)
281 `(branch . ,(if (string-prefix? "origin/" branch)
282 branch
283 (string-append "origin/" branch))))
284 (_ ref)))
285
91881986 286 (with-libgit2
ffc3fcad 287 (let* ((cache-exists? (openable-repository? cache-directory))
91881986 288 (repository (if cache-exists?
e3e1a7ba 289 (repository-open cache-directory)
ffc3fcad 290 (clone* url cache-directory))))
91881986 291 ;; Only fetch remote if it has not been cloned just before.
a78dcb3d
LC
292 (when (and cache-exists?
293 (not (reference-available? repository ref)))
c3574749
MO
294 (if auth-supported?
295 (let ((auth-method (and auth-supported?
296 (%make-auth-ssh-agent))))
297 (remote-fetch (remote-lookup repository "origin")
298 #:fetch-options (make-fetch-options auth-method)))
299 (remote-fetch (remote-lookup repository "origin"))))
60cbc6a8
LC
300 (when recursive?
301 (update-submodules repository #:log-port log-port))
37a6cdbf 302 (let ((oid (switch-to-ref repository canonical-ref)))
91881986
LC
303
304 ;; Reclaim file descriptors and memory mappings associated with
305 ;; REPOSITORY as soon as possible.
306 (when (module-defined? (resolve-interface '(git repository))
307 'repository-close!)
308 (repository-close! repository))
309
ffc3fcad 310 (values cache-directory (oid->string oid))))))
6b7b3ca9
MO
311
312(define* (latest-repository-commit store url
313 #:key
60cbc6a8 314 recursive?
35cb37ea 315 (log-port (%make-void-port "w"))
6b7b3ca9
MO
316 (cache-directory
317 (%repository-cache-directory))
37a6cdbf 318 (ref '(branch . "master")))
6b7b3ca9
MO
319 "Return two values: the content of the git repository at URL copied into a
320store directory and the sha1 of the top level commit in this directory. The
321reference to be checkout, once the repository is fetched, is specified by REF.
322REF is pair whose key is [branch | commit | tag] and value the associated
323data, respectively [<branch name> | <sha1> | <tag name>].
324
60cbc6a8
LC
325When RECURSIVE? is true, check out submodules as well, if any.
326
6b7b3ca9 327Git repositories are kept in the cache directory specified by
35cb37ea
LC
328%repository-cache-directory parameter.
329
330Log progress and checkout info to LOG-PORT."
91881986
LC
331 (define (dot-git? file stat)
332 (and (string=? (basename file) ".git")
60cbc6a8
LC
333 (or (eq? 'directory (stat:type stat))
334
335 ;; Submodule checkouts end up with a '.git' regular file that
336 ;; contains metadata about where their actual '.git' directory
337 ;; lives.
338 (and recursive?
339 (eq? 'regular (stat:type stat))))))
dfca2418 340
35cb37ea 341 (format log-port "updating checkout of '~a'...~%" url)
ffc3fcad
OP
342 (let*-values
343 (((checkout commit)
344 (update-cached-checkout url
60cbc6a8 345 #:recursive? recursive?
ffc3fcad
OP
346 #:ref ref
347 #:cache-directory
60cbc6a8
LC
348 (url-cache-directory url cache-directory
349 #:recursive?
350 recursive?)
351 #:log-port log-port))
ffc3fcad
OP
352 ((name)
353 (url+commit->name url commit)))
35cb37ea 354 (format log-port "retrieved commit ~a~%" commit)
91881986
LC
355 (values (add-to-store store name #t "sha256" checkout
356 #:select? (negate dot-git?))
357 commit)))
49ae3f6d 358
1d8b10d0
LC
359(define (print-git-error port key args default-printer)
360 (match args
361 (((? git-error? error) . _)
362 (format port (G_ "Git error: ~a~%")
363 (git-error-message error)))))
364
365(set-exception-printer! 'git-error print-git-error)
366
49ae3f6d 367\f
873f6f13
LC
368;;;
369;;; Commit difference.
370;;;
371
785af04a
LC
372(define* (commit-closure commit #:optional (visited (setq)))
373 "Return the closure of COMMIT as a set. Skip commits contained in VISITED,
374a set, and adjoin VISITED to the result."
873f6f13 375 (let loop ((commits (list commit))
785af04a 376 (visited visited))
873f6f13
LC
377 (match commits
378 (()
379 visited)
380 ((head . tail)
381 (if (set-contains? visited head)
382 (loop tail visited)
383 (loop (append (commit-parents head) tail)
384 (set-insert head visited)))))))
385
785af04a 386(define* (commit-difference new old #:optional (excluded '()))
873f6f13 387 "Return the list of commits between NEW and OLD, where OLD is assumed to be
785af04a
LC
388an ancestor of NEW. Exclude all the commits listed in EXCLUDED along with
389their ancestors.
873f6f13
LC
390
391Essentially, this computes the set difference between the closure of NEW and
392that of OLD."
393 (let loop ((commits (list new))
394 (result '())
785af04a 395 (visited (commit-closure old (list->setq excluded))))
873f6f13
LC
396 (match commits
397 (()
398 (reverse result))
399 ((head . tail)
400 (if (set-contains? visited head)
401 (loop tail result visited)
402 (loop (append (commit-parents head) tail)
403 (cons head result)
404 (set-insert head visited)))))))
405
406\f
49ae3f6d
LC
407;;;
408;;; Checkouts.
409;;;
410
b18f7234 411;; Representation of the "latest" checkout of a branch or a specific commit.
49ae3f6d
LC
412(define-record-type* <git-checkout>
413 git-checkout make-git-checkout
414 git-checkout?
415 (url git-checkout-url)
b18f7234 416 (branch git-checkout-branch (default "master"))
177fecb5 417 (commit git-checkout-commit (default #f)) ;#f | tag | commit
06fff484 418 (recursive? git-checkout-recursive? (default #f)))
49ae3f6d 419
06fff484 420(define* (latest-repository-commit* url #:key ref recursive? log-port)
a3d77c51
LC
421 ;; Monadic variant of 'latest-repository-commit'.
422 (lambda (store)
423 ;; The caller--e.g., (guix scripts build)--may not handle 'git-error' so
424 ;; translate it into '&message' conditions that we know will be properly
425 ;; handled.
426 (catch 'git-error
427 (lambda ()
428 (values (latest-repository-commit store url
06fff484
LC
429 #:ref ref
430 #:recursive? recursive?
431 #:log-port log-port)
a3d77c51
LC
432 store))
433 (lambda (key error . _)
434 (raise (condition
435 (&message
436 (message
437 (match ref
438 (('commit . commit)
439 (format #f (G_ "cannot fetch commit ~a from ~a: ~a")
440 commit url (git-error-message error)))
441 (('branch . branch)
442 (format #f (G_ "cannot fetch branch '~a' from ~a: ~a")
443 branch url (git-error-message error)))
444 (_
445 (format #f (G_ "Git failure while fetching ~a: ~a")
446 url (git-error-message error))))))))))))
49ae3f6d
LC
447
448(define-gexp-compiler (git-checkout-compiler (checkout <git-checkout>)
449 system target)
450 ;; "Compile" CHECKOUT by updating the local checkout and adding it to the
451 ;; store.
452 (match checkout
06fff484 453 (($ <git-checkout> url branch commit recursive?)
49ae3f6d 454 (latest-repository-commit* url
b18f7234 455 #:ref (if commit
177fecb5 456 `(tag-or-commit . ,commit)
b18f7234 457 `(branch . ,branch))
06fff484 458 #:recursive? recursive?
49ae3f6d 459 #:log-port (current-error-port)))))
60cbc6a8
LC
460
461;; Local Variables:
462;; eval: (put 'with-repository 'scheme-indent-function 2)
463;; End: