Commit | Line | Data |
---|---|---|
0d39a3b9 | 1 | ;;; GNU Guix --- Functional package management for GNU |
c9fbd407 | 2 | ;;; Copyright © 2018-2022 Ludovic Courtès <ludo@gnu.org> |
af12790b | 3 | ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> |
53f21642 | 4 | ;;; Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> |
b891f851 | 5 | ;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re> |
0d39a3b9 LC |
6 | ;;; |
7 | ;;; This file is part of GNU Guix. | |
8 | ;;; | |
9 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
10 | ;;; under the terms of the GNU General Public License as published by | |
11 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
12 | ;;; your option) any later version. | |
13 | ;;; | |
14 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
15 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
16 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
17 | ;;; GNU General Public License for more details. | |
18 | ;;; | |
19 | ;;; You should have received a copy of the GNU General Public License | |
20 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
21 | ||
22 | (define-module (guix channels) | |
8ba7fd3c | 23 | #:use-module (git) |
0d39a3b9 | 24 | #:use-module (guix git) |
43badf26 LC |
25 | #:use-module (guix git-authenticate) |
26 | #:use-module ((guix openpgp) | |
27 | #:select (openpgp-public-key-fingerprint | |
28 | openpgp-format-fingerprint)) | |
29 | #:use-module (guix base16) | |
0d39a3b9 LC |
30 | #:use-module (guix records) |
31 | #:use-module (guix gexp) | |
5fbdc9a5 | 32 | #:use-module (guix modules) |
0d39a3b9 LC |
33 | #:use-module (guix discovery) |
34 | #:use-module (guix monads) | |
35 | #:use-module (guix profiles) | |
37c0d458 | 36 | #:use-module (guix packages) |
43badf26 | 37 | #:use-module (guix progress) |
0d39a3b9 | 38 | #:use-module (guix derivations) |
f58f676b | 39 | #:use-module (guix combinators) |
69962ab7 | 40 | #:use-module (guix diagnostics) |
8ba7fd3c | 41 | #:use-module (guix sets) |
0d39a3b9 LC |
42 | #:use-module (guix store) |
43 | #:use-module (guix i18n) | |
44 | #:use-module (srfi srfi-1) | |
af12790b | 45 | #:use-module (srfi srfi-2) |
0d39a3b9 LC |
46 | #:use-module (srfi srfi-9) |
47 | #:use-module (srfi srfi-11) | |
9719e8d3 | 48 | #:use-module (srfi srfi-26) |
ab6025b5 LC |
49 | #:use-module (srfi srfi-34) |
50 | #:use-module (srfi srfi-35) | |
29009fdb | 51 | #:autoload (guix describe) (current-channels) ;XXX: circular dep |
5fbdc9a5 LC |
52 | #:autoload (guix self) (whole-package make-config.scm) |
53 | #:autoload (guix inferior) (gexp->derivation-in-inferior) ;FIXME: circular dep | |
20507347 | 54 | #:autoload (guix quirks) (%quirks %patches applicable-patch? apply-patch) |
43badf26 | 55 | #:use-module (ice-9 format) |
0d39a3b9 | 56 | #:use-module (ice-9 match) |
ed75bdf3 | 57 | #:use-module (ice-9 vlist) |
37c0d458 | 58 | #:use-module ((ice-9 rdelim) #:select (read-string)) |
43badf26 | 59 | #:use-module ((rnrs bytevectors) #:select (bytevector=?)) |
0d39a3b9 LC |
60 | #:export (channel |
61 | channel? | |
62 | channel-name | |
63 | channel-url | |
64 | channel-branch | |
65 | channel-commit | |
43badf26 | 66 | channel-introduction |
0d39a3b9 LC |
67 | channel-location |
68 | ||
43badf26 | 69 | channel-introduction? |
8b7d982e LC |
70 | make-channel-introduction |
71 | channel-introduction-first-signed-commit | |
72 | channel-introduction-first-commit-signer | |
43badf26 | 73 | |
6577682a LC |
74 | openpgp-fingerprint->bytevector |
75 | openpgp-fingerprint | |
76 | ||
16c7472b | 77 | %default-guix-channel |
0d39a3b9 | 78 | %default-channels |
72f749dc | 79 | guix-channel? |
64a07071 | 80 | repository->guix-channel |
0d39a3b9 LC |
81 | |
82 | channel-instance? | |
83 | channel-instance-channel | |
84 | channel-instance-commit | |
85 | channel-instance-checkout | |
86 | ||
43badf26 | 87 | authenticate-channel |
0d39a3b9 | 88 | latest-channel-instances |
fe5db4eb | 89 | checkout->channel-instance |
030f1367 | 90 | latest-channel-derivation |
4399b1cf | 91 | channel-instance->sexp |
c37f38bd | 92 | channel-instances->manifest |
5fbdc9a5 | 93 | %channel-profile-hooks |
a7c714d3 | 94 | channel-instances->derivation |
872898f7 | 95 | ensure-forward-channel-update |
a7c714d3 | 96 | |
8ba7fd3c | 97 | profile-channels |
1b88b7ba | 98 | manifest-entry-channel |
aedbc5ff | 99 | sexp->channel |
60d72f53 | 100 | channel->code |
8ba7fd3c LC |
101 | |
102 | channel-news-entry? | |
103 | channel-news-entry-commit | |
9719e8d3 | 104 | channel-news-entry-tag |
8ba7fd3c LC |
105 | channel-news-entry-title |
106 | channel-news-entry-body | |
107 | ||
108 | channel-news-for-commit)) | |
0d39a3b9 LC |
109 | |
110 | ;;; Commentary: | |
111 | ;;; | |
112 | ;;; This module implements "channels." A channel is usually a source of | |
113 | ;;; package definitions. There's a special channel, the 'guix' channel, that | |
114 | ;;; provides all of Guix, including its commands and its documentation. | |
115 | ;;; User-defined channels are expected to typically provide a bunch of .scm | |
116 | ;;; files meant to be added to the '%package-search-path'. | |
117 | ;;; | |
118 | ;;; This module provides tools to fetch and update channels from a Git | |
119 | ;;; repository and to build them. | |
120 | ;;; | |
121 | ;;; Code: | |
122 | ||
123 | (define-record-type* <channel> channel make-channel | |
124 | channel? | |
125 | (name channel-name) | |
126 | (url channel-url) | |
127 | (branch channel-branch (default "master")) | |
128 | (commit channel-commit (default #f)) | |
43badf26 | 129 | (introduction channel-introduction (default #f)) |
0d39a3b9 LC |
130 | (location channel-location |
131 | (default (current-source-location)) (innate))) | |
0d39a3b9 | 132 | |
43badf26 LC |
133 | ;; Channel introductions. A "channel introduction" provides a commit/signer |
134 | ;; pair that specifies the first commit of the authentication process as well | |
22a96992 LC |
135 | ;; as its signer's fingerprint. Introductions are used to bootstrap trust in |
136 | ;; a channel. | |
43badf26 | 137 | (define-record-type <channel-introduction> |
22a96992 | 138 | (%make-channel-introduction first-signed-commit first-commit-signer) |
43badf26 | 139 | channel-introduction? |
22a96992 LC |
140 | (first-signed-commit channel-introduction-first-signed-commit) ;hex string |
141 | (first-commit-signer channel-introduction-first-commit-signer)) ;bytevector | |
43badf26 | 142 | |
8b7d982e LC |
143 | (define (make-channel-introduction commit signer) |
144 | "Return a new channel introduction: COMMIT is the introductory where | |
145 | authentication starts, and SIGNER is the OpenPGP fingerprint (a bytevector) of | |
146 | the signer of that commit." | |
22a96992 | 147 | (%make-channel-introduction commit signer)) |
8b7d982e | 148 | |
6577682a LC |
149 | (define (openpgp-fingerprint->bytevector str) |
150 | "Convert STR, an OpenPGP fingerprint (hexadecimal string with whitespace), | |
151 | to the corresponding bytevector." | |
152 | (base16-string->bytevector | |
153 | (string-downcase (string-filter char-set:hex-digit str)))) | |
154 | ||
155 | (define-syntax openpgp-fingerprint | |
156 | (lambda (s) | |
157 | "Convert STR, an OpenPGP fingerprint (hexadecimal string with whitespace), | |
158 | to the corresponding bytevector." | |
159 | (syntax-case s () | |
160 | ((_ str) | |
161 | (string? (syntax->datum #'str)) | |
162 | (openpgp-fingerprint->bytevector (syntax->datum #'str))) | |
163 | ((_ str) | |
164 | #'(openpgp-fingerprint->bytevector str))))) | |
165 | ||
43badf26 LC |
166 | (define %guix-channel-introduction |
167 | ;; Introduction of the official 'guix channel. The chosen commit is the | |
168 | ;; first one that introduces '.guix-authorizations' on the 'staging' | |
169 | ;; branch that was eventually merged in 'master'. Any branch starting | |
170 | ;; before that commit cannot be merged or it will be rejected by 'guix pull' | |
171 | ;; & co. | |
172 | (make-channel-introduction | |
173 | "9edb3f66fd807b096b48283debdcddccfea34bad" ;2020-05-26 | |
6577682a LC |
174 | (openpgp-fingerprint ;mbakke |
175 | "BBB0 2DDF 2CEA F6A8 0D1D E643 A2A0 6DF2 A33A 54FA"))) | |
43badf26 | 176 | |
c3f6f564 LC |
177 | (define %default-channel-url |
178 | ;; URL of the default 'guix' channel. | |
179 | "https://git.savannah.gnu.org/git/guix.git") | |
180 | ||
16c7472b ZZ |
181 | (define %default-guix-channel |
182 | (channel | |
183 | (name 'guix) | |
184 | (branch "master") | |
185 | (url %default-channel-url) | |
186 | (introduction %guix-channel-introduction))) | |
187 | ||
0d39a3b9 LC |
188 | (define %default-channels |
189 | ;; Default list of channels. | |
16c7472b | 190 | (list %default-guix-channel)) |
0d39a3b9 LC |
191 | |
192 | (define (guix-channel? channel) | |
193 | "Return true if CHANNEL is the 'guix' channel." | |
194 | (eq? 'guix (channel-name channel))) | |
195 | ||
c3f6f564 LC |
196 | (define (ensure-default-introduction chan) |
197 | "If CHAN represents the \"official\" 'guix' channel and lacks an | |
198 | introduction, add it." | |
199 | (if (and (guix-channel? chan) | |
200 | (not (channel-introduction chan)) | |
201 | (string=? (channel-url chan) %default-channel-url)) | |
202 | (channel (inherit chan) | |
203 | (introduction %guix-channel-introduction)) | |
204 | chan)) | |
205 | ||
64a07071 LC |
206 | (define* (repository->guix-channel directory |
207 | #:key | |
208 | (introduction %guix-channel-introduction)) | |
209 | "Look for a Git repository in DIRECTORY or its ancestors and return a | |
210 | channel that uses that repository and the commit HEAD currently points to; use | |
211 | INTRODUCTION as the channel's introduction. Return #f if no Git repository | |
212 | could be found at DIRECTORY or one of its ancestors." | |
213 | (catch 'git-error | |
214 | (lambda () | |
215 | (with-repository (repository-discover directory) repository | |
216 | (let* ((head (repository-head repository)) | |
217 | (commit (oid->string (reference-target head)))) | |
218 | (channel | |
219 | (inherit %default-guix-channel) | |
220 | (url (repository-working-directory repository)) | |
221 | (commit commit) | |
222 | (branch (reference-shorthand head)) | |
223 | (introduction introduction))))) | |
224 | (const #f))) | |
225 | ||
0d39a3b9 LC |
226 | (define-record-type <channel-instance> |
227 | (channel-instance channel commit checkout) | |
228 | channel-instance? | |
229 | (channel channel-instance-channel) | |
230 | (commit channel-instance-commit) | |
231 | (checkout channel-instance-checkout)) | |
232 | ||
af12790b | 233 | (define-record-type <channel-metadata> |
4ae762af | 234 | (channel-metadata directory dependencies news-file keyring-reference url) |
af12790b | 235 | channel-metadata? |
ce5d9ec8 | 236 | (directory channel-metadata-directory) ;string with leading slash |
8ba7fd3c | 237 | (dependencies channel-metadata-dependencies) ;list of <channel> |
43badf26 | 238 | (news-file channel-metadata-news-file) ;string | #f |
4ae762af LC |
239 | (keyring-reference channel-metadata-keyring-reference) ;string |
240 | (url channel-metadata-url)) ;string | #f | |
43badf26 LC |
241 | |
242 | (define %default-keyring-reference | |
243 | ;; Default value of the 'keyring-reference' field. | |
244 | "keyring") | |
af12790b | 245 | |
0d39a3b9 LC |
246 | (define (channel-reference channel) |
247 | "Return the \"reference\" for CHANNEL, an sexp suitable for | |
248 | 'latest-repository-commit'." | |
249 | (match (channel-commit channel) | |
250 | (#f `(branch . ,(channel-branch channel))) | |
f3652241 | 251 | (commit `(tag-or-commit . ,(channel-commit channel))))) |
0d39a3b9 | 252 | |
d774c7b1 LC |
253 | (define sexp->channel-introduction |
254 | (match-lambda | |
255 | (('channel-introduction ('version 0) | |
256 | ('commit commit) ('signer signer) | |
257 | _ ...) | |
258 | (make-channel-introduction commit (openpgp-fingerprint signer))) | |
259 | (x #f))) | |
260 | ||
45b90332 LC |
261 | (define (read-channel-metadata port) |
262 | "Read from PORT channel metadata in the format expected for the | |
263 | '.guix-channel' file. Return a <channel-metadata> record, or raise an error | |
264 | if valid metadata could not be read from PORT." | |
265 | (match (read port) | |
266 | (('channel ('version 0) properties ...) | |
267 | (let ((directory (and=> (assoc-ref properties 'directory) first)) | |
8ba7fd3c | 268 | (dependencies (or (assoc-ref properties 'dependencies) '())) |
43badf26 | 269 | (news-file (and=> (assoc-ref properties 'news-file) first)) |
4ae762af | 270 | (url (and=> (assoc-ref properties 'url) first)) |
43badf26 LC |
271 | (keyring-reference |
272 | (or (and=> (assoc-ref properties 'keyring-reference) first) | |
273 | %default-keyring-reference))) | |
45b90332 | 274 | (channel-metadata |
8ba7fd3c | 275 | (cond ((not directory) "/") ;directory |
ce5d9ec8 LC |
276 | ((string-prefix? "/" directory) directory) |
277 | (else (string-append "/" directory))) | |
8ba7fd3c | 278 | (map (lambda (item) ;dependencies |
45b90332 LC |
279 | (let ((get (lambda* (key #:optional default) |
280 | (or (and=> (assoc-ref item key) first) default)))) | |
281 | (and-let* ((name (get 'name)) | |
282 | (url (get 'url)) | |
283 | (branch (get 'branch "master"))) | |
284 | (channel | |
285 | (name name) | |
286 | (branch branch) | |
287 | (url url) | |
d774c7b1 LC |
288 | (commit (get 'commit)) |
289 | (introduction (and=> (get 'introduction) | |
290 | sexp->channel-introduction)))))) | |
8ba7fd3c | 291 | dependencies) |
43badf26 | 292 | news-file |
4ae762af LC |
293 | keyring-reference |
294 | url))) | |
45b90332 LC |
295 | ((and ('channel ('version version) _ ...) sexp) |
296 | (raise (condition | |
297 | (&message (message "unsupported '.guix-channel' version")) | |
298 | (&error-location | |
299 | (location (source-properties->location | |
300 | (source-properties sexp))))))) | |
301 | (sexp | |
302 | (raise (condition | |
303 | (&message (message "invalid '.guix-channel' file")) | |
304 | (&error-location | |
305 | (location (source-properties->location | |
306 | (source-properties sexp))))))))) | |
307 | ||
53f21642 JN |
308 | (define (read-channel-metadata-from-source source) |
309 | "Return a channel-metadata record read from channel's SOURCE/.guix-channel | |
ce5d9ec8 LC |
310 | description file, or return the default channel-metadata record if that file |
311 | doesn't exist." | |
45b90332 LC |
312 | (catch 'system-error |
313 | (lambda () | |
314 | (call-with-input-file (string-append source "/.guix-channel") | |
315 | read-channel-metadata)) | |
316 | (lambda args | |
317 | (if (= ENOENT (system-error-errno args)) | |
4ae762af | 318 | (channel-metadata "/" '() #f %default-keyring-reference #f) |
45b90332 LC |
319 | (apply throw args))))) |
320 | ||
321 | (define (channel-instance-metadata instance) | |
53f21642 | 322 | "Return a channel-metadata record read from the channel INSTANCE's |
ce5d9ec8 | 323 | description file or its default value." |
53f21642 JN |
324 | (read-channel-metadata-from-source (channel-instance-checkout instance))) |
325 | ||
af12790b RW |
326 | (define (channel-instance-dependencies instance) |
327 | "Return the list of channels that are declared as dependencies for the given | |
328 | channel INSTANCE." | |
ce5d9ec8 | 329 | (channel-metadata-dependencies (channel-instance-metadata instance))) |
af12790b | 330 | |
053b10c3 LC |
331 | (define (apply-patches checkout commit patches) |
332 | "Apply the matching PATCHES to CHECKOUT, modifying files in place. The | |
333 | result is unspecified." | |
334 | (let loop ((patches patches)) | |
335 | (match patches | |
336 | (() #t) | |
20507347 LC |
337 | ((patch rest ...) |
338 | (when (applicable-patch? patch checkout commit) | |
339 | (apply-patch patch checkout)) | |
053b10c3 LC |
340 | (loop rest))))) |
341 | ||
43badf26 LC |
342 | (define commit-short-id |
343 | (compose (cut string-take <> 7) oid->string commit-id)) | |
344 | ||
43badf26 LC |
345 | (define* (authenticate-channel channel checkout commit |
346 | #:key (keyring-reference-prefix "origin/")) | |
347 | "Authenticate the given COMMIT of CHANNEL, available at CHECKOUT, a | |
348 | directory containing a CHANNEL checkout. Raise an error if authentication | |
349 | fails." | |
838f2bdf LC |
350 | (define intro |
351 | (channel-introduction channel)) | |
352 | ||
353 | (define cache-key | |
354 | (string-append "channels/" (symbol->string (channel-name channel)))) | |
355 | ||
356 | (define keyring-reference | |
357 | (channel-metadata-keyring-reference | |
358 | (read-channel-metadata-from-source checkout))) | |
359 | ||
360 | (define (make-reporter start-commit end-commit commits) | |
361 | (format (current-error-port) | |
362 | (G_ "Authenticating channel '~a', commits ~a to ~a (~h new \ | |
363 | commits)...~%") | |
364 | (channel-name channel) | |
365 | (commit-short-id start-commit) | |
366 | (commit-short-id end-commit) | |
367 | (length commits)) | |
368 | ||
369 | (progress-reporter/bar (length commits))) | |
370 | ||
29009fdb LC |
371 | (define authentic-commits |
372 | ;; Consider the currently-used commit of CHANNEL as authentic so | |
373 | ;; authentication can skip it and all its closure. | |
374 | (match (find (lambda (candidate) | |
375 | (eq? (channel-name candidate) (channel-name channel))) | |
376 | (current-channels)) | |
377 | (#f '()) | |
378 | (channel | |
379 | (if (channel-commit channel) | |
380 | (list (channel-commit channel)) | |
381 | '())))) | |
382 | ||
43badf26 LC |
383 | ;; XXX: Too bad we need to re-open CHECKOUT. |
384 | (with-repository checkout repository | |
838f2bdf LC |
385 | (authenticate-repository repository |
386 | (string->oid | |
387 | (channel-introduction-first-signed-commit intro)) | |
388 | (channel-introduction-first-commit-signer intro) | |
389 | #:end (string->oid commit) | |
390 | #:keyring-reference | |
391 | (string-append keyring-reference-prefix | |
392 | keyring-reference) | |
29009fdb | 393 | #:authentic-commits authentic-commits |
838f2bdf LC |
394 | #:make-reporter make-reporter |
395 | #:cache-key cache-key))) | |
43badf26 | 396 | |
053b10c3 | 397 | (define* (latest-channel-instance store channel |
872898f7 | 398 | #:key (patches %patches) |
5bafc70d | 399 | starting-commit |
a9eeeaa6 | 400 | (authenticate? #f) |
5bafc70d LC |
401 | (validate-pull |
402 | ensure-forward-channel-update)) | |
403 | "Return the latest channel instance for CHANNEL. When STARTING-COMMIT is | |
404 | true, call VALIDATE-PULL with CHANNEL, STARTING-COMMIT, the target commit, and | |
a9eeeaa6 | 405 | their relation. When AUTHENTICATE? is false, CHANNEL is not authenticated." |
053b10c3 LC |
406 | (define (dot-git? file stat) |
407 | (and (string=? (basename file) ".git") | |
408 | (eq? 'directory (stat:type stat)))) | |
409 | ||
c3f6f564 LC |
410 | (let-values (((channel) |
411 | (ensure-default-introduction channel)) | |
412 | ((checkout commit relation) | |
053b10c3 | 413 | (update-cached-checkout (channel-url channel) |
872898f7 LC |
414 | #:ref (channel-reference channel) |
415 | #:starting-commit starting-commit))) | |
5bafc70d LC |
416 | (when relation |
417 | (validate-pull channel starting-commit commit relation)) | |
418 | ||
a9eeeaa6 LC |
419 | (if authenticate? |
420 | (if (channel-introduction channel) | |
421 | (authenticate-channel channel checkout commit) | |
5bc4b8e8 LC |
422 | (begin |
423 | (when (file-exists? | |
424 | (string-append checkout "/.guix-authorizations")) | |
425 | (warning (and=> (channel-location channel) | |
426 | source-properties->location) | |
427 | (G_ "channel '~a' lacks 'introduction' field but \ | |
428 | '.guix-authorizations' found\n") | |
429 | (channel-name channel))) | |
430 | ||
431 | ;; TODO: Warn for all the channels once the authentication interface | |
432 | ;; is public. | |
433 | (when (guix-channel? channel) | |
434 | (raise (make-compound-condition | |
435 | (formatted-message (G_ "channel '~a' lacks an \ | |
ead5c461 | 436 | introduction and cannot be authenticated~%") |
5bc4b8e8 LC |
437 | (channel-name channel)) |
438 | (condition | |
439 | (&fix-hint | |
440 | (hint (G_ "Add the missing introduction to your | |
ead5c461 LC |
441 | channels file to address the issue. Alternatively, you can pass |
442 | @option{--disable-authentication}, at the risk of running unauthenticated and | |
5bc4b8e8 | 443 | thus potentially malicious code."))))))))) |
a9eeeaa6 | 444 | (warning (G_ "channel authentication disabled~%"))) |
43badf26 | 445 | |
053b10c3 LC |
446 | (when (guix-channel? channel) |
447 | ;; Apply the relevant subset of PATCHES directly in CHECKOUT. This is | |
448 | ;; safe to do because 'switch-to-ref' eventually does a hard reset. | |
449 | (apply-patches checkout commit patches)) | |
450 | ||
451 | (let* ((name (url+commit->name (channel-url channel) commit)) | |
452 | (checkout (add-to-store store name #t "sha256" checkout | |
453 | #:select? (negate dot-git?)))) | |
5bafc70d | 454 | (channel-instance channel commit checkout)))) |
872898f7 | 455 | |
5bafc70d | 456 | (define (ensure-forward-channel-update channel start commit relation) |
872898f7 | 457 | "Raise an error if RELATION is not 'ancestor, meaning that START is not an |
5bafc70d | 458 | ancestor of COMMIT, unless CHANNEL specifies a commit. |
872898f7 LC |
459 | |
460 | This procedure implements a channel update policy meant to be used as a | |
461 | #:validate-pull argument." | |
462 | (match relation | |
463 | ('ancestor #t) | |
464 | ('self #t) | |
465 | (_ | |
9744cc7b LC |
466 | (raise (make-compound-condition |
467 | (condition | |
468 | (&message (message | |
469 | (format #f (G_ "\ | |
872898f7 | 470 | aborting update of channel '~a' to commit ~a, which is not a descendant of ~a") |
9744cc7b | 471 | (channel-name channel) |
5bafc70d | 472 | commit start)))) |
872898f7 | 473 | |
9744cc7b LC |
474 | ;; If the user asked for a specific commit, they might want |
475 | ;; that to happen nevertheless, so tell them about the | |
476 | ;; relevant 'guix pull' option. | |
477 | (if (channel-commit channel) | |
478 | (condition | |
479 | (&fix-hint | |
480 | (hint (G_ "Use @option{--allow-downgrades} to force | |
481 | this downgrade.")))) | |
482 | (condition | |
483 | (&fix-hint | |
484 | (hint (G_ "This could indicate that the channel has | |
872898f7 LC |
485 | been tampered with and is trying to force a roll-back, preventing you from |
486 | getting the latest updates. If you think this is not the case, explicitly | |
9744cc7b | 487 | allow non-forward updates.")))))))))) |
872898f7 | 488 | |
4ae762af LC |
489 | (define (channel-instance-primary-url instance) |
490 | "Return the primary URL advertised for INSTANCE, or #f if there is no such | |
491 | information." | |
492 | (channel-metadata-url (channel-instance-metadata instance))) | |
493 | ||
872898f7 LC |
494 | (define* (latest-channel-instances store channels |
495 | #:key | |
496 | (current-channels '()) | |
a9eeeaa6 | 497 | (authenticate? #t) |
872898f7 LC |
498 | (validate-pull |
499 | ensure-forward-channel-update)) | |
0d39a3b9 | 500 | "Return a list of channel instances corresponding to the latest checkouts of |
872898f7 LC |
501 | CHANNELS and the channels on which they depend. |
502 | ||
a9eeeaa6 LC |
503 | When AUTHENTICATE? is true, authenticate the subset of CHANNELS that has a |
504 | \"channel introduction\". | |
505 | ||
872898f7 LC |
506 | CURRENT-CHANNELS is the list of currently used channels. It is compared |
507 | against the newly-fetched instances of CHANNELS, and VALIDATE-PULL is called | |
508 | for each channel update and can choose to emit warnings or raise an error, | |
509 | depending on the policy it implements." | |
af12790b RW |
510 | ;; Only process channels that are unique, or that are more specific than a |
511 | ;; previous channel specification. | |
512 | (define (ignore? channel others) | |
513 | (member channel others | |
514 | (lambda (a b) | |
515 | (and (eq? (channel-name a) (channel-name b)) | |
516 | (or (channel-commit b) | |
517 | (not (or (channel-commit a) | |
518 | (channel-commit b)))))))) | |
f58f676b | 519 | |
872898f7 LC |
520 | (define (current-commit name) |
521 | ;; Return the current commit for channel NAME. | |
522 | (any (lambda (channel) | |
523 | (and (eq? (channel-name channel) name) | |
524 | (channel-commit channel))) | |
525 | current-channels)) | |
526 | ||
9b049de8 LC |
527 | (let loop ((channels channels) |
528 | (previous-channels '())) | |
529 | ;; Accumulate a list of instances. A list of processed channels is also | |
530 | ;; accumulated to decide on duplicate channel specifications. | |
531 | (define-values (resulting-channels instances) | |
532 | (fold2 (lambda (channel previous-channels instances) | |
533 | (if (ignore? channel previous-channels) | |
534 | (values previous-channels instances) | |
535 | (begin | |
536 | (format (current-error-port) | |
537 | (G_ "Updating channel '~a' from Git repository at '~a'...~%") | |
538 | (channel-name channel) | |
539 | (channel-url channel)) | |
5bafc70d LC |
540 | (let* ((current (current-commit (channel-name channel))) |
541 | (instance | |
542 | (latest-channel-instance store channel | |
a9eeeaa6 LC |
543 | #:authenticate? |
544 | authenticate? | |
5bafc70d LC |
545 | #:validate-pull |
546 | validate-pull | |
547 | #:starting-commit | |
548 | current))) | |
4ae762af LC |
549 | (when authenticate? |
550 | ;; CHANNEL is authenticated so we can trust the | |
551 | ;; primary URL advertised in its metadata and warn | |
552 | ;; about possibly stale mirrors. | |
553 | (let ((primary-url (channel-instance-primary-url | |
554 | instance))) | |
555 | (unless (or (not primary-url) | |
556 | (channel-commit channel) | |
557 | (string=? primary-url (channel-url channel))) | |
558 | (warning (G_ "pulled channel '~a' from a mirror \ | |
559 | of ~a, which might be stale~%") | |
560 | (channel-name channel) | |
561 | primary-url)))) | |
872898f7 | 562 | |
9b049de8 LC |
563 | (let-values (((new-instances new-channels) |
564 | (loop (channel-instance-dependencies instance) | |
565 | previous-channels))) | |
566 | (values (append (cons channel new-channels) | |
567 | previous-channels) | |
568 | (append (cons instance new-instances) | |
569 | instances))))))) | |
570 | previous-channels | |
571 | '() ;instances | |
572 | channels)) | |
f58f676b | 573 | |
9b049de8 LC |
574 | (let ((instance-name (compose channel-name channel-instance-channel))) |
575 | ;; Remove all earlier channel specifications if they are followed by a | |
576 | ;; more specific one. | |
577 | (values (delete-duplicates instances | |
578 | (lambda (a b) | |
579 | (eq? (instance-name a) (instance-name b)))) | |
580 | resulting-channels)))) | |
0d39a3b9 | 581 | |
fe5db4eb LC |
582 | (define* (checkout->channel-instance checkout |
583 | #:key commit | |
584 | (url checkout) (name 'guix)) | |
585 | "Return a channel instance for CHECKOUT, which is assumed to be a checkout | |
586 | of COMMIT at URL. Use NAME as the channel name." | |
587 | (let* ((commit (or commit (make-string 40 #\0))) | |
588 | (channel (channel (name name) | |
589 | (commit commit) | |
590 | (url url)))) | |
591 | (channel-instance channel commit checkout))) | |
592 | ||
0d39a3b9 LC |
593 | (define %self-build-file |
594 | ;; The file containing code to build Guix. This serves the same purpose as | |
595 | ;; a makefile, and, similarly, is intended to always keep this name. | |
596 | "build-aux/build-self.scm") | |
597 | ||
598 | (define %pull-version | |
599 | ;; This is the version of the 'guix pull' protocol. It specifies what's | |
600 | ;; expected from %SELF-BUILD-FILE. The initial version ("0") was when we'd | |
601 | ;; place a set of compiled Guile modules in ~/.config/guix/latest. | |
602 | 1) | |
603 | ||
acefa740 LC |
604 | (define (standard-module-derivation name source core dependencies) |
605 | "Return a derivation that builds with CORE, a Guix instance, the Scheme | |
606 | modules in SOURCE and that depend on DEPENDENCIES, a list of lowerable | |
607 | objects. The assumption is that SOURCE contains package modules to be added | |
608 | to '%package-module-path'." | |
acefa740 | 609 | |
53f21642 | 610 | (let* ((metadata (read-channel-metadata-from-source source)) |
ce5d9ec8 | 611 | (directory (channel-metadata-directory metadata))) |
53f21642 JN |
612 | |
613 | (define build | |
614 | ;; This is code that we'll run in CORE, a Guix instance, with its own | |
615 | ;; modules and so on. That way, we make sure these modules are built for | |
616 | ;; the right Guile version, with the right dependencies, and that they get | |
617 | ;; to see the right (gnu packages …) modules. | |
618 | (with-extensions dependencies | |
619 | #~(begin | |
620 | (use-modules (guix build compile) | |
621 | (guix build utils) | |
622 | (srfi srfi-26)) | |
623 | ||
624 | (define go | |
625 | (string-append #$output "/lib/guile/" (effective-version) | |
626 | "/site-ccache")) | |
627 | (define scm | |
628 | (string-append #$output "/share/guile/site/" | |
629 | (effective-version))) | |
acefa740 | 630 | |
a514b4ab LC |
631 | (define optimizations-for-level |
632 | ;; Guile 3.0 provides this procedure but Guile 2.2 didn't. | |
633 | ;; Since this code may be executed by either version, we can't | |
634 | ;; rely on its availability. | |
635 | (or (and=> (false-if-exception | |
636 | (resolve-interface '(system base optimize))) | |
637 | (lambda (iface) | |
638 | (module-ref iface 'optimizations-for-level))) | |
639 | (const '()))) | |
640 | ||
641 | (define -O1 | |
642 | ;; Optimize for package module compilation speed. | |
643 | (optimizations-for-level 1)) | |
644 | ||
ce5d9ec8 | 645 | (let* ((subdir #$directory) |
53f21642 | 646 | (source (string-append #$source subdir))) |
a514b4ab LC |
647 | (compile-files source go (find-files source "\\.scm$") |
648 | #:optimization-options (const -O1)) | |
53f21642 JN |
649 | (mkdir-p (dirname scm)) |
650 | (symlink (string-append #$source subdir) scm)) | |
acefa740 | 651 | |
53f21642 | 652 | scm))) |
acefa740 | 653 | |
53f21642 | 654 | (gexp->derivation-in-inferior name build core))) |
0d39a3b9 | 655 | |
37c0d458 LC |
656 | (define* (guile-for-source source #:optional (quirks %quirks)) |
657 | "Return the Guile package to use when building SOURCE or #f if the default | |
658 | '%guile-for-build' should be good enough." | |
659 | (let loop ((quirks quirks)) | |
660 | (match quirks | |
661 | (() | |
662 | #f) | |
663 | (((predicate . guile) rest ...) | |
664 | (if (predicate source) (guile) (loop rest)))))) | |
665 | ||
9db88369 LC |
666 | (define (call-with-guile guile thunk) |
667 | (lambda (store) | |
668 | (values (parameterize ((%guile-for-build | |
669 | (if guile | |
670 | (package-derivation store guile) | |
671 | (%guile-for-build)))) | |
672 | (run-with-store store (thunk))) | |
673 | store))) | |
674 | ||
675 | (define-syntax-rule (with-guile guile exp ...) | |
676 | "Set GUILE as the '%guile-for-build' parameter for the dynamic extent of | |
677 | EXP, a series of monadic expressions." | |
678 | (call-with-guile guile (lambda () | |
679 | (mbegin %store-monad exp ...)))) | |
680 | ||
42a87136 LC |
681 | (define (with-trivial-build-handler mvalue) |
682 | "Run MVALUE, a monadic value, with a \"trivial\" build handler installed | |
683 | that unconditionally resumes the continuation." | |
684 | (lambda (store) | |
685 | (with-build-handler (lambda (continue . _) | |
686 | (continue #t)) | |
687 | (values (run-with-store store mvalue) | |
688 | store)))) | |
689 | ||
316fc2ac | 690 | (define* (build-from-source instance |
34985fb6 | 691 | #:key core verbose? (dependencies '()) system) |
316fc2ac LC |
692 | "Return a derivation to build Guix from INSTANCE, using the self-build |
693 | script contained therein. When CORE is true, build package modules under | |
34985fb6 CB |
694 | SOURCE using CORE, an instance of Guix. By default, build for the current |
695 | system, or SYSTEM if specified." | |
316fc2ac LC |
696 | (define name |
697 | (symbol->string | |
698 | (channel-name (channel-instance-channel instance)))) | |
699 | (define source | |
700 | (channel-instance-checkout instance)) | |
701 | (define commit | |
702 | (channel-instance-commit instance)) | |
703 | ||
0d39a3b9 LC |
704 | ;; Running the self-build script makes it easier to update the build |
705 | ;; procedure: the self-build script of the Guix-to-be-installed contains the | |
706 | ;; right dependencies, build procedure, etc., which the Guix-in-use may not | |
316fc2ac | 707 | ;; know. |
0d39a3b9 LC |
708 | (define script |
709 | (string-append source "/" %self-build-file)) | |
710 | ||
711 | (if (file-exists? script) | |
712 | (let ((build (save-module-excursion | |
713 | (lambda () | |
3a8c4860 LC |
714 | ;; Disable deprecation warnings; it's OK for SCRIPT to |
715 | ;; use deprecated APIs and the user doesn't have to know | |
716 | ;; about it. | |
69962ab7 | 717 | (parameterize ((guix-warning-port |
3a8c4860 | 718 | (%make-void-port "w"))) |
37c0d458 LC |
719 | (primitive-load script))))) |
720 | (guile (guile-for-source source))) | |
0d39a3b9 LC |
721 | ;; BUILD must be a monadic procedure of at least one argument: the |
722 | ;; source tree. | |
723 | ;; | |
724 | ;; Note: BUILD can return #f if it does not support %PULL-VERSION. In | |
725 | ;; the future we'll fall back to a previous version of the protocol | |
726 | ;; when that happens. | |
9db88369 | 727 | (with-guile guile |
42a87136 LC |
728 | ;; BUILD is usually quite costly. Install a "trivial" build handler |
729 | ;; so we don't bounce an outer build-accumulator handler that could | |
730 | ;; cause us to redo half of the BUILD computation several times just | |
731 | ;; to realize it gives the same result. | |
732 | (with-trivial-build-handler | |
316fc2ac LC |
733 | (build source |
734 | #:verbose? verbose? #:version commit | |
34985fb6 | 735 | #:system system |
316fc2ac | 736 | #:channel-metadata (channel-instance->sexp instance) |
42a87136 | 737 | #:pull-version %pull-version)))) |
0d39a3b9 LC |
738 | |
739 | ;; Build a set of modules that extend Guix using the standard method. | |
acefa740 | 740 | (standard-module-derivation name source core dependencies))) |
0d39a3b9 | 741 | |
34985fb6 | 742 | (define* (build-channel-instance instance system |
acefa740 | 743 | #:optional core (dependencies '())) |
0d39a3b9 | 744 | "Return, as a monadic value, the derivation for INSTANCE, a channel |
34985fb6 CB |
745 | instance, for SYSTEM. DEPENDENCIES is a list of extensions providing Guile |
746 | modules that INSTANCE depends on." | |
316fc2ac | 747 | (build-from-source instance |
acefa740 | 748 | #:core core |
34985fb6 CB |
749 | #:dependencies dependencies |
750 | #:system system)) | |
0d39a3b9 | 751 | |
ed75bdf3 LC |
752 | (define (resolve-dependencies instances) |
753 | "Return a procedure that, given one of the elements of INSTANCES, returns | |
754 | list of instances it depends on." | |
755 | (define channel-instance-name | |
756 | (compose channel-name channel-instance-channel)) | |
757 | ||
758 | (define table ;map a name to an instance | |
759 | (fold (lambda (instance table) | |
760 | (vhash-consq (channel-instance-name instance) | |
761 | instance table)) | |
762 | vlist-null | |
763 | instances)) | |
764 | ||
765 | (define edges | |
766 | (fold (lambda (instance edges) | |
767 | (fold (lambda (channel edges) | |
768 | (let ((name (channel-name channel))) | |
769 | (match (vhash-assq name table) | |
770 | ((_ . target) | |
771 | (vhash-consq instance target edges))))) | |
772 | edges | |
773 | (channel-instance-dependencies instance))) | |
774 | vlist-null | |
775 | instances)) | |
776 | ||
777 | (lambda (instance) | |
778 | (vhash-foldq* cons '() instance edges))) | |
779 | ||
34985fb6 | 780 | (define* (channel-instance-derivations instances #:key system) |
0d39a3b9 | 781 | "Return the list of derivations to build INSTANCES, in the same order as |
34985fb6 | 782 | INSTANCES. Build for the current system by default, or SYSTEM if specified." |
0d39a3b9 LC |
783 | (define core-instance |
784 | ;; The 'guix' channel is treated specially: it's an implicit dependency of | |
785 | ;; all the other channels. | |
786 | (find (lambda (instance) | |
787 | (guix-channel? (channel-instance-channel instance))) | |
788 | instances)) | |
789 | ||
ed75bdf3 LC |
790 | (define edges |
791 | (resolve-dependencies instances)) | |
792 | ||
793 | (define (instance->derivation instance) | |
34985fb6 | 794 | (mlet %store-monad ((system (if system (return system) (current-system)))) |
cdf68947 | 795 | (mcached (if (eq? instance core-instance) |
34985fb6 | 796 | (build-channel-instance instance system) |
cdf68947 LC |
797 | (mlet %store-monad ((core (instance->derivation core-instance)) |
798 | (deps (mapm %store-monad instance->derivation | |
799 | (edges instance)))) | |
34985fb6 | 800 | (build-channel-instance instance system core deps))) |
cdf68947 LC |
801 | instance |
802 | system))) | |
ed75bdf3 | 803 | |
ab6025b5 LC |
804 | (unless core-instance |
805 | (let ((loc (and=> (any (compose channel-location channel-instance-channel) | |
806 | instances) | |
807 | source-properties->location))) | |
808 | (raise (apply make-compound-condition | |
809 | (condition | |
810 | (&message (message "'guix' channel is lacking"))) | |
f75243e1 LC |
811 | (condition |
812 | (&fix-hint (hint (G_ "Make sure your list of channels | |
813 | contains one channel named @code{guix} providing the core of Guix.")))) | |
ab6025b5 LC |
814 | (if loc |
815 | (list (condition (&error-location (location loc)))) | |
816 | '()))))) | |
817 | ||
ed75bdf3 | 818 | (mapm %store-monad instance->derivation instances)) |
0d39a3b9 | 819 | |
0d39a3b9 LC |
820 | (define (whole-package-for-legacy name modules) |
821 | "Return a full-blown Guix package for MODULES, a derivation that builds Guix | |
822 | modules in the old ~/.config/guix/latest style." | |
823 | (define packages | |
824 | (resolve-interface '(gnu packages guile))) | |
825 | ||
49c35bbb LC |
826 | (define modules+compiled |
827 | ;; Since MODULES contains both .scm and .go files at its root, re-bundle | |
828 | ;; it so that it has share/guile/site and lib/guile, which is what | |
829 | ;; 'whole-package' expects. | |
830 | (computed-file (derivation-name modules) | |
831 | (with-imported-modules '((guix build utils)) | |
832 | #~(begin | |
833 | (use-modules (guix build utils)) | |
834 | ||
835 | (define version | |
836 | (effective-version)) | |
837 | (define share | |
838 | (string-append #$output "/share/guile/site")) | |
839 | (define lib | |
840 | (string-append #$output "/lib/guile/" version)) | |
841 | ||
842 | (mkdir-p share) (mkdir-p lib) | |
843 | (symlink #$modules (string-append share "/" version)) | |
844 | (symlink #$modules (string-append lib "/site-ccache")))))) | |
845 | ||
0d39a3b9 LC |
846 | (letrec-syntax ((list (syntax-rules (->) |
847 | ((_) | |
848 | '()) | |
849 | ((_ (module -> variable) rest ...) | |
850 | (cons (module-ref (resolve-interface | |
851 | '(gnu packages module)) | |
852 | 'variable) | |
853 | (list rest ...))) | |
854 | ((_ variable rest ...) | |
855 | (cons (module-ref packages 'variable) | |
856 | (list rest ...)))))) | |
49c35bbb | 857 | (whole-package name modules+compiled |
0d39a3b9 LC |
858 | |
859 | ;; In the "old style", %SELF-BUILD-FILE would simply return a | |
860 | ;; derivation that builds modules. We have to infer what the | |
861 | ;; dependencies of these modules were. | |
b74ed909 | 862 | (list guile-json-3 guile-git guile-bytestructures |
6c46e477 LC |
863 | (ssh -> guile-ssh) (tls -> gnutls)) |
864 | #:guile (default-guile)))) | |
0d39a3b9 LC |
865 | |
866 | (define (old-style-guix? drv) | |
867 | "Return true if DRV corresponds to a ~/.config/guix/latest style of | |
868 | derivation." | |
869 | ;; Here we rely on a gross historical fact: that derivations produced by the | |
870 | ;; "old style" (before commit 8a0d9bc8a3f153159d9e239a151c0fa98f1e12d8, | |
871 | ;; dated May 30, 2018) did not depend on "guix-command.drv". | |
872 | (not (find (lambda (input) | |
9af75a26 LC |
873 | (string=? "guix-command" |
874 | (derivation-name | |
875 | (derivation-input-derivation input)))) | |
0d39a3b9 LC |
876 | (derivation-inputs drv)))) |
877 | ||
9272cc70 LC |
878 | (define (channel-instance->sexp instance) |
879 | "Return an sexp representation of INSTANCE, a channel instance." | |
880 | (let* ((commit (channel-instance-commit instance)) | |
881 | (channel (channel-instance-channel instance)) | |
882 | (intro (channel-introduction channel))) | |
883 | `(repository | |
884 | (version 0) | |
885 | (url ,(channel-url channel)) | |
886 | (branch ,(channel-branch channel)) | |
887 | (commit ,commit) | |
a47f16a8 | 888 | (name ,(channel-name channel)) |
9272cc70 LC |
889 | ,@(if intro |
890 | `((introduction | |
891 | (channel-introduction | |
892 | (version 0) | |
893 | (commit | |
894 | ,(channel-introduction-first-signed-commit | |
895 | intro)) | |
896 | (signer | |
897 | ,(openpgp-format-fingerprint | |
898 | (channel-introduction-first-commit-signer | |
899 | intro)))))) | |
900 | '())))) | |
901 | ||
34985fb6 | 902 | (define* (channel-instances->manifest instances #:key system) |
0d39a3b9 | 903 | "Return a profile manifest with entries for all of INSTANCES, a list of |
34985fb6 CB |
904 | channel instances. By default, build for the current system, or SYSTEM if |
905 | specified." | |
d9e6217f | 906 | (define (instance->entry instance drv) |
9272cc70 LC |
907 | (let ((commit (channel-instance-commit instance)) |
908 | (channel (channel-instance-channel instance))) | |
d9e6217f LC |
909 | (manifest-entry |
910 | (name (symbol->string (channel-name channel))) | |
911 | (version (string-take commit 7)) | |
912 | (item (if (guix-channel? channel) | |
913 | (if (old-style-guix? drv) | |
914 | (whole-package-for-legacy (string-append name "-" version) | |
915 | drv) | |
916 | drv) | |
917 | drv)) | |
918 | (properties | |
9272cc70 | 919 | `((source ,(channel-instance->sexp instance))))))) |
0d39a3b9 | 920 | |
34985fb6 CB |
921 | (mlet* %store-monad ((derivations (channel-instance-derivations instances |
922 | #:system system)) | |
d9e6217f | 923 | (entries -> (map instance->entry instances derivations))) |
0d39a3b9 | 924 | (return (manifest entries)))) |
030f1367 | 925 | |
5fbdc9a5 LC |
926 | (define (package-cache-file manifest) |
927 | "Build a package cache file for the instance in MANIFEST. This is meant to | |
928 | be used as a profile hook." | |
c9fbd407 LC |
929 | ;; Note: Emit a profile in format version 3, which was introduced in 2017 |
930 | ;; and is readable by Guix since before version 1.0. This ensures that the | |
931 | ;; Guix in MANIFEST is able to read the manifest file created for its own | |
932 | ;; profile below. See <https://issues.guix.gnu.org/56441>. | |
933 | (let ((profile (profile (content manifest) (hooks '()) | |
934 | (format-version 3)))) | |
5fbdc9a5 LC |
935 | (define build |
936 | #~(begin | |
937 | (use-modules (gnu packages)) | |
938 | ||
939 | (if (defined? 'generate-package-cache) | |
940 | (begin | |
941 | ;; Delegate package cache generation to the inferior. | |
942 | (format (current-error-port) | |
943 | "Generating package cache for '~a'...~%" | |
944 | #$profile) | |
f4041120 JP |
945 | ;; This script runs through (primitive-load), which by default |
946 | ;; doesn't print backtraces when it encounters an exception, | |
947 | ;; so manually do it. Use with-throw-handler because it is | |
948 | ;; supported by all Guile versions. | |
949 | (with-throw-handler #t | |
950 | (lambda () (generate-package-cache #$output)) | |
951 | (lambda (key . args) | |
952 | (backtrace)))) | |
5fbdc9a5 LC |
953 | (mkdir #$output)))) |
954 | ||
955 | (gexp->derivation-in-inferior "guix-package-cache" build | |
956 | profile | |
4035fcba LC |
957 | |
958 | ;; If the Guix in PROFILE is too old and | |
959 | ;; lacks 'guix repl', don't build the cache | |
960 | ;; instead of failing. | |
961 | #:silent-failure? #t | |
962 | ||
5fbdc9a5 | 963 | #:properties '((type . profile-hook) |
f674bc66 LC |
964 | (hook . package-cache)) |
965 | #:local-build? #t))) | |
5fbdc9a5 LC |
966 | |
967 | (define %channel-profile-hooks | |
968 | ;; The default channel profile hooks. | |
969 | (cons package-cache-file %default-profile-hooks)) | |
970 | ||
c37f38bd LC |
971 | (define (channel-instances->derivation instances) |
972 | "Return the derivation of the profile containing INSTANCES, a list of | |
973 | channel instances." | |
974 | (mlet %store-monad ((manifest (channel-instances->manifest instances))) | |
c9fbd407 LC |
975 | ;; Emit a profile in format version so that, if INSTANCES denotes an old |
976 | ;; Guix, it can still read that profile, for instance for the purposes of | |
977 | ;; 'guix describe'. | |
5fbdc9a5 | 978 | (profile-derivation manifest |
c9fbd407 LC |
979 | #:hooks %channel-profile-hooks |
980 | #:format-version 3))) | |
c37f38bd | 981 | |
030f1367 LC |
982 | (define latest-channel-instances* |
983 | (store-lift latest-channel-instances)) | |
984 | ||
872898f7 LC |
985 | (define* (latest-channel-derivation #:optional (channels %default-channels) |
986 | #:key | |
987 | (current-channels '()) | |
988 | (validate-pull | |
989 | ensure-forward-channel-update)) | |
030f1367 | 990 | "Return as a monadic value the derivation that builds the profile for the |
872898f7 LC |
991 | latest instances of CHANNELS. CURRENT-CHANNELS and VALIDATE-PULL are passed |
992 | to 'latest-channel-instances'." | |
993 | (mlet %store-monad ((instances | |
994 | (latest-channel-instances* channels | |
995 | #:current-channels | |
996 | current-channels | |
997 | #:validate-pull | |
998 | validate-pull))) | |
c37f38bd | 999 | (channel-instances->derivation instances))) |
a7c714d3 | 1000 | |
9272cc70 | 1001 | (define* (sexp->channel sexp #:optional (name 'channel)) |
a47f16a8 LC |
1002 | "Read SEXP, a provenance sexp as created by 'channel-instance->sexp'; use |
1003 | NAME as the channel name if SEXP does not specify it. Return #f if the sexp | |
1004 | does not have the expected structure." | |
9272cc70 LC |
1005 | (match sexp |
1006 | (('repository ('version 0) | |
1007 | ('url url) | |
1008 | ('branch branch) | |
1009 | ('commit commit) | |
1010 | rest ...) | |
a47f16a8 LC |
1011 | ;; Historically channel sexps did not include the channel name. It's OK |
1012 | ;; for channels created by 'channel-instances->manifest' because the | |
1013 | ;; entry name is the channel name, but it was missing for entries created | |
1014 | ;; by 'manifest-entry-with-provenance'. | |
1015 | (channel (name (match (assq 'name rest) | |
1016 | (#f name) | |
1017 | (('name name) name))) | |
9272cc70 | 1018 | (url url) |
8f999e1a | 1019 | (branch branch) |
9272cc70 LC |
1020 | (commit commit) |
1021 | (introduction | |
1022 | (match (assq 'introduction rest) | |
1023 | (#f #f) | |
1024 | (('introduction intro) | |
1025 | (sexp->channel-introduction intro)))))) | |
1026 | ||
1027 | (_ #f))) | |
1028 | ||
1029 | (define (manifest-entry-channel entry) | |
1030 | "Return the channel ENTRY corresponds to, or #f if that information is | |
1031 | missing or unreadable. ENTRY must be an entry created by | |
1032 | 'channel-instances->manifest', with the 'source' property." | |
1033 | (let ((name (string->symbol (manifest-entry-name entry)))) | |
1034 | (match (assq-ref (manifest-entry-properties entry) 'source) | |
1035 | ((sexp) | |
1036 | (sexp->channel sexp name)) | |
1037 | (_ | |
1038 | ;; No channel information for this manifest entry. | |
1039 | ;; XXX: Pre-0.15.0 Guix did not provide that information, | |
1040 | ;; but there's not much we can do in that case. | |
1041 | #f)))) | |
1042 | ||
a7c714d3 LC |
1043 | (define (profile-channels profile) |
1044 | "Return the list of channels corresponding to entries in PROFILE. If | |
1045 | PROFILE is not a profile created by 'guix pull', return the empty list." | |
9272cc70 | 1046 | (filter-map manifest-entry-channel |
a7c714d3 LC |
1047 | ;; Show most recently installed packages last. |
1048 | (reverse | |
1049 | (manifest-entries (profile-manifest profile))))) | |
8ba7fd3c | 1050 | |
60d72f53 LC |
1051 | (define* (channel->code channel #:key (include-introduction? #t)) |
1052 | "Return code (an sexp) to build CHANNEL. When INCLUDE-INTRODUCTION? is | |
1053 | true, include its introduction, if any." | |
1054 | (let ((intro (and include-introduction? | |
1055 | (channel-introduction channel)))) | |
1056 | `(channel | |
1057 | (name ',(channel-name channel)) | |
1058 | (url ,(channel-url channel)) | |
b891f851 | 1059 | (branch ,(channel-branch channel)) |
60d72f53 LC |
1060 | (commit ,(channel-commit channel)) |
1061 | ,@(if intro | |
1062 | `((introduction (make-channel-introduction | |
1063 | ,(channel-introduction-first-signed-commit intro) | |
1064 | (openpgp-fingerprint | |
1065 | ,(openpgp-format-fingerprint | |
1066 | (channel-introduction-first-commit-signer | |
1067 | intro)))))) | |
1068 | '())))) | |
1069 | ||
8ba7fd3c LC |
1070 | \f |
1071 | ;;; | |
1072 | ;;; News. | |
1073 | ;;; | |
1074 | ||
1075 | ;; Channel news. | |
1076 | (define-record-type <channel-news> | |
1077 | (channel-news entries) | |
1078 | channel-news? | |
1079 | (entries channel-news-entries)) ;list of <channel-news-entry> | |
1080 | ||
1081 | ;; News entry, associated with a specific commit of the channel. | |
1082 | (define-record-type <channel-news-entry> | |
9719e8d3 | 1083 | (channel-news-entry commit tag title body) |
8ba7fd3c | 1084 | channel-news-entry? |
9719e8d3 LC |
1085 | (commit channel-news-entry-commit) ;hex string | #f |
1086 | (tag channel-news-entry-tag) ;#f | string | |
8ba7fd3c LC |
1087 | (title channel-news-entry-title) ;list of language tag/string pairs |
1088 | (body channel-news-entry-body)) ;list of language tag/string pairs | |
1089 | ||
1090 | (define (sexp->channel-news-entry entry) | |
1091 | "Return the <channel-news-entry> record corresponding to ENTRY, an sexp." | |
1092 | (define (pair language message) | |
1093 | (cons (symbol->string language) message)) | |
1094 | ||
1095 | (match entry | |
9719e8d3 | 1096 | (('entry ((and (or 'commit 'tag) type) commit-or-tag) |
8ba7fd3c LC |
1097 | ('title ((? symbol? title-tags) (? string? titles)) ...) |
1098 | ('body ((? symbol? body-tags) (? string? bodies)) ...) | |
1099 | _ ...) | |
9719e8d3 LC |
1100 | (channel-news-entry (and (eq? type 'commit) commit-or-tag) |
1101 | (and (eq? type 'tag) commit-or-tag) | |
8ba7fd3c LC |
1102 | (map pair title-tags titles) |
1103 | (map pair body-tags bodies))) | |
1104 | (_ | |
1105 | (raise (condition | |
1106 | (&message (message "invalid channel news entry")) | |
1107 | (&error-location | |
1108 | (location (source-properties->location | |
1109 | (source-properties entry))))))))) | |
1110 | ||
1111 | (define (read-channel-news port) | |
1112 | "Read a channel news feed from PORT and return it as a <channel-news> | |
1113 | record." | |
1114 | (match (false-if-exception (read port)) | |
1115 | (('channel-news ('version 0) entries ...) | |
1116 | (channel-news (map sexp->channel-news-entry entries))) | |
1117 | (('channel-news ('version version) _ ...) | |
1118 | ;; This is an unsupported version from the future. There's nothing wrong | |
1119 | ;; with that (the user may simply need to upgrade the 'guix' channel to | |
1120 | ;; be able to read it), so silently ignore it. | |
1121 | (channel-news '())) | |
1122 | (#f | |
1123 | (raise (condition | |
1124 | (&message (message "syntactically invalid channel news file"))))) | |
1125 | (sexp | |
1126 | (raise (condition | |
1127 | (&message (message "invalid channel news file")) | |
1128 | (&error-location | |
1129 | (location (source-properties->location | |
1130 | (source-properties sexp))))))))) | |
1131 | ||
9719e8d3 LC |
1132 | (define (resolve-channel-news-entry-tag repository entry) |
1133 | "If ENTRY has its 'commit' field set, return ENTRY. Otherwise, lookup | |
1134 | ENTRY's 'tag' in REPOSITORY and return ENTRY with its 'commit' field set to | |
1135 | the field its 'tag' refers to. A 'git-error' exception is raised if the tag | |
1136 | cannot be found." | |
1137 | (if (channel-news-entry-commit entry) | |
1138 | entry | |
1139 | (let* ((tag (channel-news-entry-tag entry)) | |
778c1fb4 LC |
1140 | (reference (reference-lookup repository |
1141 | (string-append "refs/tags/" tag))) | |
1142 | (target (reference-target reference)) | |
1143 | (oid (let ((obj (object-lookup repository target))) | |
1144 | (if (= OBJ-TAG (object-type obj)) ;annotated tag? | |
1145 | (tag-target-id (tag-lookup repository target)) | |
1146 | target)))) | |
9719e8d3 LC |
1147 | (channel-news-entry (oid->string oid) tag |
1148 | (channel-news-entry-title entry) | |
1149 | (channel-news-entry-body entry))))) | |
1150 | ||
8ba7fd3c LC |
1151 | (define* (channel-news-for-commit channel new #:optional old) |
1152 | "Return a list of <channel-news-entry> for CHANNEL between commits OLD and | |
1153 | NEW. When OLD is omitted or is #f, return all the news entries of CHANNEL." | |
1154 | (catch 'git-error | |
1155 | (lambda () | |
1156 | (let* ((checkout (update-cached-checkout (channel-url channel) | |
1157 | #:ref `(commit . ,new))) | |
1158 | (metadata (read-channel-metadata-from-source checkout)) | |
1159 | (news-file (channel-metadata-news-file metadata)) | |
1160 | (news-file (and news-file | |
1161 | (string-append checkout "/" news-file)))) | |
1162 | (if (and news-file (file-exists? news-file)) | |
9719e8d3 LC |
1163 | (with-repository checkout repository |
1164 | (let* ((news (call-with-input-file news-file | |
60e0aae8 LC |
1165 | (lambda (port) |
1166 | (set-port-encoding! port | |
1167 | (or (file-encoding port) | |
1168 | "UTF-8")) | |
1169 | (read-channel-news port)))) | |
9719e8d3 LC |
1170 | (entries (map (lambda (entry) |
1171 | (resolve-channel-news-entry-tag repository | |
1172 | entry)) | |
1173 | (channel-news-entries news)))) | |
1174 | (if old | |
8ba7fd3c LC |
1175 | (let* ((new (commit-lookup repository (string->oid new))) |
1176 | (old (commit-lookup repository (string->oid old))) | |
1177 | (commits (list->set | |
1178 | (map (compose oid->string commit-id) | |
1179 | (commit-difference new old))))) | |
1180 | (filter (lambda (entry) | |
1181 | (set-contains? commits | |
1182 | (channel-news-entry-commit entry))) | |
9719e8d3 LC |
1183 | entries)) |
1184 | entries))) | |
8ba7fd3c LC |
1185 | '()))) |
1186 | (lambda (key error . rest) | |
1187 | ;; If commit NEW or commit OLD cannot be found, then something must be | |
1188 | ;; wrong (for example, the history of CHANNEL was rewritten and these | |
1189 | ;; commits no longer exist upstream), so quietly return the empty list. | |
1190 | (if (= GIT_ENOTFOUND (git-error-code error)) | |
1191 | '() | |
1192 | (apply throw key error rest))))) | |
9db88369 LC |
1193 | |
1194 | ;;; Local Variables: | |
1195 | ;;; eval: (put 'with-guile 'scheme-indent-function 1) | |
1196 | ;;; End: |