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