You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

535 lines
21 KiB

Switch to Guile-Gcrypt. This removes (guix hash) and (guix pk-crypto), which now live as part of Guile-Gcrypt (version 0.1.0.) * guix/gcrypt.scm, guix/hash.scm, guix/pk-crypto.scm, tests/hash.scm, tests/pk-crypto.scm: Remove. * configure.ac: Test for Guile-Gcrypt. Remove LIBGCRYPT and LIBGCRYPT_LIBDIR assignments. * m4/guix.m4 (GUIX_ASSERT_LIBGCRYPT_USABLE): Remove. * README: Add Guile-Gcrypt to the dependencies; move libgcrypt as "required unless --disable-daemon". * doc/guix.texi (Requirements): Likewise. * gnu/packages/bash.scm, guix/derivations.scm, guix/docker.scm, guix/git.scm, guix/http-client.scm, guix/import/cpan.scm, guix/import/cran.scm, guix/import/crate.scm, guix/import/elpa.scm, guix/import/gnu.scm, guix/import/hackage.scm, guix/import/texlive.scm, guix/import/utils.scm, guix/nar.scm, guix/pki.scm, guix/scripts/archive.scm, guix/scripts/authenticate.scm, guix/scripts/download.scm, guix/scripts/hash.scm, guix/scripts/pack.scm, guix/scripts/publish.scm, guix/scripts/refresh.scm, guix/scripts/substitute.scm, guix/store.scm, guix/store/deduplication.scm, guix/tests.scm, tests/base32.scm, tests/builders.scm, tests/challenge.scm, tests/cpan.scm, tests/crate.scm, tests/derivations.scm, tests/gem.scm, tests/nar.scm, tests/opam.scm, tests/pki.scm, tests/publish.scm, tests/pypi.scm, tests/store-deduplication.scm, tests/store.scm, tests/substitute.scm: Adjust imports. * gnu/system/vm.scm: Likewise. (guile-sqlite3&co): Rename to... (gcrypt-sqlite3&co): ... this. Add GUILE-GCRYPT. (expression->derivation-in-linux-vm)[config]: Remove. (iso9660-image)[config]: Remove. (qemu-image)[config]: Remove. (system-docker-image)[config]: Remove. * guix/scripts/pack.scm: Adjust imports. (guile-sqlite3&co): Rename to... (gcrypt-sqlite3&co): ... this. Add GUILE-GCRYPT. (self-contained-tarball)[build]: Call 'make-config.scm' without #:libgcrypt argument. (squashfs-image)[libgcrypt]: Remove. [build]: Call 'make-config.scm' without #:libgcrypt. (docker-image)[config, json]: Remove. [build]: Add GUILE-GCRYPT to the extensions Remove (guix config) from the imported modules. * guix/self.scm (specification->package): Remove "libgcrypt", add "guile-gcrypt". (compiled-guix): Remove #:libgcrypt. [guile-gcrypt]: New variable. [dependencies]: Add it. [*core-modules*]: Remove #:libgcrypt from 'make-config.scm' call. Add #:extensions. [*config*]: Remove #:libgcrypt from 'make-config.scm' call. (%dependency-variables): Remove %libgcrypt. (make-config.scm): Remove #:libgcrypt. * build-aux/build-self.scm (guile-gcrypt): New variable. (make-config.scm): Remove #:libgcrypt. (build-program)[fake-gcrypt-hash]: New variable. Add (gcrypt hash) to the imported modules. Adjust load path assignments. * gnu/packages/package-management.scm (guix)[propagated-inputs]: Add GUILE-GCRYPT. [arguments]: In 'wrap-program' phase, add GUILE-GCRYPT to the search path.
3 years ago
  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
  3. ;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
  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. (define-module (guix git)
  20. #:use-module (git)
  21. #:use-module (git object)
  22. #:use-module (guix i18n)
  23. #:use-module (guix base32)
  24. #:use-module (gcrypt hash)
  25. #:use-module ((guix build utils) #:select (mkdir-p))
  26. #:use-module (guix store)
  27. #:use-module (guix utils)
  28. #:use-module (guix records)
  29. #:use-module (guix gexp)
  30. #:use-module (guix sets)
  31. #:use-module ((guix diagnostics) #:select (leave))
  32. #:use-module (rnrs bytevectors)
  33. #:use-module (ice-9 match)
  34. #:use-module (srfi srfi-1)
  35. #:use-module (srfi srfi-11)
  36. #:use-module (srfi srfi-34)
  37. #:use-module (srfi srfi-35)
  38. #:export (%repository-cache-directory
  39. honor-system-x509-certificates!
  40. with-repository
  41. with-git-error-handling
  42. false-if-git-not-found
  43. update-cached-checkout
  44. url+commit->name
  45. latest-repository-commit
  46. commit-difference
  47. commit-relation
  48. git-checkout
  49. git-checkout?
  50. git-checkout-url
  51. git-checkout-branch
  52. git-checkout-commit
  53. git-checkout-recursive?))
  54. (define %repository-cache-directory
  55. (make-parameter (string-append (cache-directory #:ensure? #f)
  56. "/checkouts")))
  57. (define (honor-system-x509-certificates!)
  58. "Use the system's X.509 certificates for Git checkouts over HTTPS. Honor
  59. the 'SSL_CERT_FILE' and 'SSL_CERT_DIR' environment variables."
  60. ;; On distros such as CentOS 7, /etc/ssl/certs contains only a couple of
  61. ;; files (instead of all the certificates) among which "ca-bundle.crt". On
  62. ;; other distros /etc/ssl/certs usually contains the whole set of
  63. ;; certificates along with "ca-certificates.crt". Try to choose the right
  64. ;; one.
  65. (let ((file (letrec-syntax ((choose
  66. (syntax-rules ()
  67. ((_ file rest ...)
  68. (let ((f file))
  69. (if (and f (file-exists? f))
  70. f
  71. (choose rest ...))))
  72. ((_)
  73. #f))))
  74. (choose (getenv "SSL_CERT_FILE")
  75. "/etc/ssl/certs/ca-certificates.crt"
  76. "/etc/ssl/certs/ca-bundle.crt")))
  77. (directory (or (getenv "SSL_CERT_DIR") "/etc/ssl/certs")))
  78. (and (or file
  79. (and=> (stat directory #f)
  80. (lambda (st)
  81. (> (stat:nlink st) 2))))
  82. (begin
  83. (set-tls-certificate-locations! directory file)
  84. #t))))
  85. (define %certificates-initialized?
  86. ;; Whether 'honor-system-x509-certificates!' has already been called.
  87. #f)
  88. (define-syntax-rule (with-libgit2 thunk ...)
  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!)
  94. (unless %certificates-initialized?
  95. (honor-system-x509-certificates!)
  96. (set! %certificates-initialized? #t))
  97. thunk ...))
  98. (define* (url-cache-directory url
  99. #:optional (cache-directory
  100. (%repository-cache-directory))
  101. #:key recursive?)
  102. "Return the directory associated to URL in %repository-cache-directory."
  103. (string-append
  104. cache-directory "/"
  105. (bytevector->base32-string
  106. (sha256 (string->utf8 (if recursive?
  107. (string-append "R:" url)
  108. url))))))
  109. ;; Authentication appeared in Guile-Git 0.3.0, check if it is available.
  110. (define auth-supported?
  111. (false-if-exception (resolve-interface '(git auth))))
  112. (define (clone* url directory)
  113. "Clone git repository at URL into DIRECTORY. Upon failure,
  114. make sure no empty directory is left behind."
  115. (with-throw-handler #t
  116. (lambda ()
  117. (mkdir-p directory)
  118. ;; Note: Explicitly pass options to work around the invalid default
  119. ;; value in Guile-Git: <https://bugs.gnu.org/29238>.
  120. (if (module-defined? (resolve-interface '(git))
  121. 'clone-init-options)
  122. (let ((auth-method (and auth-supported?
  123. (%make-auth-ssh-agent))))
  124. (clone url directory
  125. (if auth-supported?
  126. (make-clone-options
  127. #:fetch-options (make-fetch-options auth-method))
  128. (clone-init-options))))
  129. (clone url directory)))
  130. (lambda _
  131. (false-if-exception (rmdir directory)))))
  132. (define (url+commit->name url sha1)
  133. "Return the string \"<REPO-NAME>-<SHA1:7>\" where REPO-NAME is the name of
  134. the git repository, extracted from URL and SHA1:7 the seven first digits
  135. of SHA1 string."
  136. (string-append
  137. (string-replace-substring
  138. (last (string-split url #\/)) ".git" "")
  139. "-" (string-take sha1 7)))
  140. (define (resolve-reference repository ref)
  141. "Resolve the branch, commit or tag specified by REF, and return the
  142. corresponding Git object."
  143. (let resolve ((ref ref))
  144. (match ref
  145. (('branch . branch)
  146. (let ((oid (reference-target
  147. (branch-lookup repository branch BRANCH-REMOTE))))
  148. (object-lookup repository oid)))
  149. (('commit . commit)
  150. (let ((len (string-length commit)))
  151. ;; 'object-lookup-prefix' appeared in Guile-Git in Mar. 2018, so we
  152. ;; can't be sure it's available. Furthermore, 'string->oid' used to
  153. ;; read out-of-bounds when passed a string shorter than 40 chars,
  154. ;; which is why we delay calls to it below.
  155. (if (< len 40)
  156. (if (module-defined? (resolve-interface '(git object))
  157. 'object-lookup-prefix)
  158. (object-lookup-prefix repository (string->oid commit) len)
  159. (raise (condition
  160. (&message
  161. (message "long Git object ID is required")))))
  162. (object-lookup repository (string->oid commit)))))
  163. (('tag-or-commit . str)
  164. (if (or (> (string-length str) 40)
  165. (not (string-every char-set:hex-digit str)))
  166. (resolve `(tag . ,str)) ;definitely a tag
  167. (catch 'git-error
  168. (lambda ()
  169. (resolve `(tag . ,str)))
  170. (lambda _
  171. ;; There's no such tag, so it must be a commit ID.
  172. (resolve `(commit . ,str))))))
  173. (('tag . tag)
  174. (let ((oid (reference-name->oid repository
  175. (string-append "refs/tags/" tag))))
  176. ;; OID may point to a "tag" object, but it can also point directly
  177. ;; to a "commit" object, as surprising as it may seem. Return that
  178. ;; object, whatever that is.
  179. (object-lookup repository oid))))))
  180. (define (switch-to-ref repository ref)
  181. "Switch to REPOSITORY's branch, commit or tag specified by REF. Return the
  182. OID (roughly the commit hash) corresponding to REF."
  183. (define obj
  184. (resolve-reference repository ref))
  185. (reset repository obj RESET_HARD)
  186. (object-id obj))
  187. (define (call-with-repository directory proc)
  188. (let ((repository #f))
  189. (dynamic-wind
  190. (lambda ()
  191. (set! repository (repository-open directory)))
  192. (lambda ()
  193. (proc repository))
  194. (lambda ()
  195. (repository-close! repository)))))
  196. (define-syntax-rule (with-repository directory repository exp ...)
  197. "Open the repository at DIRECTORY and bind REPOSITORY to it within the
  198. dynamic extent of EXP."
  199. (call-with-repository directory
  200. (lambda (repository) exp ...)))
  201. (define (report-git-error error)
  202. "Report the given Guile-Git error."
  203. ;; Prior to Guile-Git commit b6b2760c2fd6dfaa5c0fedb43eeaff06166b3134,
  204. ;; errors would be represented by integers.
  205. (match error
  206. ((? integer? error) ;old Guile-Git
  207. (leave (G_ "Git error ~a~%") error))
  208. ((? git-error? error) ;new Guile-Git
  209. (leave (G_ "Git error: ~a~%") (git-error-message error)))))
  210. (define-syntax-rule (with-git-error-handling body ...)
  211. (catch 'git-error
  212. (lambda ()
  213. body ...)
  214. (lambda (key err)
  215. (report-git-error err))))
  216. (define (load-git-submodules)
  217. "Attempt to load (git submodules), which was missing until Guile-Git 0.2.0.
  218. Return true on success, false on failure."
  219. (match (false-if-exception (resolve-interface '(git submodule)))
  220. (#f
  221. (set! load-git-submodules (const #f))
  222. #f)
  223. (iface
  224. (module-use! (resolve-module '(guix git)) iface)
  225. (set! load-git-submodules (const #t))
  226. #t)))
  227. (define* (update-submodules repository
  228. #:key (log-port (current-error-port)))
  229. "Update the submodules of REPOSITORY, a Git repository object."
  230. ;; Guile-Git < 0.2.0 did not have (git submodule).
  231. (if (load-git-submodules)
  232. (for-each (lambda (name)
  233. (let ((submodule (submodule-lookup repository name)))
  234. (format log-port (G_ "updating submodule '~a'...~%")
  235. name)
  236. (submodule-update submodule)
  237. ;; Recurse in SUBMODULE.
  238. (let ((directory (string-append
  239. (repository-working-directory repository)
  240. "/" (submodule-path submodule))))
  241. (with-repository directory repository
  242. (update-submodules repository
  243. #:log-port log-port)))))
  244. (repository-submodules repository))
  245. (format (current-error-port)
  246. (G_ "Support for submodules is missing; \
  247. please upgrade Guile-Git.~%"))))
  248. (define-syntax-rule (false-if-git-not-found exp)
  249. "Evaluate EXP, returning #false if a GIT_ENOTFOUND error is raised."
  250. (catch 'git-error
  251. (lambda ()
  252. exp)
  253. (lambda (key error . rest)
  254. (if (= GIT_ENOTFOUND (git-error-code error))
  255. #f
  256. (apply throw key error rest)))))
  257. (define (reference-available? repository ref)
  258. "Return true if REF, a reference such as '(commit . \"cabba9e\"), is
  259. definitely available in REPOSITORY, false otherwise."
  260. (match ref
  261. (('commit . commit)
  262. (false-if-git-not-found
  263. (->bool (commit-lookup repository (string->oid commit)))))
  264. (_
  265. #f)))
  266. (define* (update-cached-checkout url
  267. #:key
  268. (ref '(branch . "master"))
  269. recursive?
  270. (check-out? #t)
  271. starting-commit
  272. (log-port (%make-void-port "w"))
  273. (cache-directory
  274. (url-cache-directory
  275. url (%repository-cache-directory)
  276. #:recursive? recursive?)))
  277. "Update the cached checkout of URL to REF in CACHE-DIRECTORY. Return three
  278. values: the cache directory name, and the SHA1 commit (a string) corresponding
  279. to REF, and the relation of the new commit relative to STARTING-COMMIT (if
  280. provided) as returned by 'commit-relation'.
  281. REF is pair whose key is [branch | commit | tag | tag-or-commit ] and value
  282. the associated data: [<branch name> | <sha1> | <tag name> | <string>].
  283. When RECURSIVE? is true, check out submodules as well, if any.
  284. When CHECK-OUT? is true, reset the cached working tree to REF; otherwise leave
  285. it unchanged."
  286. (define canonical-ref
  287. ;; We used to require callers to specify "origin/" for each branch, which
  288. ;; made little sense since the cache should be transparent to them. So
  289. ;; here we append "origin/" if it's missing and otherwise keep it.
  290. (match ref
  291. (('branch . branch)
  292. `(branch . ,(if (string-prefix? "origin/" branch)
  293. branch
  294. (string-append "origin/" branch))))
  295. (_ ref)))
  296. (with-libgit2
  297. (let* ((cache-exists? (openable-repository? cache-directory))
  298. (repository (if cache-exists?
  299. (repository-open cache-directory)
  300. (clone* url cache-directory))))
  301. ;; Only fetch remote if it has not been cloned just before.
  302. (when (and cache-exists?
  303. (not (reference-available? repository ref)))
  304. (if auth-supported?
  305. (let ((auth-method (and auth-supported?
  306. (%make-auth-ssh-agent))))
  307. (remote-fetch (remote-lookup repository "origin")
  308. #:fetch-options (make-fetch-options auth-method)))
  309. (remote-fetch (remote-lookup repository "origin"))))
  310. (when recursive?
  311. (update-submodules repository #:log-port log-port))
  312. ;; Note: call 'commit-relation' from here because it's more efficient
  313. ;; than letting users re-open the checkout later on.
  314. (let* ((oid (if check-out?
  315. (switch-to-ref repository canonical-ref)
  316. (object-id
  317. (resolve-reference repository canonical-ref))))
  318. (new (and starting-commit
  319. (commit-lookup repository oid)))
  320. (old (and starting-commit
  321. (false-if-git-not-found
  322. (commit-lookup repository
  323. (string->oid starting-commit)))))
  324. (relation (and starting-commit
  325. (if old
  326. (commit-relation old new)
  327. 'unrelated))))
  328. ;; Reclaim file descriptors and memory mappings associated with
  329. ;; REPOSITORY as soon as possible.
  330. (when (module-defined? (resolve-interface '(git repository))
  331. 'repository-close!)
  332. (repository-close! repository))
  333. (values cache-directory (oid->string oid) relation)))))
  334. (define* (latest-repository-commit store url
  335. #:key
  336. recursive?
  337. (log-port (%make-void-port "w"))
  338. (cache-directory
  339. (%repository-cache-directory))
  340. (ref '(branch . "master")))
  341. "Return two values: the content of the git repository at URL copied into a
  342. store directory and the sha1 of the top level commit in this directory. The
  343. reference to be checkout, once the repository is fetched, is specified by REF.
  344. REF is pair whose key is [branch | commit | tag] and value the associated
  345. data, respectively [<branch name> | <sha1> | <tag name>].
  346. When RECURSIVE? is true, check out submodules as well, if any.
  347. Git repositories are kept in the cache directory specified by
  348. %repository-cache-directory parameter.
  349. Log progress and checkout info to LOG-PORT."
  350. (define (dot-git? file stat)
  351. (and (string=? (basename file) ".git")
  352. (or (eq? 'directory (stat:type stat))
  353. ;; Submodule checkouts end up with a '.git' regular file that
  354. ;; contains metadata about where their actual '.git' directory
  355. ;; lives.
  356. (and recursive?
  357. (eq? 'regular (stat:type stat))))))
  358. (format log-port "updating checkout of '~a'...~%" url)
  359. (let*-values
  360. (((checkout commit _)
  361. (update-cached-checkout url
  362. #:recursive? recursive?
  363. #:ref ref
  364. #:cache-directory
  365. (url-cache-directory url cache-directory
  366. #:recursive?
  367. recursive?)
  368. #:log-port log-port))
  369. ((name)
  370. (url+commit->name url commit)))
  371. (format log-port "retrieved commit ~a~%" commit)
  372. (values (add-to-store store name #t "sha256" checkout
  373. #:select? (negate dot-git?))
  374. commit)))
  375. (define (print-git-error port key args default-printer)
  376. (match args
  377. (((? git-error? error) . _)
  378. (format port (G_ "Git error: ~a~%")
  379. (git-error-message error)))))
  380. (set-exception-printer! 'git-error print-git-error)
  381. ;;;
  382. ;;; Commit difference.
  383. ;;;
  384. (define* (commit-closure commit #:optional (visited (setq)))
  385. "Return the closure of COMMIT as a set. Skip commits contained in VISITED,
  386. a set, and adjoin VISITED to the result."
  387. (let loop ((commits (list commit))
  388. (visited visited))
  389. (match commits
  390. (()
  391. visited)
  392. ((head . tail)
  393. (if (set-contains? visited head)
  394. (loop tail visited)
  395. (loop (append (commit-parents head) tail)
  396. (set-insert head visited)))))))
  397. (define* (commit-difference new old #:optional (excluded '()))
  398. "Return the list of commits between NEW and OLD, where OLD is assumed to be
  399. an ancestor of NEW. Exclude all the commits listed in EXCLUDED along with
  400. their ancestors.
  401. Essentially, this computes the set difference between the closure of NEW and
  402. that of OLD."
  403. (let loop ((commits (list new))
  404. (result '())
  405. (visited (fold commit-closure
  406. (setq)
  407. (cons old excluded))))
  408. (match commits
  409. (()
  410. (reverse result))
  411. ((head . tail)
  412. (if (set-contains? visited head)
  413. (loop tail result visited)
  414. (loop (append (commit-parents head) tail)
  415. (cons head result)
  416. (set-insert head visited)))))))
  417. (define (commit-relation old new)
  418. "Return a symbol denoting the relation between OLD and NEW, two commit
  419. objects: 'ancestor (meaning that OLD is an ancestor of NEW), 'descendant, or
  420. 'unrelated, or 'self (OLD and NEW are the same commit)."
  421. (if (eq? old new)
  422. 'self
  423. (let ((newest (commit-closure new)))
  424. (if (set-contains? newest old)
  425. 'ancestor
  426. (let* ((seen (list->setq (commit-parents new)))
  427. (oldest (commit-closure old seen)))
  428. (if (set-contains? oldest new)
  429. 'descendant
  430. 'unrelated))))))
  431. ;;;
  432. ;;; Checkouts.
  433. ;;;
  434. ;; Representation of the "latest" checkout of a branch or a specific commit.
  435. (define-record-type* <git-checkout>
  436. git-checkout make-git-checkout
  437. git-checkout?
  438. (url git-checkout-url)
  439. (branch git-checkout-branch (default "master"))
  440. (commit git-checkout-commit (default #f)) ;#f | tag | commit
  441. (recursive? git-checkout-recursive? (default #f)))
  442. (define* (latest-repository-commit* url #:key ref recursive? log-port)
  443. ;; Monadic variant of 'latest-repository-commit'.
  444. (lambda (store)
  445. ;; The caller--e.g., (guix scripts build)--may not handle 'git-error' so
  446. ;; translate it into '&message' conditions that we know will be properly
  447. ;; handled.
  448. (catch 'git-error
  449. (lambda ()
  450. (values (latest-repository-commit store url
  451. #:ref ref
  452. #:recursive? recursive?
  453. #:log-port log-port)
  454. store))
  455. (lambda (key error . _)
  456. (raise (condition
  457. (&message
  458. (message
  459. (match ref
  460. (('commit . commit)
  461. (format #f (G_ "cannot fetch commit ~a from ~a: ~a")
  462. commit url (git-error-message error)))
  463. (('branch . branch)
  464. (format #f (G_ "cannot fetch branch '~a' from ~a: ~a")
  465. branch url (git-error-message error)))
  466. (_
  467. (format #f (G_ "Git failure while fetching ~a: ~a")
  468. url (git-error-message error))))))))))))
  469. (define-gexp-compiler (git-checkout-compiler (checkout <git-checkout>)
  470. system target)
  471. ;; "Compile" CHECKOUT by updating the local checkout and adding it to the
  472. ;; store.
  473. (match checkout
  474. (($ <git-checkout> url branch commit recursive?)
  475. (latest-repository-commit* url
  476. #:ref (if commit
  477. `(tag-or-commit . ,commit)
  478. `(branch . ,branch))
  479. #:recursive? recursive?
  480. #:log-port (current-error-port)))))
  481. ;; Local Variables:
  482. ;; eval: (put 'with-repository 'scheme-indent-function 2)
  483. ;; End: