Commit | Line | Data |
---|---|---|
0d39a3b9 | 1 | ;;; GNU Guix --- Functional package management for GNU |
49c35bbb | 2 | ;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org> |
af12790b | 3 | ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> |
0d39a3b9 LC |
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 channels) | |
21 | #:use-module (guix git) | |
22 | #:use-module (guix records) | |
23 | #:use-module (guix gexp) | |
5fbdc9a5 | 24 | #:use-module (guix modules) |
0d39a3b9 LC |
25 | #:use-module (guix discovery) |
26 | #:use-module (guix monads) | |
27 | #:use-module (guix profiles) | |
28 | #:use-module (guix derivations) | |
f58f676b | 29 | #:use-module (guix combinators) |
3a8c4860 | 30 | #:use-module (guix deprecation) |
0d39a3b9 LC |
31 | #:use-module (guix store) |
32 | #:use-module (guix i18n) | |
ab6025b5 LC |
33 | #:use-module ((guix utils) |
34 | #:select (source-properties->location | |
35 | &error-location)) | |
0d39a3b9 | 36 | #:use-module (srfi srfi-1) |
af12790b | 37 | #:use-module (srfi srfi-2) |
0d39a3b9 LC |
38 | #:use-module (srfi srfi-9) |
39 | #:use-module (srfi srfi-11) | |
ab6025b5 LC |
40 | #:use-module (srfi srfi-34) |
41 | #:use-module (srfi srfi-35) | |
5fbdc9a5 LC |
42 | #:autoload (guix self) (whole-package make-config.scm) |
43 | #:autoload (guix inferior) (gexp->derivation-in-inferior) ;FIXME: circular dep | |
0d39a3b9 | 44 | #:use-module (ice-9 match) |
ed75bdf3 | 45 | #:use-module (ice-9 vlist) |
0d39a3b9 LC |
46 | #:export (channel |
47 | channel? | |
48 | channel-name | |
49 | channel-url | |
50 | channel-branch | |
51 | channel-commit | |
52 | channel-location | |
53 | ||
54 | %default-channels | |
55 | ||
56 | channel-instance? | |
57 | channel-instance-channel | |
58 | channel-instance-commit | |
59 | channel-instance-checkout | |
60 | ||
61 | latest-channel-instances | |
fe5db4eb | 62 | checkout->channel-instance |
030f1367 | 63 | latest-channel-derivation |
c37f38bd | 64 | channel-instances->manifest |
5fbdc9a5 | 65 | %channel-profile-hooks |
c37f38bd | 66 | channel-instances->derivation)) |
0d39a3b9 LC |
67 | |
68 | ;;; Commentary: | |
69 | ;;; | |
70 | ;;; This module implements "channels." A channel is usually a source of | |
71 | ;;; package definitions. There's a special channel, the 'guix' channel, that | |
72 | ;;; provides all of Guix, including its commands and its documentation. | |
73 | ;;; User-defined channels are expected to typically provide a bunch of .scm | |
74 | ;;; files meant to be added to the '%package-search-path'. | |
75 | ;;; | |
76 | ;;; This module provides tools to fetch and update channels from a Git | |
77 | ;;; repository and to build them. | |
78 | ;;; | |
79 | ;;; Code: | |
80 | ||
81 | (define-record-type* <channel> channel make-channel | |
82 | channel? | |
83 | (name channel-name) | |
84 | (url channel-url) | |
85 | (branch channel-branch (default "master")) | |
86 | (commit channel-commit (default #f)) | |
87 | (location channel-location | |
88 | (default (current-source-location)) (innate))) | |
0d39a3b9 LC |
89 | |
90 | (define %default-channels | |
91 | ;; Default list of channels. | |
92 | (list (channel | |
93 | (name 'guix) | |
37a6cdbf | 94 | (branch "master") |
0d39a3b9 LC |
95 | (url "https://git.savannah.gnu.org/git/guix.git")))) |
96 | ||
97 | (define (guix-channel? channel) | |
98 | "Return true if CHANNEL is the 'guix' channel." | |
99 | (eq? 'guix (channel-name channel))) | |
100 | ||
101 | (define-record-type <channel-instance> | |
102 | (channel-instance channel commit checkout) | |
103 | channel-instance? | |
104 | (channel channel-instance-channel) | |
105 | (commit channel-instance-commit) | |
106 | (checkout channel-instance-checkout)) | |
107 | ||
af12790b RW |
108 | (define-record-type <channel-metadata> |
109 | (channel-metadata version dependencies) | |
110 | channel-metadata? | |
111 | (version channel-metadata-version) | |
112 | (dependencies channel-metadata-dependencies)) | |
113 | ||
0d39a3b9 LC |
114 | (define (channel-reference channel) |
115 | "Return the \"reference\" for CHANNEL, an sexp suitable for | |
116 | 'latest-repository-commit'." | |
117 | (match (channel-commit channel) | |
118 | (#f `(branch . ,(channel-branch channel))) | |
119 | (commit `(commit . ,(channel-commit channel))))) | |
120 | ||
af12790b RW |
121 | (define (read-channel-metadata instance) |
122 | "Return a channel-metadata record read from the channel INSTANCE's | |
123 | description file, or return #F if the channel instance does not include the | |
124 | file." | |
125 | (let* ((source (channel-instance-checkout instance)) | |
126 | (meta-file (string-append source "/.guix-channel"))) | |
127 | (and (file-exists? meta-file) | |
128 | (and-let* ((raw (call-with-input-file meta-file read)) | |
129 | (version (and=> (assoc-ref raw 'version) first)) | |
130 | (dependencies (or (assoc-ref raw 'dependencies) '()))) | |
131 | (channel-metadata | |
132 | version | |
133 | (map (lambda (item) | |
134 | (let ((get (lambda* (key #:optional default) | |
135 | (or (and=> (assoc-ref item key) first) default)))) | |
136 | (and-let* ((name (get 'name)) | |
137 | (url (get 'url)) | |
138 | (branch (get 'branch "master"))) | |
139 | (channel | |
140 | (name name) | |
141 | (branch branch) | |
142 | (url url) | |
143 | (commit (get 'commit)))))) | |
144 | dependencies)))))) | |
145 | ||
146 | (define (channel-instance-dependencies instance) | |
147 | "Return the list of channels that are declared as dependencies for the given | |
148 | channel INSTANCE." | |
149 | (match (read-channel-metadata instance) | |
150 | (#f '()) | |
151 | (($ <channel-metadata> version dependencies) | |
152 | dependencies))) | |
153 | ||
154 | (define* (latest-channel-instances store channels #:optional (previous-channels '())) | |
0d39a3b9 | 155 | "Return a list of channel instances corresponding to the latest checkouts of |
af12790b RW |
156 | CHANNELS and the channels on which they depend. PREVIOUS-CHANNELS is a list |
157 | of previously processed channels." | |
158 | ;; Only process channels that are unique, or that are more specific than a | |
159 | ;; previous channel specification. | |
160 | (define (ignore? channel others) | |
161 | (member channel others | |
162 | (lambda (a b) | |
163 | (and (eq? (channel-name a) (channel-name b)) | |
164 | (or (channel-commit b) | |
165 | (not (or (channel-commit a) | |
166 | (channel-commit b)))))))) | |
f58f676b | 167 | |
af12790b RW |
168 | ;; Accumulate a list of instances. A list of processed channels is also |
169 | ;; accumulated to decide on duplicate channel specifications. | |
f58f676b LC |
170 | (define-values (resulting-channels instances) |
171 | (fold2 (lambda (channel previous-channels instances) | |
172 | (if (ignore? channel previous-channels) | |
173 | (values previous-channels instances) | |
174 | (begin | |
175 | (format (current-error-port) | |
176 | (G_ "Updating channel '~a' from Git repository at '~a'...~%") | |
177 | (channel-name channel) | |
178 | (channel-url channel)) | |
179 | (let-values (((checkout commit) | |
180 | (latest-repository-commit store (channel-url channel) | |
181 | #:ref (channel-reference | |
182 | channel)))) | |
183 | (let ((instance (channel-instance channel commit checkout))) | |
184 | (let-values (((new-instances new-channels) | |
185 | (latest-channel-instances | |
186 | store | |
187 | (channel-instance-dependencies instance) | |
188 | previous-channels))) | |
189 | (values (append (cons channel new-channels) | |
190 | previous-channels) | |
191 | (append (cons instance new-instances) | |
192 | instances)))))))) | |
193 | previous-channels | |
194 | '() ;instances | |
195 | channels)) | |
196 | ||
197 | (let ((instance-name (compose channel-name channel-instance-channel))) | |
198 | ;; Remove all earlier channel specifications if they are followed by a | |
199 | ;; more specific one. | |
200 | (values (delete-duplicates instances | |
201 | (lambda (a b) | |
202 | (eq? (instance-name a) (instance-name b)))) | |
203 | resulting-channels))) | |
0d39a3b9 | 204 | |
fe5db4eb LC |
205 | (define* (checkout->channel-instance checkout |
206 | #:key commit | |
207 | (url checkout) (name 'guix)) | |
208 | "Return a channel instance for CHECKOUT, which is assumed to be a checkout | |
209 | of COMMIT at URL. Use NAME as the channel name." | |
210 | (let* ((commit (or commit (make-string 40 #\0))) | |
211 | (channel (channel (name name) | |
212 | (commit commit) | |
213 | (url url)))) | |
214 | (channel-instance channel commit checkout))) | |
215 | ||
0d39a3b9 LC |
216 | (define %self-build-file |
217 | ;; The file containing code to build Guix. This serves the same purpose as | |
218 | ;; a makefile, and, similarly, is intended to always keep this name. | |
219 | "build-aux/build-self.scm") | |
220 | ||
221 | (define %pull-version | |
222 | ;; This is the version of the 'guix pull' protocol. It specifies what's | |
223 | ;; expected from %SELF-BUILD-FILE. The initial version ("0") was when we'd | |
224 | ;; place a set of compiled Guile modules in ~/.config/guix/latest. | |
225 | 1) | |
226 | ||
acefa740 LC |
227 | (define (standard-module-derivation name source core dependencies) |
228 | "Return a derivation that builds with CORE, a Guix instance, the Scheme | |
229 | modules in SOURCE and that depend on DEPENDENCIES, a list of lowerable | |
230 | objects. The assumption is that SOURCE contains package modules to be added | |
231 | to '%package-module-path'." | |
0d39a3b9 LC |
232 | ;; FIXME: We should load, say SOURCE/.guix-channel.scm, which would allow |
233 | ;; channel publishers to specify things such as the sub-directory where .scm | |
234 | ;; files live, files to exclude from the channel, preferred substitute URLs, | |
235 | ;; etc. | |
acefa740 LC |
236 | |
237 | (define build | |
238 | ;; This is code that we'll run in CORE, a Guix instance, with its own | |
239 | ;; modules and so on. That way, we make sure these modules are built for | |
240 | ;; the right Guile version, with the right dependencies, and that they get | |
241 | ;; to see the right (gnu packages …) modules. | |
242 | (with-extensions dependencies | |
243 | #~(begin | |
244 | (use-modules (guix build compile) | |
245 | (guix build utils) | |
246 | (srfi srfi-26)) | |
247 | ||
248 | (define go | |
249 | (string-append #$output "/lib/guile/" (effective-version) | |
250 | "/site-ccache")) | |
251 | (define scm | |
252 | (string-append #$output "/share/guile/site/" | |
253 | (effective-version))) | |
254 | ||
255 | (compile-files #$source go | |
256 | (find-files #$source "\\.scm$")) | |
257 | (mkdir-p (dirname scm)) | |
258 | (symlink #$source scm) | |
259 | scm))) | |
260 | ||
261 | (gexp->derivation-in-inferior name build core)) | |
0d39a3b9 LC |
262 | |
263 | (define* (build-from-source name source | |
acefa740 | 264 | #:key core verbose? commit |
0d39a3b9 LC |
265 | (dependencies '())) |
266 | "Return a derivation to build Guix from SOURCE, using the self-build script | |
acefa740 LC |
267 | contained therein; use COMMIT as the version string. When CORE is true, build |
268 | package modules under SOURCE using CORE, an instance of Guix." | |
0d39a3b9 LC |
269 | ;; Running the self-build script makes it easier to update the build |
270 | ;; procedure: the self-build script of the Guix-to-be-installed contains the | |
271 | ;; right dependencies, build procedure, etc., which the Guix-in-use may not | |
272 | ;; be know. | |
273 | (define script | |
274 | (string-append source "/" %self-build-file)) | |
275 | ||
276 | (if (file-exists? script) | |
277 | (let ((build (save-module-excursion | |
278 | (lambda () | |
3a8c4860 LC |
279 | ;; Disable deprecation warnings; it's OK for SCRIPT to |
280 | ;; use deprecated APIs and the user doesn't have to know | |
281 | ;; about it. | |
282 | (parameterize ((deprecation-warning-port | |
283 | (%make-void-port "w"))) | |
284 | (primitive-load script)))))) | |
0d39a3b9 LC |
285 | ;; BUILD must be a monadic procedure of at least one argument: the |
286 | ;; source tree. | |
287 | ;; | |
288 | ;; Note: BUILD can return #f if it does not support %PULL-VERSION. In | |
289 | ;; the future we'll fall back to a previous version of the protocol | |
290 | ;; when that happens. | |
291 | (build source #:verbose? verbose? #:version commit | |
292 | #:pull-version %pull-version)) | |
293 | ||
294 | ;; Build a set of modules that extend Guix using the standard method. | |
acefa740 | 295 | (standard-module-derivation name source core dependencies))) |
0d39a3b9 | 296 | |
acefa740 LC |
297 | (define* (build-channel-instance instance |
298 | #:optional core (dependencies '())) | |
0d39a3b9 LC |
299 | "Return, as a monadic value, the derivation for INSTANCE, a channel |
300 | instance. DEPENDENCIES is a list of extensions providing Guile modules that | |
301 | INSTANCE depends on." | |
302 | (build-from-source (symbol->string | |
303 | (channel-name (channel-instance-channel instance))) | |
304 | (channel-instance-checkout instance) | |
305 | #:commit (channel-instance-commit instance) | |
acefa740 | 306 | #:core core |
0d39a3b9 LC |
307 | #:dependencies dependencies)) |
308 | ||
ed75bdf3 LC |
309 | (define (resolve-dependencies instances) |
310 | "Return a procedure that, given one of the elements of INSTANCES, returns | |
311 | list of instances it depends on." | |
312 | (define channel-instance-name | |
313 | (compose channel-name channel-instance-channel)) | |
314 | ||
315 | (define table ;map a name to an instance | |
316 | (fold (lambda (instance table) | |
317 | (vhash-consq (channel-instance-name instance) | |
318 | instance table)) | |
319 | vlist-null | |
320 | instances)) | |
321 | ||
322 | (define edges | |
323 | (fold (lambda (instance edges) | |
324 | (fold (lambda (channel edges) | |
325 | (let ((name (channel-name channel))) | |
326 | (match (vhash-assq name table) | |
327 | ((_ . target) | |
328 | (vhash-consq instance target edges))))) | |
329 | edges | |
330 | (channel-instance-dependencies instance))) | |
331 | vlist-null | |
332 | instances)) | |
333 | ||
334 | (lambda (instance) | |
335 | (vhash-foldq* cons '() instance edges))) | |
336 | ||
0d39a3b9 LC |
337 | (define (channel-instance-derivations instances) |
338 | "Return the list of derivations to build INSTANCES, in the same order as | |
339 | INSTANCES." | |
340 | (define core-instance | |
341 | ;; The 'guix' channel is treated specially: it's an implicit dependency of | |
342 | ;; all the other channels. | |
343 | (find (lambda (instance) | |
344 | (guix-channel? (channel-instance-channel instance))) | |
345 | instances)) | |
346 | ||
ed75bdf3 LC |
347 | (define edges |
348 | (resolve-dependencies instances)) | |
349 | ||
350 | (define (instance->derivation instance) | |
351 | (mcached (if (eq? instance core-instance) | |
352 | (build-channel-instance instance) | |
353 | (mlet %store-monad ((core (instance->derivation core-instance)) | |
354 | (deps (mapm %store-monad instance->derivation | |
355 | (edges instance)))) | |
acefa740 | 356 | (build-channel-instance instance core deps))) |
ed75bdf3 LC |
357 | instance)) |
358 | ||
ab6025b5 LC |
359 | (unless core-instance |
360 | (let ((loc (and=> (any (compose channel-location channel-instance-channel) | |
361 | instances) | |
362 | source-properties->location))) | |
363 | (raise (apply make-compound-condition | |
364 | (condition | |
365 | (&message (message "'guix' channel is lacking"))) | |
366 | (if loc | |
367 | (list (condition (&error-location (location loc)))) | |
368 | '()))))) | |
369 | ||
ed75bdf3 | 370 | (mapm %store-monad instance->derivation instances)) |
0d39a3b9 | 371 | |
0d39a3b9 LC |
372 | (define (whole-package-for-legacy name modules) |
373 | "Return a full-blown Guix package for MODULES, a derivation that builds Guix | |
374 | modules in the old ~/.config/guix/latest style." | |
375 | (define packages | |
376 | (resolve-interface '(gnu packages guile))) | |
377 | ||
49c35bbb LC |
378 | (define modules+compiled |
379 | ;; Since MODULES contains both .scm and .go files at its root, re-bundle | |
380 | ;; it so that it has share/guile/site and lib/guile, which is what | |
381 | ;; 'whole-package' expects. | |
382 | (computed-file (derivation-name modules) | |
383 | (with-imported-modules '((guix build utils)) | |
384 | #~(begin | |
385 | (use-modules (guix build utils)) | |
386 | ||
387 | (define version | |
388 | (effective-version)) | |
389 | (define share | |
390 | (string-append #$output "/share/guile/site")) | |
391 | (define lib | |
392 | (string-append #$output "/lib/guile/" version)) | |
393 | ||
394 | (mkdir-p share) (mkdir-p lib) | |
395 | (symlink #$modules (string-append share "/" version)) | |
396 | (symlink #$modules (string-append lib "/site-ccache")))))) | |
397 | ||
0d39a3b9 LC |
398 | (letrec-syntax ((list (syntax-rules (->) |
399 | ((_) | |
400 | '()) | |
401 | ((_ (module -> variable) rest ...) | |
402 | (cons (module-ref (resolve-interface | |
403 | '(gnu packages module)) | |
404 | 'variable) | |
405 | (list rest ...))) | |
406 | ((_ variable rest ...) | |
407 | (cons (module-ref packages 'variable) | |
408 | (list rest ...)))))) | |
49c35bbb | 409 | (whole-package name modules+compiled |
0d39a3b9 LC |
410 | |
411 | ;; In the "old style", %SELF-BUILD-FILE would simply return a | |
412 | ;; derivation that builds modules. We have to infer what the | |
413 | ;; dependencies of these modules were. | |
414 | (list guile-json guile-git guile-bytestructures | |
415 | (ssh -> guile-ssh) (tls -> gnutls))))) | |
416 | ||
417 | (define (old-style-guix? drv) | |
418 | "Return true if DRV corresponds to a ~/.config/guix/latest style of | |
419 | derivation." | |
420 | ;; Here we rely on a gross historical fact: that derivations produced by the | |
421 | ;; "old style" (before commit 8a0d9bc8a3f153159d9e239a151c0fa98f1e12d8, | |
422 | ;; dated May 30, 2018) did not depend on "guix-command.drv". | |
423 | (not (find (lambda (input) | |
424 | (string-suffix? "-guix-command.drv" | |
425 | (derivation-input-path input))) | |
426 | (derivation-inputs drv)))) | |
427 | ||
428 | (define (channel-instances->manifest instances) | |
429 | "Return a profile manifest with entries for all of INSTANCES, a list of | |
430 | channel instances." | |
431 | (define instance->entry | |
432 | (match-lambda | |
433 | ((instance drv) | |
434 | (let ((commit (channel-instance-commit instance)) | |
435 | (channel (channel-instance-channel instance))) | |
436 | (with-monad %store-monad | |
437 | (return (manifest-entry | |
438 | (name (symbol->string (channel-name channel))) | |
439 | (version (string-take commit 7)) | |
440 | (item (if (guix-channel? channel) | |
441 | (if (old-style-guix? drv) | |
442 | (whole-package-for-legacy | |
443 | (string-append name "-" version) | |
444 | drv) | |
445 | drv) | |
446 | drv)) | |
447 | (properties | |
448 | `((source (repository | |
449 | (version 0) | |
450 | (url ,(channel-url channel)) | |
451 | (branch ,(channel-branch channel)) | |
452 | (commit ,commit)))))))))))) | |
453 | ||
454 | (mlet* %store-monad ((derivations (channel-instance-derivations instances)) | |
455 | (entries (mapm %store-monad instance->entry | |
456 | (zip instances derivations)))) | |
457 | (return (manifest entries)))) | |
030f1367 | 458 | |
5fbdc9a5 LC |
459 | (define (package-cache-file manifest) |
460 | "Build a package cache file for the instance in MANIFEST. This is meant to | |
461 | be used as a profile hook." | |
462 | (mlet %store-monad ((profile (profile-derivation manifest | |
463 | #:hooks '()))) | |
464 | ||
465 | (define build | |
466 | #~(begin | |
467 | (use-modules (gnu packages)) | |
468 | ||
469 | (if (defined? 'generate-package-cache) | |
470 | (begin | |
471 | ;; Delegate package cache generation to the inferior. | |
472 | (format (current-error-port) | |
473 | "Generating package cache for '~a'...~%" | |
474 | #$profile) | |
475 | (generate-package-cache #$output)) | |
476 | (mkdir #$output)))) | |
477 | ||
478 | (gexp->derivation-in-inferior "guix-package-cache" build | |
479 | profile | |
480 | #:properties '((type . profile-hook) | |
f674bc66 LC |
481 | (hook . package-cache)) |
482 | #:local-build? #t))) | |
5fbdc9a5 LC |
483 | |
484 | (define %channel-profile-hooks | |
485 | ;; The default channel profile hooks. | |
486 | (cons package-cache-file %default-profile-hooks)) | |
487 | ||
c37f38bd LC |
488 | (define (channel-instances->derivation instances) |
489 | "Return the derivation of the profile containing INSTANCES, a list of | |
490 | channel instances." | |
491 | (mlet %store-monad ((manifest (channel-instances->manifest instances))) | |
5fbdc9a5 LC |
492 | (profile-derivation manifest |
493 | #:hooks %channel-profile-hooks))) | |
c37f38bd | 494 | |
030f1367 LC |
495 | (define latest-channel-instances* |
496 | (store-lift latest-channel-instances)) | |
497 | ||
498 | (define* (latest-channel-derivation #:optional (channels %default-channels)) | |
499 | "Return as a monadic value the derivation that builds the profile for the | |
500 | latest instances of CHANNELS." | |
c37f38bd LC |
501 | (mlet %store-monad ((instances (latest-channel-instances* channels))) |
502 | (channel-instances->derivation instances))) |