Mirror of GNU Guix
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.

222 lines
8.8 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 Mathieu Othacehe <m.othacehe@gmail.com>
  3. ;;; Copyright © 2018 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 base32)
  23. #:use-module (gcrypt hash)
  24. #:use-module ((guix build utils) #:select (mkdir-p))
  25. #:use-module (guix store)
  26. #:use-module (guix utils)
  27. #:use-module (guix records)
  28. #:use-module (guix gexp)
  29. #:use-module (rnrs bytevectors)
  30. #:use-module (ice-9 match)
  31. #:use-module (srfi srfi-1)
  32. #:use-module (srfi srfi-11)
  33. #:use-module (srfi srfi-34)
  34. #:use-module (srfi srfi-35)
  35. #:export (%repository-cache-directory
  36. update-cached-checkout
  37. latest-repository-commit
  38. git-checkout
  39. git-checkout?
  40. git-checkout-url
  41. git-checkout-branch))
  42. (define %repository-cache-directory
  43. (make-parameter (string-append (cache-directory #:ensure? #f)
  44. "/checkouts")))
  45. (define-syntax-rule (with-libgit2 thunk ...)
  46. (begin
  47. ;; XXX: The right thing to do would be to call (libgit2-shutdown) here,
  48. ;; but pointer finalizers used in guile-git may be called after shutdown,
  49. ;; resulting in a segfault. Hence, let's skip shutdown call for now.
  50. (libgit2-init!)
  51. thunk ...))
  52. (define* (url-cache-directory url
  53. #:optional (cache-directory
  54. (%repository-cache-directory)))
  55. "Return the directory associated to URL in %repository-cache-directory."
  56. (string-append
  57. cache-directory "/"
  58. (bytevector->base32-string (sha256 (string->utf8 url)))))
  59. (define (clone* url directory)
  60. "Clone git repository at URL into DIRECTORY. Upon failure,
  61. make sure no empty directory is left behind."
  62. (with-throw-handler #t
  63. (lambda ()
  64. (mkdir-p directory)
  65. ;; Note: Explicitly pass options to work around the invalid default
  66. ;; value in Guile-Git: <https://bugs.gnu.org/29238>.
  67. (if (module-defined? (resolve-interface '(git))
  68. 'clone-init-options)
  69. (clone url directory (clone-init-options))
  70. (clone url directory)))
  71. (lambda _
  72. (false-if-exception (rmdir directory)))))
  73. (define (url+commit->name url sha1)
  74. "Return the string \"<REPO-NAME>-<SHA1:7>\" where REPO-NAME is the name of
  75. the git repository, extracted from URL and SHA1:7 the seven first digits
  76. of SHA1 string."
  77. (string-append
  78. (string-replace-substring
  79. (last (string-split url #\/)) ".git" "")
  80. "-" (string-take sha1 7)))
  81. (define (switch-to-ref repository ref)
  82. "Switch to REPOSITORY's branch, commit or tag specified by REF. Return the
  83. OID (roughly the commit hash) corresponding to REF."
  84. (define obj
  85. (match ref
  86. (('branch . branch)
  87. (let ((oid (reference-target
  88. (branch-lookup repository branch BRANCH-REMOTE))))
  89. (object-lookup repository oid)))
  90. (('commit . commit)
  91. (let ((len (string-length commit)))
  92. ;; 'object-lookup-prefix' appeared in Guile-Git in Mar. 2018, so we
  93. ;; can't be sure it's available. Furthermore, 'string->oid' used to
  94. ;; read out-of-bounds when passed a string shorter than 40 chars,
  95. ;; which is why we delay calls to it below.
  96. (if (< len 40)
  97. (if (module-defined? (resolve-interface '(git object))
  98. 'object-lookup-prefix)
  99. (object-lookup-prefix repository (string->oid commit) len)
  100. (raise (condition
  101. (&message
  102. (message "long Git object ID is required")))))
  103. (object-lookup repository (string->oid commit)))))
  104. (('tag . tag)
  105. (let ((oid (reference-name->oid repository
  106. (string-append "refs/tags/" tag))))
  107. (object-lookup repository oid)))))
  108. (reset repository obj RESET_HARD)
  109. (object-id obj))
  110. (define* (update-cached-checkout url
  111. #:key
  112. (ref '(branch . "master"))
  113. (cache-directory
  114. (url-cache-directory
  115. url (%repository-cache-directory))))
  116. "Update the cached checkout of URL to REF in CACHE-DIRECTORY. Return two
  117. values: the cache directory name, and the SHA1 commit (a string) corresponding
  118. to REF.
  119. REF is pair whose key is [branch | commit | tag] and value the associated
  120. data, respectively [<branch name> | <sha1> | <tag name>]."
  121. (define canonical-ref
  122. ;; We used to require callers to specify "origin/" for each branch, which
  123. ;; made little sense since the cache should be transparent to them. So
  124. ;; here we append "origin/" if it's missing and otherwise keep it.
  125. (match ref
  126. (('branch . branch)
  127. `(branch . ,(if (string-prefix? "origin/" branch)
  128. branch
  129. (string-append "origin/" branch))))
  130. (_ ref)))
  131. (with-libgit2
  132. (let* ((cache-exists? (openable-repository? cache-directory))
  133. (repository (if cache-exists?
  134. (repository-open cache-directory)
  135. (clone* url cache-directory))))
  136. ;; Only fetch remote if it has not been cloned just before.
  137. (when cache-exists?
  138. (remote-fetch (remote-lookup repository "origin")))
  139. (let ((oid (switch-to-ref repository canonical-ref)))
  140. ;; Reclaim file descriptors and memory mappings associated with
  141. ;; REPOSITORY as soon as possible.
  142. (when (module-defined? (resolve-interface '(git repository))
  143. 'repository-close!)
  144. (repository-close! repository))
  145. (values cache-directory (oid->string oid))))))
  146. (define* (latest-repository-commit store url
  147. #:key
  148. (log-port (%make-void-port "w"))
  149. (cache-directory
  150. (%repository-cache-directory))
  151. (ref '(branch . "master")))
  152. "Return two values: the content of the git repository at URL copied into a
  153. store directory and the sha1 of the top level commit in this directory. The
  154. reference to be checkout, once the repository is fetched, is specified by REF.
  155. REF is pair whose key is [branch | commit | tag] and value the associated
  156. data, respectively [<branch name> | <sha1> | <tag name>].
  157. Git repositories are kept in the cache directory specified by
  158. %repository-cache-directory parameter.
  159. Log progress and checkout info to LOG-PORT."
  160. (define (dot-git? file stat)
  161. (and (string=? (basename file) ".git")
  162. (eq? 'directory (stat:type stat))))
  163. (format log-port "updating checkout of '~a'...~%" url)
  164. (let*-values
  165. (((checkout commit)
  166. (update-cached-checkout url
  167. #:ref ref
  168. #:cache-directory
  169. (url-cache-directory url cache-directory)))
  170. ((name)
  171. (url+commit->name url commit)))
  172. (format log-port "retrieved commit ~a~%" commit)
  173. (values (add-to-store store name #t "sha256" checkout
  174. #:select? (negate dot-git?))
  175. commit)))
  176. ;;;
  177. ;;; Checkouts.
  178. ;;;
  179. ;; Representation of the "latest" checkout of a branch or a specific commit.
  180. (define-record-type* <git-checkout>
  181. git-checkout make-git-checkout
  182. git-checkout?
  183. (url git-checkout-url)
  184. (branch git-checkout-branch (default "master"))
  185. (commit git-checkout-commit (default #f)))
  186. (define latest-repository-commit*
  187. (store-lift latest-repository-commit))
  188. (define-gexp-compiler (git-checkout-compiler (checkout <git-checkout>)
  189. system target)
  190. ;; "Compile" CHECKOUT by updating the local checkout and adding it to the
  191. ;; store.
  192. (match checkout
  193. (($ <git-checkout> url branch commit)
  194. (latest-repository-commit* url
  195. #:ref (if commit
  196. `(commit . ,commit)
  197. `(branch . ,branch))
  198. #:log-port (current-error-port)))))