Commit | Line | Data |
---|---|---|
41f443c9 LC |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org> | |
3 | ;;; | |
4 | ;;; This file is part of GNU Guix. | |
5 | ;;; | |
6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
7 | ;;; under the terms of the GNU General Public License as published by | |
8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
9 | ;;; your option) any later version. | |
10 | ;;; | |
11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | ;;; GNU General Public License for more details. | |
15 | ;;; | |
16 | ;;; You should have received a copy of the GNU General Public License | |
17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
18 | ||
19 | (define-module (guix git-authenticate) | |
20 | #:use-module (git) | |
21 | #:use-module (guix base16) | |
e7827560 | 22 | #:use-module ((guix git) #:select (false-if-git-not-found)) |
41f443c9 LC |
23 | #:use-module (guix i18n) |
24 | #:use-module (guix openpgp) | |
25 | #:use-module ((guix utils) | |
26 | #:select (cache-directory with-atomic-file-output)) | |
27 | #:use-module ((guix build utils) | |
28 | #:select (mkdir-p)) | |
29 | #:use-module (srfi srfi-1) | |
30 | #:use-module (srfi srfi-11) | |
31 | #:use-module (srfi srfi-26) | |
32 | #:use-module (srfi srfi-34) | |
33 | #:use-module (srfi srfi-35) | |
34 | #:use-module (rnrs bytevectors) | |
35 | #:use-module (rnrs io ports) | |
36 | #:use-module (ice-9 match) | |
37 | #:autoload (ice-9 pretty-print) (pretty-print) | |
38 | #:export (read-authorizations | |
39 | commit-signing-key | |
40 | commit-authorized-keys | |
41 | authenticate-commit | |
42 | authenticate-commits | |
43 | load-keyring-from-reference | |
44 | previously-authenticated-commits | |
f8213f1b LC |
45 | cache-authenticated-commit |
46 | ||
47 | git-authentication-error? | |
48 | git-authentication-error-commit | |
49 | unsigned-commit-error? | |
50 | unauthorized-commit-error? | |
51 | unauthorized-commit-error-signing-key | |
52 | signature-verification-error? | |
53 | signature-verification-error-keyring | |
54 | signature-verification-error-signature | |
55 | missing-key-error? | |
56 | missing-key-error-signature)) | |
41f443c9 LC |
57 | |
58 | ;;; Commentary: | |
59 | ;;; | |
60 | ;;; This module provides tools to authenticate a range of Git commits. A | |
61 | ;;; commit is considered "authentic" if and only if it is signed by an | |
62 | ;;; authorized party. Parties authorized to sign a commit are listed in the | |
63 | ;;; '.guix-authorizations' file of the parent commit. | |
64 | ;;; | |
65 | ;;; Code: | |
66 | ||
f8213f1b LC |
67 | (define-condition-type &git-authentication-error &error |
68 | git-authentication-error? | |
69 | (commit git-authentication-error-commit)) | |
70 | ||
71 | (define-condition-type &unsigned-commit-error &git-authentication-error | |
72 | unsigned-commit-error?) | |
73 | ||
74 | (define-condition-type &unauthorized-commit-error &git-authentication-error | |
75 | unauthorized-commit-error? | |
76 | (signing-key unauthorized-commit-error-signing-key)) | |
77 | ||
78 | (define-condition-type &signature-verification-error &git-authentication-error | |
79 | signature-verification-error? | |
80 | (signature signature-verification-error-signature) | |
81 | (keyring signature-verification-error-keyring)) | |
82 | ||
83 | (define-condition-type &missing-key-error &git-authentication-error | |
84 | missing-key-error? | |
85 | (signature missing-key-error-signature)) | |
86 | ||
87 | ||
41f443c9 LC |
88 | (define (commit-signing-key repo commit-id keyring) |
89 | "Return the OpenPGP key that signed COMMIT-ID (an OID). Raise an exception | |
90 | if the commit is unsigned, has an invalid signature, or if its signing key is | |
91 | not in KEYRING." | |
92 | (let-values (((signature signed-data) | |
93 | (catch 'git-error | |
94 | (lambda () | |
95 | (commit-extract-signature repo commit-id)) | |
96 | (lambda _ | |
97 | (values #f #f))))) | |
98 | (unless signature | |
99 | (raise (condition | |
f8213f1b | 100 | (&unsigned-commit-error (commit commit-id)) |
41f443c9 LC |
101 | (&message |
102 | (message (format #f (G_ "commit ~a lacks a signature") | |
f8213f1b | 103 | (oid->string commit-id))))))) |
41f443c9 LC |
104 | |
105 | (let ((signature (string->openpgp-packet signature))) | |
106 | (with-fluids ((%default-port-encoding "UTF-8")) | |
107 | (let-values (((status data) | |
108 | (verify-openpgp-signature signature keyring | |
109 | (open-input-string signed-data)))) | |
110 | (match status | |
111 | ('bad-signature | |
112 | ;; There's a signature but it's invalid. | |
113 | (raise (condition | |
f8213f1b LC |
114 | (&signature-verification-error (commit commit-id) |
115 | (signature signature) | |
116 | (keyring keyring)) | |
41f443c9 LC |
117 | (&message |
118 | (message (format #f (G_ "signature verification failed \ | |
119 | for commit ~a") | |
120 | (oid->string commit-id))))))) | |
121 | ('missing-key | |
122 | (raise (condition | |
f8213f1b LC |
123 | (&missing-key-error (commit commit-id) |
124 | (signature signature)) | |
41f443c9 LC |
125 | (&message |
126 | (message (format #f (G_ "could not authenticate \ | |
127 | commit ~a: key ~a is missing") | |
128 | (oid->string commit-id) | |
129 | data)))))) | |
130 | ('good-signature data))))))) | |
131 | ||
132 | (define (read-authorizations port) | |
133 | "Read authorizations in the '.guix-authorizations' format from PORT, and | |
134 | return a list of authorized fingerprints." | |
135 | (match (read port) | |
136 | (('authorizations ('version 0) | |
137 | (((? string? fingerprints) _ ...) ...) | |
138 | _ ...) | |
139 | (map (lambda (fingerprint) | |
140 | (base16-string->bytevector | |
141 | (string-downcase (string-filter char-set:graphic fingerprint)))) | |
142 | fingerprints)))) | |
143 | ||
144 | (define* (commit-authorized-keys repository commit | |
145 | #:optional (default-authorizations '())) | |
146 | "Return the list of OpenPGP fingerprints authorized to sign COMMIT, based on | |
147 | authorizations listed in its parent commits. If one of the parent commits | |
148 | does not specify anything, fall back to DEFAULT-AUTHORIZATIONS." | |
e7827560 LC |
149 | (define (parents-have-authorizations-file? commit) |
150 | ;; Return true if at least one of the parents of COMMIT has the | |
151 | ;; '.guix-authorizations' file. | |
152 | (find (lambda (commit) | |
153 | (false-if-git-not-found | |
154 | (tree-entry-bypath (commit-tree commit) | |
155 | ".guix-authorizations"))) | |
156 | (commit-parents commit))) | |
157 | ||
158 | (define (assert-parents-lack-authorizations commit) | |
159 | ;; If COMMIT removes the '.guix-authorizations' file found in one of its | |
160 | ;; parents, raise an error. | |
161 | (when (parents-have-authorizations-file? commit) | |
162 | (raise (condition | |
163 | (&unauthorized-commit-error (commit (commit-id commit)) | |
164 | (signing-key #f)) | |
165 | (&message | |
166 | (message (format #f (G_ "commit ~a attempts \ | |
167 | to remove '.guix-authorizations' file") | |
168 | (oid->string (commit-id commit))))))))) | |
169 | ||
41f443c9 LC |
170 | (define (commit-authorizations commit) |
171 | (catch 'git-error | |
172 | (lambda () | |
173 | (let* ((tree (commit-tree commit)) | |
174 | (entry (tree-entry-bypath tree ".guix-authorizations")) | |
175 | (blob (blob-lookup repository (tree-entry-id entry)))) | |
176 | (read-authorizations | |
177 | (open-bytevector-input-port (blob-content blob))))) | |
178 | (lambda (key error) | |
179 | (if (= (git-error-code error) GIT_ENOTFOUND) | |
e7827560 LC |
180 | (begin |
181 | ;; Prevent removal of '.guix-authorizations' since it would make | |
182 | ;; it trivial to force a fallback to DEFAULT-AUTHORIZATIONS. | |
183 | (assert-parents-lack-authorizations commit) | |
184 | default-authorizations) | |
41f443c9 LC |
185 | (throw key error))))) |
186 | ||
187 | (apply lset-intersection bytevector=? | |
188 | (map commit-authorizations (commit-parents commit)))) | |
189 | ||
190 | (define* (authenticate-commit repository commit keyring | |
191 | #:key (default-authorizations '())) | |
192 | "Authenticate COMMIT from REPOSITORY and return the signing key fingerprint. | |
193 | Raise an error when authentication fails. If one of the parent commits does | |
194 | not specify anything, fall back to DEFAULT-AUTHORIZATIONS." | |
195 | (define id | |
196 | (commit-id commit)) | |
197 | ||
198 | (define signing-key | |
199 | (commit-signing-key repository id keyring)) | |
200 | ||
201 | (unless (member (openpgp-public-key-fingerprint signing-key) | |
202 | (commit-authorized-keys repository commit | |
203 | default-authorizations)) | |
204 | (raise (condition | |
f8213f1b LC |
205 | (&unauthorized-commit-error (commit id) |
206 | (signing-key signing-key)) | |
41f443c9 LC |
207 | (&message |
208 | (message (format #f (G_ "commit ~a not signed by an authorized \ | |
209 | key: ~a") | |
210 | (oid->string id) | |
211 | (openpgp-format-fingerprint | |
212 | (openpgp-public-key-fingerprint | |
213 | signing-key)))))))) | |
214 | ||
215 | signing-key) | |
216 | ||
217 | (define (load-keyring-from-blob repository oid keyring) | |
218 | "Augment KEYRING with the keyring available in the blob at OID, which may or | |
219 | may not be ASCII-armored." | |
220 | (let* ((blob (blob-lookup repository oid)) | |
221 | (port (open-bytevector-input-port (blob-content blob)))) | |
222 | (get-openpgp-keyring (if (port-ascii-armored? port) | |
223 | (open-bytevector-input-port (read-radix-64 port)) | |
224 | port) | |
225 | keyring))) | |
226 | ||
227 | (define (load-keyring-from-reference repository reference) | |
228 | "Load the '.key' files from the tree at REFERENCE in REPOSITORY and return | |
229 | an OpenPGP keyring." | |
512b9e2d | 230 | (let* ((reference (branch-lookup repository reference BRANCH-ALL)) |
41f443c9 LC |
231 | (target (reference-target reference)) |
232 | (commit (commit-lookup repository target)) | |
233 | (tree (commit-tree commit))) | |
234 | (fold (lambda (name keyring) | |
235 | (if (string-suffix? ".key" name) | |
236 | (let ((entry (tree-entry-bypath tree name))) | |
237 | (load-keyring-from-blob repository | |
238 | (tree-entry-id entry) | |
239 | keyring)) | |
240 | keyring)) | |
241 | %empty-keyring | |
242 | (tree-list tree)))) | |
243 | ||
244 | (define* (authenticate-commits repository commits | |
245 | #:key | |
246 | (default-authorizations '()) | |
247 | (keyring-reference "keyring") | |
248 | (report-progress (const #t))) | |
249 | "Authenticate COMMITS, a list of commit objects, calling REPORT-PROGRESS for | |
250 | each of them. Return an alist showing the number of occurrences of each key. | |
251 | The OpenPGP keyring is loaded from KEYRING-REFERENCE in REPOSITORY." | |
252 | (define keyring | |
253 | (load-keyring-from-reference repository keyring-reference)) | |
254 | ||
255 | (fold (lambda (commit stats) | |
256 | (report-progress) | |
257 | (let ((signer (authenticate-commit repository commit keyring | |
258 | #:default-authorizations | |
259 | default-authorizations))) | |
260 | (match (assq signer stats) | |
261 | (#f (cons `(,signer . 1) stats)) | |
262 | ((_ . count) (cons `(,signer . ,(+ count 1)) | |
263 | (alist-delete signer stats)))))) | |
264 | '() | |
265 | commits)) | |
266 | ||
267 | \f | |
268 | ;;; | |
269 | ;;; Caching. | |
270 | ;;; | |
271 | ||
272 | (define (authenticated-commit-cache-file) | |
273 | "Return the name of the file that contains the cache of | |
274 | previously-authenticated commits." | |
275 | (string-append (cache-directory) "/authentication/channels/guix")) | |
276 | ||
277 | (define (previously-authenticated-commits) | |
278 | "Return the previously-authenticated commits as a list of commit IDs (hex | |
279 | strings)." | |
280 | (catch 'system-error | |
281 | (lambda () | |
282 | (call-with-input-file (authenticated-commit-cache-file) | |
283 | read)) | |
284 | (lambda args | |
285 | (if (= ENOENT (system-error-errno args)) | |
286 | '() | |
287 | (apply throw args))))) | |
288 | ||
289 | (define (cache-authenticated-commit commit-id) | |
290 | "Record in ~/.cache COMMIT-ID and its closure as authenticated (only | |
291 | COMMIT-ID is written to cache, though)." | |
292 | (define %max-cache-length | |
293 | ;; Maximum number of commits in cache. | |
294 | 200) | |
295 | ||
296 | (let ((lst (delete-duplicates | |
297 | (cons commit-id (previously-authenticated-commits)))) | |
298 | (file (authenticated-commit-cache-file))) | |
299 | (mkdir-p (dirname file)) | |
300 | (with-atomic-file-output file | |
301 | (lambda (port) | |
302 | (let ((lst (if (> (length lst) %max-cache-length) | |
303 | (take lst %max-cache-length) ;truncate | |
304 | lst))) | |
305 | (chmod port #o600) | |
306 | (display ";; List of previously-authenticated commits.\n\n" | |
307 | port) | |
308 | (pretty-print lst port)))))) |