git.scm 30 KB

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