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.
 
 
 
 
 
 

171 lines
7.0 KiB

  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 (rnrs bytevectors)
  28. #:use-module (ice-9 match)
  29. #:use-module (srfi srfi-1)
  30. #:use-module (srfi srfi-11)
  31. #:use-module (srfi srfi-34)
  32. #:use-module (srfi srfi-35)
  33. #:export (%repository-cache-directory
  34. update-cached-checkout
  35. latest-repository-commit))
  36. (define %repository-cache-directory
  37. (make-parameter "/var/cache/guix/checkouts"))
  38. (define-syntax-rule (with-libgit2 thunk ...)
  39. (begin
  40. ;; XXX: The right thing to do would be to call (libgit2-shutdown) here,
  41. ;; but pointer finalizers used in guile-git may be called after shutdown,
  42. ;; resulting in a segfault. Hence, let's skip shutdown call for now.
  43. (libgit2-init!)
  44. thunk ...))
  45. (define* (url-cache-directory url
  46. #:optional (cache-directory
  47. (%repository-cache-directory)))
  48. "Return the directory associated to URL in %repository-cache-directory."
  49. (string-append
  50. cache-directory "/"
  51. (bytevector->base32-string (sha256 (string->utf8 url)))))
  52. (define (clone* url directory)
  53. "Clone git repository at URL into DIRECTORY. Upon failure,
  54. make sure no empty directory is left behind."
  55. (with-throw-handler #t
  56. (lambda ()
  57. (mkdir-p directory)
  58. ;; Note: Explicitly pass options to work around the invalid default
  59. ;; value in Guile-Git: <https://bugs.gnu.org/29238>.
  60. (if (module-defined? (resolve-interface '(git))
  61. 'clone-init-options)
  62. (clone url directory (clone-init-options))
  63. (clone url directory)))
  64. (lambda _
  65. (false-if-exception (rmdir directory)))))
  66. (define (url+commit->name url sha1)
  67. "Return the string \"<REPO-NAME>-<SHA1:7>\" where REPO-NAME is the name of
  68. the git repository, extracted from URL and SHA1:7 the seven first digits
  69. of SHA1 string."
  70. (string-append
  71. (string-replace-substring
  72. (last (string-split url #\/)) ".git" "")
  73. "-" (string-take sha1 7)))
  74. (define (switch-to-ref repository ref)
  75. "Switch to REPOSITORY's branch, commit or tag specified by REF. Return the
  76. OID (roughly the commit hash) corresponding to REF."
  77. (define obj
  78. (match ref
  79. (('branch . branch)
  80. (let ((oid (reference-target
  81. (branch-lookup repository branch BRANCH-REMOTE))))
  82. (object-lookup repository oid)))
  83. (('commit . commit)
  84. (let ((len (string-length commit)))
  85. ;; 'object-lookup-prefix' appeared in Guile-Git in Mar. 2018, so we
  86. ;; can't be sure it's available. Furthermore, 'string->oid' used to
  87. ;; read out-of-bounds when passed a string shorter than 40 chars,
  88. ;; which is why we delay calls to it below.
  89. (if (< len 40)
  90. (if (module-defined? (resolve-interface '(git object))
  91. 'object-lookup-prefix)
  92. (object-lookup-prefix repository (string->oid commit) len)
  93. (raise (condition
  94. (&message
  95. (message "long Git object ID is required")))))
  96. (object-lookup repository (string->oid commit)))))
  97. (('tag . tag)
  98. (let ((oid (reference-name->oid repository
  99. (string-append "refs/tags/" tag))))
  100. (object-lookup repository oid)))))
  101. (reset repository obj RESET_HARD)
  102. (object-id obj))
  103. (define* (update-cached-checkout url
  104. #:key
  105. (ref '(branch . "origin/master"))
  106. (cache-directory
  107. (url-cache-directory
  108. url (%repository-cache-directory))))
  109. "Update the cached checkout of URL to REF in CACHE-DIRECTORY. Return two
  110. values: the cache directory name, and the SHA1 commit (a string) corresponding
  111. to REF.
  112. REF is pair whose key is [branch | commit | tag] and value the associated
  113. data, respectively [<branch name> | <sha1> | <tag name>]."
  114. (with-libgit2
  115. (let* ((cache-exists? (openable-repository? cache-directory))
  116. (repository (if cache-exists?
  117. (repository-open cache-directory)
  118. (clone* url cache-directory))))
  119. ;; Only fetch remote if it has not been cloned just before.
  120. (when cache-exists?
  121. (remote-fetch (remote-lookup repository "origin")))
  122. (let ((oid (switch-to-ref repository ref)))
  123. ;; Reclaim file descriptors and memory mappings associated with
  124. ;; REPOSITORY as soon as possible.
  125. (when (module-defined? (resolve-interface '(git repository))
  126. 'repository-close!)
  127. (repository-close! repository))
  128. (values cache-directory (oid->string oid))))))
  129. (define* (latest-repository-commit store url
  130. #:key
  131. (cache-directory
  132. (%repository-cache-directory))
  133. (ref '(branch . "origin/master")))
  134. "Return two values: the content of the git repository at URL copied into a
  135. store directory and the sha1 of the top level commit in this directory. The
  136. reference to be checkout, once the repository is fetched, is specified by REF.
  137. REF is pair whose key is [branch | commit | tag] and value the associated
  138. data, respectively [<branch name> | <sha1> | <tag name>].
  139. Git repositories are kept in the cache directory specified by
  140. %repository-cache-directory parameter."
  141. (define (dot-git? file stat)
  142. (and (string=? (basename file) ".git")
  143. (eq? 'directory (stat:type stat))))
  144. (let*-values
  145. (((checkout commit)
  146. (update-cached-checkout url
  147. #:ref ref
  148. #:cache-directory
  149. (url-cache-directory url cache-directory)))
  150. ((name)
  151. (url+commit->name url commit)))
  152. (values (add-to-store store name #t "sha256" checkout
  153. #:select? (negate dot-git?))
  154. commit)))