Commit | Line | Data |
---|---|---|
6b7b3ca9 | 1 | ;;; GNU Guix --- Functional package management for GNU |
c3574749 | 2 | ;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com> |
87d49346 | 3 | ;;; Copyright © 2018-2022 Ludovic Courtès <ludo@gnu.org> |
cb41c158 | 4 | ;;; Copyright © 2021 Kyle Meyer <kyle@kyleam.com> |
1dc3825e | 5 | ;;; Copyright © 2021 Marius Bakke <marius@gnu.org> |
9f526f5d | 6 | ;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be> |
6b7b3ca9 MO |
7 | ;;; |
8 | ;;; This file is part of GNU Guix. | |
9 | ;;; | |
10 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
11 | ;;; under the terms of the GNU General Public License as published by | |
12 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
13 | ;;; your option) any later version. | |
14 | ;;; | |
15 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
16 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 | ;;; GNU General Public License for more details. | |
19 | ;;; | |
20 | ;;; You should have received a copy of the GNU General Public License | |
21 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
22 | ||
23 | (define-module (guix git) | |
24 | #:use-module (git) | |
25 | #:use-module (git object) | |
59bb1ae3 | 26 | #:use-module (git submodule) |
a3d77c51 | 27 | #:use-module (guix i18n) |
6b7b3ca9 | 28 | #:use-module (guix base32) |
87b00013 | 29 | #:use-module (guix cache) |
ca719424 | 30 | #:use-module (gcrypt hash) |
87b00013 LC |
31 | #:use-module ((guix build utils) |
32 | #:select (mkdir-p delete-file-recursively)) | |
6b7b3ca9 MO |
33 | #:use-module (guix store) |
34 | #:use-module (guix utils) | |
49ae3f6d LC |
35 | #:use-module (guix records) |
36 | #:use-module (guix gexp) | |
9f526f5d SM |
37 | #:autoload (guix git-download) |
38 | (git-reference-url git-reference-commit git-reference-recursive?) | |
873f6f13 | 39 | #:use-module (guix sets) |
05f44c2d | 40 | #:use-module ((guix diagnostics) #:select (leave warning)) |
298f9d29 | 41 | #:use-module (guix progress) |
dce2cf31 | 42 | #:autoload (guix swh) (swh-download commit-id?) |
6b7b3ca9 | 43 | #:use-module (rnrs bytevectors) |
298f9d29 | 44 | #:use-module (ice-9 format) |
6b7b3ca9 | 45 | #:use-module (ice-9 match) |
87b00013 | 46 | #:use-module (ice-9 ftw) |
6b7b3ca9 | 47 | #:use-module (srfi srfi-1) |
91881986 | 48 | #:use-module (srfi srfi-11) |
87d49346 | 49 | #:use-module (srfi srfi-26) |
95bd9f65 LC |
50 | #:use-module (srfi srfi-34) |
51 | #:use-module (srfi srfi-35) | |
6b7b3ca9 | 52 | #:export (%repository-cache-directory |
bc041b3e LC |
53 | honor-system-x509-certificates! |
54 | ||
2fbbfe6f | 55 | url-cache-directory |
873f6f13 | 56 | with-repository |
69db2993 | 57 | with-git-error-handling |
e7827560 | 58 | false-if-git-not-found |
91881986 | 59 | update-cached-checkout |
053b10c3 | 60 | url+commit->name |
49ae3f6d | 61 | latest-repository-commit |
873f6f13 | 62 | commit-difference |
c098c11b | 63 | commit-relation |
87d49346 | 64 | commit-descendant? |
49ae3f6d | 65 | |
59ee1075 XC |
66 | remote-refs |
67 | ||
49ae3f6d LC |
68 | git-checkout |
69 | git-checkout? | |
70 | git-checkout-url | |
a063bac6 LC |
71 | git-checkout-branch |
72 | git-checkout-commit | |
9f526f5d SM |
73 | git-checkout-recursive? |
74 | ||
75 | git-reference->git-checkout)) | |
6b7b3ca9 MO |
76 | |
77 | (define %repository-cache-directory | |
e83b2b0f LC |
78 | (make-parameter (string-append (cache-directory #:ensure? #f) |
79 | "/checkouts"))) | |
6b7b3ca9 | 80 | |
bc041b3e LC |
81 | (define (honor-system-x509-certificates!) |
82 | "Use the system's X.509 certificates for Git checkouts over HTTPS. Honor | |
83 | the 'SSL_CERT_FILE' and 'SSL_CERT_DIR' environment variables." | |
84 | ;; On distros such as CentOS 7, /etc/ssl/certs contains only a couple of | |
85 | ;; files (instead of all the certificates) among which "ca-bundle.crt". On | |
86 | ;; other distros /etc/ssl/certs usually contains the whole set of | |
87 | ;; certificates along with "ca-certificates.crt". Try to choose the right | |
88 | ;; one. | |
89 | (let ((file (letrec-syntax ((choose | |
90 | (syntax-rules () | |
91 | ((_ file rest ...) | |
92 | (let ((f file)) | |
93 | (if (and f (file-exists? f)) | |
94 | f | |
95 | (choose rest ...)))) | |
96 | ((_) | |
97 | #f)))) | |
98 | (choose (getenv "SSL_CERT_FILE") | |
99 | "/etc/ssl/certs/ca-certificates.crt" | |
100 | "/etc/ssl/certs/ca-bundle.crt"))) | |
101 | (directory (or (getenv "SSL_CERT_DIR") "/etc/ssl/certs"))) | |
102 | (and (or file | |
103 | (and=> (stat directory #f) | |
104 | (lambda (st) | |
105 | (> (stat:nlink st) 2)))) | |
106 | (begin | |
107 | (set-tls-certificate-locations! directory file) | |
108 | #t)))) | |
109 | ||
110 | (define %certificates-initialized? | |
111 | ;; Whether 'honor-system-x509-certificates!' has already been called. | |
112 | #f) | |
113 | ||
6b7b3ca9 | 114 | (define-syntax-rule (with-libgit2 thunk ...) |
b02469d2 MO |
115 | (begin |
116 | ;; XXX: The right thing to do would be to call (libgit2-shutdown) here, | |
117 | ;; but pointer finalizers used in guile-git may be called after shutdown, | |
118 | ;; resulting in a segfault. Hence, let's skip shutdown call for now. | |
119 | (libgit2-init!) | |
bc041b3e LC |
120 | (unless %certificates-initialized? |
121 | (honor-system-x509-certificates!) | |
122 | (set! %certificates-initialized? #t)) | |
b02469d2 | 123 | thunk ...)) |
6b7b3ca9 MO |
124 | |
125 | (define* (url-cache-directory url | |
126 | #:optional (cache-directory | |
60cbc6a8 LC |
127 | (%repository-cache-directory)) |
128 | #:key recursive?) | |
6b7b3ca9 MO |
129 | "Return the directory associated to URL in %repository-cache-directory." |
130 | (string-append | |
131 | cache-directory "/" | |
60cbc6a8 LC |
132 | (bytevector->base32-string |
133 | (sha256 (string->utf8 (if recursive? | |
134 | (string-append "R:" url) | |
135 | url)))))) | |
6b7b3ca9 | 136 | |
298f9d29 LC |
137 | (define (show-progress progress) |
138 | "Display a progress bar as we fetch Git code. PROGRESS is an | |
139 | <indexer-progress> record from (git)." | |
140 | (define total | |
141 | (indexer-progress-total-objects progress)) | |
142 | ||
143 | (define hundredth | |
144 | (match (quotient (indexer-progress-total-objects progress) 100) | |
145 | (0 1) | |
146 | (x x))) | |
147 | ||
148 | (define-values (done label) | |
149 | (if (< (indexer-progress-received-objects progress) total) | |
150 | (values (indexer-progress-received-objects progress) | |
151 | (G_ "receiving objects")) | |
152 | (values (indexer-progress-indexed-objects progress) | |
153 | (G_ "indexing objects")))) | |
154 | ||
155 | (define % | |
156 | (* 100. (/ done total))) | |
157 | ||
158 | (when (and (< % 100) (zero? (modulo done hundredth))) | |
159 | (erase-current-line (current-error-port)) | |
160 | (let ((width (max (- (current-terminal-columns) | |
161 | (string-length label) 7) | |
162 | 3))) | |
163 | (format (current-error-port) "~a ~3,d% ~a" | |
164 | label (inexact->exact (round %)) | |
165 | (progress-bar % width))) | |
166 | (force-output (current-error-port))) | |
167 | ||
168 | (when (= % 100.) | |
169 | ;; We're done, erase the line. | |
170 | (erase-current-line (current-error-port)) | |
171 | (force-output (current-error-port))) | |
172 | ||
173 | ;; Return true to indicate that we should go on. | |
174 | #t) | |
175 | ||
176 | (define (make-default-fetch-options) | |
177 | "Return the default fetch options." | |
178 | (let ((auth-method (%make-auth-ssh-agent))) | |
8425a9b6 LC |
179 | ;; The #:transfer-progress and #:proxy-url options appeared in Guile-Git |
180 | ;; 0.4.0. Omit them when using an older version. | |
298f9d29 LC |
181 | (catch 'wrong-number-of-args |
182 | (lambda () | |
183 | (make-fetch-options auth-method | |
8425a9b6 LC |
184 | ;; Guile-Git doesn't distinguish between these. |
185 | #:proxy-url (or (getenv "http_proxy") | |
186 | (getenv "https_proxy")) | |
298f9d29 LC |
187 | #:transfer-progress |
188 | (and (isatty? (current-error-port)) | |
189 | show-progress))) | |
190 | (lambda args | |
191 | (make-fetch-options auth-method))))) | |
192 | ||
05f44c2d LC |
193 | (define GITERR_HTTP |
194 | ;; Guile-Git <= 0.5.2 lacks this constant. | |
195 | (let ((errors (resolve-interface '(git errors)))) | |
196 | (if (module-defined? errors 'GITERR_HTTP) | |
197 | (module-ref errors 'GITERR_HTTP) | |
198 | 34))) | |
199 | ||
6b7b3ca9 MO |
200 | (define (clone* url directory) |
201 | "Clone git repository at URL into DIRECTORY. Upon failure, | |
202 | make sure no empty directory is left behind." | |
203 | (with-throw-handler #t | |
204 | (lambda () | |
205 | (mkdir-p directory) | |
195f0d05 | 206 | |
973b8af7 LC |
207 | (clone url directory |
208 | (make-clone-options | |
209 | #:fetch-options (make-default-fetch-options)))) | |
6b7b3ca9 MO |
210 | (lambda _ |
211 | (false-if-exception (rmdir directory))))) | |
212 | ||
6b7b3ca9 MO |
213 | (define (url+commit->name url sha1) |
214 | "Return the string \"<REPO-NAME>-<SHA1:7>\" where REPO-NAME is the name of | |
215 | the git repository, extracted from URL and SHA1:7 the seven first digits | |
216 | of SHA1 string." | |
217 | (string-append | |
218 | (string-replace-substring | |
219 | (last (string-split url #\/)) ".git" "") | |
220 | "-" (string-take sha1 7))) | |
221 | ||
1c058c38 LC |
222 | (define (resolve-reference repository ref) |
223 | "Resolve the branch, commit or tag specified by REF, and return the | |
224 | corresponding Git object." | |
225 | (let resolve ((ref ref)) | |
226 | (match ref | |
227 | (('branch . branch) | |
228 | (let ((oid (reference-target | |
229 | (branch-lookup repository branch BRANCH-REMOTE)))) | |
230 | (object-lookup repository oid))) | |
cb41c158 KM |
231 | (('symref . symref) |
232 | (let ((oid (reference-name->oid repository symref))) | |
233 | (object-lookup repository oid))) | |
1c058c38 LC |
234 | (('commit . commit) |
235 | (let ((len (string-length commit))) | |
236 | ;; 'object-lookup-prefix' appeared in Guile-Git in Mar. 2018, so we | |
237 | ;; can't be sure it's available. Furthermore, 'string->oid' used to | |
238 | ;; read out-of-bounds when passed a string shorter than 40 chars, | |
239 | ;; which is why we delay calls to it below. | |
240 | (if (< len 40) | |
59bb1ae3 | 241 | (object-lookup-prefix repository (string->oid commit) len) |
1c058c38 LC |
242 | (object-lookup repository (string->oid commit))))) |
243 | (('tag-or-commit . str) | |
1dc3825e MB |
244 | (cond ((and (string-contains str "-g") |
245 | (match (string-split str #\-) | |
246 | ((version ... revision g+commit) | |
247 | (if (and (> (string-length g+commit) 4) | |
248 | (string-every char-set:digit revision) | |
249 | (string-every char-set:hex-digit | |
250 | (string-drop g+commit 1))) | |
16ef7b49 MB |
251 | ;; Looks like a 'git describe' style ID, like |
252 | ;; v1.3.0-7-gaa34d4d28d. | |
1dc3825e MB |
253 | (string-drop g+commit 1) |
254 | #f)) | |
255 | (_ #f))) | |
1dc3825e MB |
256 | => (lambda (commit) (resolve `(commit . ,commit)))) |
257 | ((or (> (string-length str) 40) | |
258 | (not (string-every char-set:hex-digit str))) | |
259 | (resolve `(tag . ,str))) ;definitely a tag | |
260 | (else | |
261 | (catch 'git-error | |
262 | (lambda () | |
263 | (resolve `(tag . ,str))) | |
264 | (lambda _ | |
265 | ;; There's no such tag, so it must be a commit ID. | |
266 | (resolve `(commit . ,str))))))) | |
1c058c38 LC |
267 | (('tag . tag) |
268 | (let ((oid (reference-name->oid repository | |
269 | (string-append "refs/tags/" tag)))) | |
270 | ;; OID may point to a "tag" object, but it can also point directly | |
271 | ;; to a "commit" object, as surprising as it may seem. Return that | |
272 | ;; object, whatever that is. | |
273 | (object-lookup repository oid)))))) | |
274 | ||
6b7b3ca9 | 275 | (define (switch-to-ref repository ref) |
91881986 LC |
276 | "Switch to REPOSITORY's branch, commit or tag specified by REF. Return the |
277 | OID (roughly the commit hash) corresponding to REF." | |
95bd9f65 | 278 | (define obj |
1c058c38 | 279 | (resolve-reference repository ref)) |
95bd9f65 | 280 | |
91881986 LC |
281 | (reset repository obj RESET_HARD) |
282 | (object-id obj)) | |
283 | ||
60cbc6a8 LC |
284 | (define (call-with-repository directory proc) |
285 | (let ((repository #f)) | |
286 | (dynamic-wind | |
287 | (lambda () | |
288 | (set! repository (repository-open directory))) | |
289 | (lambda () | |
290 | (proc repository)) | |
291 | (lambda () | |
292 | (repository-close! repository))))) | |
293 | ||
294 | (define-syntax-rule (with-repository directory repository exp ...) | |
295 | "Open the repository at DIRECTORY and bind REPOSITORY to it within the | |
296 | dynamic extent of EXP." | |
297 | (call-with-repository directory | |
298 | (lambda (repository) exp ...))) | |
299 | ||
69db2993 LC |
300 | (define (report-git-error error) |
301 | "Report the given Guile-Git error." | |
302 | ;; Prior to Guile-Git commit b6b2760c2fd6dfaa5c0fedb43eeaff06166b3134, | |
303 | ;; errors would be represented by integers. | |
304 | (match error | |
305 | ((? integer? error) ;old Guile-Git | |
306 | (leave (G_ "Git error ~a~%") error)) | |
307 | ((? git-error? error) ;new Guile-Git | |
308 | (leave (G_ "Git error: ~a~%") (git-error-message error))))) | |
309 | ||
310 | (define-syntax-rule (with-git-error-handling body ...) | |
311 | (catch 'git-error | |
312 | (lambda () | |
313 | body ...) | |
314 | (lambda (key err) | |
315 | (report-git-error err)))) | |
316 | ||
60cbc6a8 | 317 | (define* (update-submodules repository |
fab8ab76 LC |
318 | #:key (log-port (current-error-port)) |
319 | (fetch-options #f)) | |
60cbc6a8 | 320 | "Update the submodules of REPOSITORY, a Git repository object." |
59bb1ae3 LC |
321 | (for-each (lambda (name) |
322 | (let ((submodule (submodule-lookup repository name))) | |
323 | (format log-port (G_ "updating submodule '~a'...~%") | |
324 | name) | |
fab8ab76 LC |
325 | (submodule-update submodule |
326 | #:fetch-options fetch-options) | |
59bb1ae3 LC |
327 | |
328 | ;; Recurse in SUBMODULE. | |
329 | (let ((directory (string-append | |
330 | (repository-working-directory repository) | |
331 | "/" (submodule-path submodule)))) | |
332 | (with-repository directory repository | |
333 | (update-submodules repository | |
fab8ab76 | 334 | #:fetch-options fetch-options |
59bb1ae3 LC |
335 | #:log-port log-port))))) |
336 | (repository-submodules repository))) | |
60cbc6a8 | 337 | |
1fd7de45 LC |
338 | (define-syntax-rule (false-if-git-not-found exp) |
339 | "Evaluate EXP, returning #false if a GIT_ENOTFOUND error is raised." | |
340 | (catch 'git-error | |
341 | (lambda () | |
342 | exp) | |
343 | (lambda (key error . rest) | |
344 | (if (= GIT_ENOTFOUND (git-error-code error)) | |
345 | #f | |
346 | (apply throw key error rest))))) | |
347 | ||
a78dcb3d LC |
348 | (define (reference-available? repository ref) |
349 | "Return true if REF, a reference such as '(commit . \"cabba9e\"), is | |
350 | definitely available in REPOSITORY, false otherwise." | |
351 | (match ref | |
dce2cf31 LC |
352 | ((or ('commit . commit) |
353 | ('tag-or-commit . (? commit-id? commit))) | |
cde3a69a LC |
354 | (let ((len (string-length commit)) |
355 | (oid (string->oid commit))) | |
356 | (false-if-git-not-found | |
357 | (->bool (if (< len 40) | |
358 | (object-lookup-prefix repository oid len OBJ-COMMIT) | |
359 | (commit-lookup repository oid)))))) | |
a78dcb3d LC |
360 | (_ |
361 | #f))) | |
362 | ||
05f44c2d LC |
363 | (define (clone-from-swh url tag-or-commit output) |
364 | "Attempt to clone TAG-OR-COMMIT (a string), which originates from URL, using | |
365 | a copy archived at Software Heritage." | |
366 | (call-with-temporary-directory | |
367 | (lambda (bare) | |
368 | (and (swh-download url tag-or-commit bare | |
369 | #:archive-type 'git-bare) | |
370 | (let ((repository (clone* bare output))) | |
371 | (remote-set-url! repository "origin" url) | |
372 | repository))))) | |
373 | ||
374 | (define (clone/swh-fallback url ref cache-directory) | |
375 | "Like 'clone', but fallback to Software Heritage if the repository cannot be | |
376 | found at URL." | |
377 | (define (inaccessible-url-error? err) | |
378 | (let ((class (git-error-class err)) | |
379 | (code (git-error-code err))) | |
380 | (or (= class GITERR_HTTP) ;404 or similar | |
381 | (= class GITERR_NET)))) ;unknown host, etc. | |
382 | ||
383 | (catch 'git-error | |
384 | (lambda () | |
385 | (clone* url cache-directory)) | |
386 | (lambda (key err) | |
387 | (match ref | |
388 | (((or 'commit 'tag-or-commit) . commit) | |
389 | (if (inaccessible-url-error? err) | |
390 | (or (clone-from-swh url commit cache-directory) | |
391 | (begin | |
392 | (warning (G_ "revision ~a of ~a \ | |
393 | could not be fetched from Software Heritage~%") | |
394 | commit url) | |
395 | (throw key err))) | |
396 | (throw key err))) | |
397 | (_ (throw key err)))))) | |
398 | ||
87b00013 LC |
399 | (define cached-checkout-expiration |
400 | ;; Return the expiration time procedure for a cached checkout. | |
401 | ;; TODO: Honor $GUIX_GIT_CACHE_EXPIRATION. | |
402 | ||
403 | ;; Use the mtime rather than the atime to cope with file systems mounted | |
404 | ;; with 'noatime'. | |
405 | (file-expiration-time (* 90 24 3600) stat:mtime)) | |
406 | ||
407 | (define %checkout-cache-cleanup-period | |
408 | ;; Period for the removal of expired cached checkouts. | |
409 | (* 5 24 3600)) | |
410 | ||
411 | (define (delete-checkout directory) | |
412 | "Delete DIRECTORY recursively, in an atomic fashion." | |
413 | (let ((trashed (string-append directory ".trashed"))) | |
414 | (rename-file directory trashed) | |
415 | (delete-file-recursively trashed))) | |
416 | ||
91881986 LC |
417 | (define* (update-cached-checkout url |
418 | #:key | |
cb41c158 | 419 | (ref '()) |
60cbc6a8 | 420 | recursive? |
a620c9d5 | 421 | (check-out? #t) |
8d1d5657 | 422 | starting-commit |
60cbc6a8 | 423 | (log-port (%make-void-port "w")) |
91881986 | 424 | (cache-directory |
ffc3fcad | 425 | (url-cache-directory |
60cbc6a8 LC |
426 | url (%repository-cache-directory) |
427 | #:recursive? recursive?))) | |
8d1d5657 | 428 | "Update the cached checkout of URL to REF in CACHE-DIRECTORY. Return three |
91881986 | 429 | values: the cache directory name, and the SHA1 commit (a string) corresponding |
8d1d5657 LC |
430 | to REF, and the relation of the new commit relative to STARTING-COMMIT (if |
431 | provided) as returned by 'commit-relation'. | |
91881986 | 432 | |
c4c2449f LC |
433 | REF is pair whose key is [branch | commit | tag | tag-or-commit ] and value |
434 | the associated data: [<branch name> | <sha1> | <tag name> | <string>]. | |
cb41c158 | 435 | If REF is the empty list, the remote HEAD is used. |
60cbc6a8 | 436 | |
a620c9d5 LC |
437 | When RECURSIVE? is true, check out submodules as well, if any. |
438 | ||
439 | When CHECK-OUT? is true, reset the cached working tree to REF; otherwise leave | |
440 | it unchanged." | |
87b00013 LC |
441 | (define (cache-entries directory) |
442 | (filter-map (match-lambda | |
443 | ((or "." "..") | |
444 | #f) | |
445 | (file | |
446 | (string-append directory "/" file))) | |
447 | (or (scandir directory) '()))) | |
448 | ||
37a6cdbf LC |
449 | (define canonical-ref |
450 | ;; We used to require callers to specify "origin/" for each branch, which | |
451 | ;; made little sense since the cache should be transparent to them. So | |
452 | ;; here we append "origin/" if it's missing and otherwise keep it. | |
453 | (match ref | |
cb41c158 | 454 | (() '(symref . "refs/remotes/origin/HEAD")) |
37a6cdbf LC |
455 | (('branch . branch) |
456 | `(branch . ,(if (string-prefix? "origin/" branch) | |
457 | branch | |
458 | (string-append "origin/" branch)))) | |
459 | (_ ref))) | |
460 | ||
91881986 | 461 | (with-libgit2 |
ffc3fcad | 462 | (let* ((cache-exists? (openable-repository? cache-directory)) |
91881986 | 463 | (repository (if cache-exists? |
e3e1a7ba | 464 | (repository-open cache-directory) |
05f44c2d | 465 | (clone/swh-fallback url ref cache-directory)))) |
91881986 | 466 | ;; Only fetch remote if it has not been cloned just before. |
a78dcb3d LC |
467 | (when (and cache-exists? |
468 | (not (reference-available? repository ref))) | |
973b8af7 LC |
469 | (remote-fetch (remote-lookup repository "origin") |
470 | #:fetch-options (make-default-fetch-options))) | |
60cbc6a8 | 471 | (when recursive? |
fab8ab76 LC |
472 | (update-submodules repository #:log-port log-port |
473 | #:fetch-options (make-default-fetch-options))) | |
8d1d5657 LC |
474 | |
475 | ;; Note: call 'commit-relation' from here because it's more efficient | |
476 | ;; than letting users re-open the checkout later on. | |
a620c9d5 LC |
477 | (let* ((oid (if check-out? |
478 | (switch-to-ref repository canonical-ref) | |
479 | (object-id | |
480 | (resolve-reference repository canonical-ref)))) | |
8d1d5657 LC |
481 | (new (and starting-commit |
482 | (commit-lookup repository oid))) | |
483 | (old (and starting-commit | |
1fd7de45 LC |
484 | (false-if-git-not-found |
485 | (commit-lookup repository | |
486 | (string->oid starting-commit))))) | |
8d1d5657 | 487 | (relation (and starting-commit |
1fd7de45 LC |
488 | (if old |
489 | (commit-relation old new) | |
490 | 'unrelated)))) | |
91881986 LC |
491 | |
492 | ;; Reclaim file descriptors and memory mappings associated with | |
493 | ;; REPOSITORY as soon as possible. | |
59bb1ae3 | 494 | (repository-close! repository) |
91881986 | 495 | |
baf0a428 LC |
496 | ;; Update CACHE-DIRECTORY's mtime to so the cache logic sees it. |
497 | (match (gettimeofday) | |
498 | ((seconds . microseconds) | |
499 | (let ((nanoseconds (* 1000 microseconds))) | |
500 | (utime cache-directory | |
501 | seconds seconds | |
502 | nanoseconds nanoseconds)))) | |
503 | ||
87b00013 LC |
504 | ;; When CACHE-DIRECTORY is a sub-directory of the default cache |
505 | ;; directory, remove expired checkouts that are next to it. | |
506 | (let ((parent (dirname cache-directory))) | |
507 | (when (string=? parent (%repository-cache-directory)) | |
508 | (maybe-remove-expired-cache-entries parent cache-entries | |
509 | #:entry-expiration | |
510 | cached-checkout-expiration | |
511 | #:delete-entry delete-checkout | |
512 | #:cleanup-period | |
513 | %checkout-cache-cleanup-period))) | |
514 | ||
8d1d5657 | 515 | (values cache-directory (oid->string oid) relation))))) |
6b7b3ca9 MO |
516 | |
517 | (define* (latest-repository-commit store url | |
518 | #:key | |
60cbc6a8 | 519 | recursive? |
35cb37ea | 520 | (log-port (%make-void-port "w")) |
6b7b3ca9 MO |
521 | (cache-directory |
522 | (%repository-cache-directory)) | |
cb41c158 | 523 | (ref '())) |
6b7b3ca9 MO |
524 | "Return two values: the content of the git repository at URL copied into a |
525 | store directory and the sha1 of the top level commit in this directory. The | |
526 | reference to be checkout, once the repository is fetched, is specified by REF. | |
527 | REF is pair whose key is [branch | commit | tag] and value the associated | |
cb41c158 KM |
528 | data, respectively [<branch name> | <sha1> | <tag name>]. If REF is the empty |
529 | list, the remote HEAD is used. | |
6b7b3ca9 | 530 | |
60cbc6a8 LC |
531 | When RECURSIVE? is true, check out submodules as well, if any. |
532 | ||
6b7b3ca9 | 533 | Git repositories are kept in the cache directory specified by |
35cb37ea LC |
534 | %repository-cache-directory parameter. |
535 | ||
536 | Log progress and checkout info to LOG-PORT." | |
91881986 LC |
537 | (define (dot-git? file stat) |
538 | (and (string=? (basename file) ".git") | |
60cbc6a8 LC |
539 | (or (eq? 'directory (stat:type stat)) |
540 | ||
541 | ;; Submodule checkouts end up with a '.git' regular file that | |
542 | ;; contains metadata about where their actual '.git' directory | |
543 | ;; lives. | |
544 | (and recursive? | |
545 | (eq? 'regular (stat:type stat)))))) | |
dfca2418 | 546 | |
35cb37ea | 547 | (format log-port "updating checkout of '~a'...~%" url) |
ffc3fcad | 548 | (let*-values |
8d1d5657 | 549 | (((checkout commit _) |
ffc3fcad | 550 | (update-cached-checkout url |
60cbc6a8 | 551 | #:recursive? recursive? |
ffc3fcad OP |
552 | #:ref ref |
553 | #:cache-directory | |
60cbc6a8 LC |
554 | (url-cache-directory url cache-directory |
555 | #:recursive? | |
556 | recursive?) | |
557 | #:log-port log-port)) | |
ffc3fcad OP |
558 | ((name) |
559 | (url+commit->name url commit))) | |
35cb37ea | 560 | (format log-port "retrieved commit ~a~%" commit) |
91881986 LC |
561 | (values (add-to-store store name #t "sha256" checkout |
562 | #:select? (negate dot-git?)) | |
563 | commit))) | |
49ae3f6d | 564 | |
1d8b10d0 LC |
565 | (define (print-git-error port key args default-printer) |
566 | (match args | |
567 | (((? git-error? error) . _) | |
568 | (format port (G_ "Git error: ~a~%") | |
569 | (git-error-message error))))) | |
570 | ||
571 | (set-exception-printer! 'git-error print-git-error) | |
572 | ||
49ae3f6d | 573 | \f |
873f6f13 LC |
574 | ;;; |
575 | ;;; Commit difference. | |
576 | ;;; | |
577 | ||
785af04a LC |
578 | (define* (commit-closure commit #:optional (visited (setq))) |
579 | "Return the closure of COMMIT as a set. Skip commits contained in VISITED, | |
580 | a set, and adjoin VISITED to the result." | |
873f6f13 | 581 | (let loop ((commits (list commit)) |
785af04a | 582 | (visited visited)) |
873f6f13 LC |
583 | (match commits |
584 | (() | |
585 | visited) | |
586 | ((head . tail) | |
587 | (if (set-contains? visited head) | |
588 | (loop tail visited) | |
589 | (loop (append (commit-parents head) tail) | |
590 | (set-insert head visited))))))) | |
591 | ||
785af04a | 592 | (define* (commit-difference new old #:optional (excluded '())) |
873f6f13 | 593 | "Return the list of commits between NEW and OLD, where OLD is assumed to be |
785af04a LC |
594 | an ancestor of NEW. Exclude all the commits listed in EXCLUDED along with |
595 | their ancestors. | |
873f6f13 LC |
596 | |
597 | Essentially, this computes the set difference between the closure of NEW and | |
598 | that of OLD." | |
599 | (let loop ((commits (list new)) | |
600 | (result '()) | |
72357e21 LC |
601 | (visited (fold commit-closure |
602 | (setq) | |
603 | (cons old excluded)))) | |
873f6f13 LC |
604 | (match commits |
605 | (() | |
606 | (reverse result)) | |
607 | ((head . tail) | |
608 | (if (set-contains? visited head) | |
609 | (loop tail result visited) | |
610 | (loop (append (commit-parents head) tail) | |
611 | (cons head result) | |
612 | (set-insert head visited))))))) | |
613 | ||
c098c11b LC |
614 | (define (commit-relation old new) |
615 | "Return a symbol denoting the relation between OLD and NEW, two commit | |
616 | objects: 'ancestor (meaning that OLD is an ancestor of NEW), 'descendant, or | |
617 | 'unrelated, or 'self (OLD and NEW are the same commit)." | |
618 | (if (eq? old new) | |
619 | 'self | |
620 | (let ((newest (commit-closure new))) | |
621 | (if (set-contains? newest old) | |
622 | 'ancestor | |
623 | (let* ((seen (list->setq (commit-parents new))) | |
624 | (oldest (commit-closure old seen))) | |
625 | (if (set-contains? oldest new) | |
626 | 'descendant | |
627 | 'unrelated)))))) | |
87d49346 LC |
628 | |
629 | (define (commit-descendant? new old) | |
630 | "Return true if NEW is the descendant of one of OLD, a list of commits. | |
631 | ||
632 | When the expected result is likely #t, this is faster than using | |
633 | 'commit-relation' since fewer commits need to be traversed." | |
634 | (let ((old (list->setq old))) | |
635 | (let loop ((commits (list new)) | |
636 | (visited (setq))) | |
637 | (match commits | |
638 | (() | |
639 | #f) | |
640 | (_ | |
641 | ;; Perform a breadth-first search as this is likely going to | |
642 | ;; terminate more quickly than a depth-first search. | |
643 | (let ((commits (remove (cut set-contains? visited <>) commits))) | |
644 | (or (any (cut set-contains? old <>) commits) | |
645 | (loop (append-map commit-parents commits) | |
646 | (fold set-insert visited commits))))))))) | |
647 | ||
59ee1075 XC |
648 | \f |
649 | ;; | |
650 | ;;; Remote operations. | |
651 | ;;; | |
652 | ||
653 | (define* (remote-refs url #:key tags?) | |
654 | "Return the list of references advertised at Git repository URL. If TAGS? | |
655 | is true, limit to only refs/tags." | |
656 | (define (ref? ref) | |
657 | ;; Like `git ls-remote --refs', only show actual references. | |
658 | (and (string-prefix? "refs/" ref) | |
659 | (not (string-suffix? "^{}" ref)))) | |
660 | ||
661 | (define (tag? ref) | |
662 | (string-prefix? "refs/tags/" ref)) | |
663 | ||
664 | (define (include? ref) | |
665 | (and (ref? ref) | |
666 | (or (not tags?) (tag? ref)))) | |
667 | ||
668 | (define (remote-head->ref remote) | |
669 | (let ((name (remote-head-name remote))) | |
670 | (and (include? name) | |
671 | name))) | |
672 | ||
673 | (with-libgit2 | |
674 | (call-with-temporary-directory | |
675 | (lambda (cache-directory) | |
676 | (let* ((repository (repository-init cache-directory)) | |
677 | ;; Create an in-memory remote so we don't touch disk. | |
678 | (remote (remote-create-anonymous repository url))) | |
679 | (remote-connect remote) | |
680 | ||
681 | (let* ((remote-heads (remote-ls remote)) | |
682 | (refs (filter-map remote-head->ref remote-heads))) | |
683 | ;; Wait until we're finished with the repository before closing it. | |
684 | (remote-disconnect remote) | |
685 | (repository-close! repository) | |
686 | refs)))))) | |
c098c11b | 687 | |
873f6f13 | 688 | \f |
49ae3f6d LC |
689 | ;;; |
690 | ;;; Checkouts. | |
691 | ;;; | |
692 | ||
b18f7234 | 693 | ;; Representation of the "latest" checkout of a branch or a specific commit. |
49ae3f6d LC |
694 | (define-record-type* <git-checkout> |
695 | git-checkout make-git-checkout | |
696 | git-checkout? | |
697 | (url git-checkout-url) | |
cb41c158 | 698 | (branch git-checkout-branch (default #f)) |
177fecb5 | 699 | (commit git-checkout-commit (default #f)) ;#f | tag | commit |
06fff484 | 700 | (recursive? git-checkout-recursive? (default #f))) |
49ae3f6d | 701 | |
9f526f5d SM |
702 | (define (git-reference->git-checkout reference) |
703 | "Convert the <git-reference> REFERENCE to an equivalent <git-checkout>." | |
704 | (git-checkout | |
705 | (url (git-reference-url reference)) | |
706 | (commit (git-reference-commit reference)) | |
707 | (recursive? (git-reference-recursive? reference)))) | |
708 | ||
06fff484 | 709 | (define* (latest-repository-commit* url #:key ref recursive? log-port) |
a3d77c51 LC |
710 | ;; Monadic variant of 'latest-repository-commit'. |
711 | (lambda (store) | |
712 | ;; The caller--e.g., (guix scripts build)--may not handle 'git-error' so | |
713 | ;; translate it into '&message' conditions that we know will be properly | |
714 | ;; handled. | |
715 | (catch 'git-error | |
716 | (lambda () | |
717 | (values (latest-repository-commit store url | |
06fff484 LC |
718 | #:ref ref |
719 | #:recursive? recursive? | |
720 | #:log-port log-port) | |
a3d77c51 LC |
721 | store)) |
722 | (lambda (key error . _) | |
723 | (raise (condition | |
724 | (&message | |
725 | (message | |
726 | (match ref | |
727 | (('commit . commit) | |
728 | (format #f (G_ "cannot fetch commit ~a from ~a: ~a") | |
729 | commit url (git-error-message error))) | |
730 | (('branch . branch) | |
731 | (format #f (G_ "cannot fetch branch '~a' from ~a: ~a") | |
732 | branch url (git-error-message error))) | |
733 | (_ | |
734 | (format #f (G_ "Git failure while fetching ~a: ~a") | |
735 | url (git-error-message error)))))))))))) | |
49ae3f6d LC |
736 | |
737 | (define-gexp-compiler (git-checkout-compiler (checkout <git-checkout>) | |
738 | system target) | |
739 | ;; "Compile" CHECKOUT by updating the local checkout and adding it to the | |
740 | ;; store. | |
741 | (match checkout | |
06fff484 | 742 | (($ <git-checkout> url branch commit recursive?) |
49ae3f6d | 743 | (latest-repository-commit* url |
cb41c158 KM |
744 | #:ref (cond (commit |
745 | `(tag-or-commit . ,commit)) | |
746 | (branch | |
747 | `(branch . ,branch)) | |
748 | (else '())) | |
06fff484 | 749 | #:recursive? recursive? |
49ae3f6d | 750 | #:log-port (current-error-port))))) |
60cbc6a8 LC |
751 | |
752 | ;; Local Variables: | |
753 | ;; eval: (put 'with-repository 'scheme-indent-function 2) | |
754 | ;; End: |