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