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> |
53f21642 | 4 | ;;; Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> |
0d39a3b9 LC |
5 | ;;; |
6 | ;;; This file is part of GNU Guix. | |
7 | ;;; | |
8 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
9 | ;;; under the terms of the GNU General Public License as published by | |
10 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
11 | ;;; your option) any later version. | |
12 | ;;; | |
13 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
14 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
15 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
16 | ;;; GNU General Public License for more details. | |
17 | ;;; | |
18 | ;;; You should have received a copy of the GNU General Public License | |
19 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
20 | ||
21 | (define-module (guix channels) | |
8ba7fd3c | 22 | #:use-module (git) |
0d39a3b9 LC |
23 | #:use-module (guix git) |
24 | #:use-module (guix records) | |
25 | #:use-module (guix gexp) | |
5fbdc9a5 | 26 | #:use-module (guix modules) |
0d39a3b9 LC |
27 | #:use-module (guix discovery) |
28 | #:use-module (guix monads) | |
29 | #:use-module (guix profiles) | |
37c0d458 | 30 | #:use-module (guix packages) |
0d39a3b9 | 31 | #:use-module (guix derivations) |
f58f676b | 32 | #:use-module (guix combinators) |
69962ab7 | 33 | #:use-module (guix diagnostics) |
8ba7fd3c | 34 | #:use-module (guix sets) |
0d39a3b9 LC |
35 | #:use-module (guix store) |
36 | #:use-module (guix i18n) | |
ab6025b5 LC |
37 | #:use-module ((guix utils) |
38 | #:select (source-properties->location | |
39 | &error-location)) | |
0d39a3b9 | 40 | #:use-module (srfi srfi-1) |
af12790b | 41 | #:use-module (srfi srfi-2) |
0d39a3b9 LC |
42 | #:use-module (srfi srfi-9) |
43 | #:use-module (srfi srfi-11) | |
9719e8d3 | 44 | #:use-module (srfi srfi-26) |
ab6025b5 LC |
45 | #:use-module (srfi srfi-34) |
46 | #:use-module (srfi srfi-35) | |
5fbdc9a5 LC |
47 | #:autoload (guix self) (whole-package make-config.scm) |
48 | #:autoload (guix inferior) (gexp->derivation-in-inferior) ;FIXME: circular dep | |
0d39a3b9 | 49 | #:use-module (ice-9 match) |
ed75bdf3 | 50 | #:use-module (ice-9 vlist) |
37c0d458 | 51 | #:use-module ((ice-9 rdelim) #:select (read-string)) |
0d39a3b9 LC |
52 | #:export (channel |
53 | channel? | |
54 | channel-name | |
55 | channel-url | |
56 | channel-branch | |
57 | channel-commit | |
58 | channel-location | |
59 | ||
60 | %default-channels | |
72f749dc | 61 | guix-channel? |
0d39a3b9 LC |
62 | |
63 | channel-instance? | |
64 | channel-instance-channel | |
65 | channel-instance-commit | |
66 | channel-instance-checkout | |
67 | ||
68 | latest-channel-instances | |
fe5db4eb | 69 | checkout->channel-instance |
030f1367 | 70 | latest-channel-derivation |
c37f38bd | 71 | channel-instances->manifest |
5fbdc9a5 | 72 | %channel-profile-hooks |
a7c714d3 LC |
73 | channel-instances->derivation |
74 | ||
8ba7fd3c LC |
75 | profile-channels |
76 | ||
77 | channel-news-entry? | |
78 | channel-news-entry-commit | |
9719e8d3 | 79 | channel-news-entry-tag |
8ba7fd3c LC |
80 | channel-news-entry-title |
81 | channel-news-entry-body | |
82 | ||
83 | channel-news-for-commit)) | |
0d39a3b9 LC |
84 | |
85 | ;;; Commentary: | |
86 | ;;; | |
87 | ;;; This module implements "channels." A channel is usually a source of | |
88 | ;;; package definitions. There's a special channel, the 'guix' channel, that | |
89 | ;;; provides all of Guix, including its commands and its documentation. | |
90 | ;;; User-defined channels are expected to typically provide a bunch of .scm | |
91 | ;;; files meant to be added to the '%package-search-path'. | |
92 | ;;; | |
93 | ;;; This module provides tools to fetch and update channels from a Git | |
94 | ;;; repository and to build them. | |
95 | ;;; | |
96 | ;;; Code: | |
97 | ||
98 | (define-record-type* <channel> channel make-channel | |
99 | channel? | |
100 | (name channel-name) | |
101 | (url channel-url) | |
102 | (branch channel-branch (default "master")) | |
103 | (commit channel-commit (default #f)) | |
104 | (location channel-location | |
105 | (default (current-source-location)) (innate))) | |
0d39a3b9 LC |
106 | |
107 | (define %default-channels | |
108 | ;; Default list of channels. | |
109 | (list (channel | |
110 | (name 'guix) | |
37a6cdbf | 111 | (branch "master") |
0d39a3b9 LC |
112 | (url "https://git.savannah.gnu.org/git/guix.git")))) |
113 | ||
114 | (define (guix-channel? channel) | |
115 | "Return true if CHANNEL is the 'guix' channel." | |
116 | (eq? 'guix (channel-name channel))) | |
117 | ||
118 | (define-record-type <channel-instance> | |
119 | (channel-instance channel commit checkout) | |
120 | channel-instance? | |
121 | (channel channel-instance-channel) | |
122 | (commit channel-instance-commit) | |
123 | (checkout channel-instance-checkout)) | |
124 | ||
af12790b | 125 | (define-record-type <channel-metadata> |
8ba7fd3c | 126 | (channel-metadata directory dependencies news-file) |
af12790b | 127 | channel-metadata? |
ce5d9ec8 | 128 | (directory channel-metadata-directory) ;string with leading slash |
8ba7fd3c LC |
129 | (dependencies channel-metadata-dependencies) ;list of <channel> |
130 | (news-file channel-metadata-news-file)) ;string | #f | |
af12790b | 131 | |
0d39a3b9 LC |
132 | (define (channel-reference channel) |
133 | "Return the \"reference\" for CHANNEL, an sexp suitable for | |
134 | 'latest-repository-commit'." | |
135 | (match (channel-commit channel) | |
136 | (#f `(branch . ,(channel-branch channel))) | |
137 | (commit `(commit . ,(channel-commit channel))))) | |
138 | ||
45b90332 LC |
139 | (define (read-channel-metadata port) |
140 | "Read from PORT channel metadata in the format expected for the | |
141 | '.guix-channel' file. Return a <channel-metadata> record, or raise an error | |
142 | if valid metadata could not be read from PORT." | |
143 | (match (read port) | |
144 | (('channel ('version 0) properties ...) | |
145 | (let ((directory (and=> (assoc-ref properties 'directory) first)) | |
8ba7fd3c LC |
146 | (dependencies (or (assoc-ref properties 'dependencies) '())) |
147 | (news-file (and=> (assoc-ref properties 'news-file) first))) | |
45b90332 | 148 | (channel-metadata |
8ba7fd3c | 149 | (cond ((not directory) "/") ;directory |
ce5d9ec8 LC |
150 | ((string-prefix? "/" directory) directory) |
151 | (else (string-append "/" directory))) | |
8ba7fd3c | 152 | (map (lambda (item) ;dependencies |
45b90332 LC |
153 | (let ((get (lambda* (key #:optional default) |
154 | (or (and=> (assoc-ref item key) first) default)))) | |
155 | (and-let* ((name (get 'name)) | |
156 | (url (get 'url)) | |
157 | (branch (get 'branch "master"))) | |
158 | (channel | |
159 | (name name) | |
160 | (branch branch) | |
161 | (url url) | |
162 | (commit (get 'commit)))))) | |
8ba7fd3c LC |
163 | dependencies) |
164 | news-file))) ;news-file | |
45b90332 LC |
165 | ((and ('channel ('version version) _ ...) sexp) |
166 | (raise (condition | |
167 | (&message (message "unsupported '.guix-channel' version")) | |
168 | (&error-location | |
169 | (location (source-properties->location | |
170 | (source-properties sexp))))))) | |
171 | (sexp | |
172 | (raise (condition | |
173 | (&message (message "invalid '.guix-channel' file")) | |
174 | (&error-location | |
175 | (location (source-properties->location | |
176 | (source-properties sexp))))))))) | |
177 | ||
53f21642 JN |
178 | (define (read-channel-metadata-from-source source) |
179 | "Return a channel-metadata record read from channel's SOURCE/.guix-channel | |
ce5d9ec8 LC |
180 | description file, or return the default channel-metadata record if that file |
181 | doesn't exist." | |
45b90332 LC |
182 | (catch 'system-error |
183 | (lambda () | |
184 | (call-with-input-file (string-append source "/.guix-channel") | |
185 | read-channel-metadata)) | |
186 | (lambda args | |
187 | (if (= ENOENT (system-error-errno args)) | |
8ba7fd3c | 188 | (channel-metadata "/" '() #f) |
45b90332 LC |
189 | (apply throw args))))) |
190 | ||
191 | (define (channel-instance-metadata instance) | |
53f21642 | 192 | "Return a channel-metadata record read from the channel INSTANCE's |
ce5d9ec8 | 193 | description file or its default value." |
53f21642 JN |
194 | (read-channel-metadata-from-source (channel-instance-checkout instance))) |
195 | ||
af12790b RW |
196 | (define (channel-instance-dependencies instance) |
197 | "Return the list of channels that are declared as dependencies for the given | |
198 | channel INSTANCE." | |
ce5d9ec8 | 199 | (channel-metadata-dependencies (channel-instance-metadata instance))) |
af12790b RW |
200 | |
201 | (define* (latest-channel-instances store channels #:optional (previous-channels '())) | |
0d39a3b9 | 202 | "Return a list of channel instances corresponding to the latest checkouts of |
af12790b RW |
203 | CHANNELS and the channels on which they depend. PREVIOUS-CHANNELS is a list |
204 | of previously processed channels." | |
205 | ;; Only process channels that are unique, or that are more specific than a | |
206 | ;; previous channel specification. | |
207 | (define (ignore? channel others) | |
208 | (member channel others | |
209 | (lambda (a b) | |
210 | (and (eq? (channel-name a) (channel-name b)) | |
211 | (or (channel-commit b) | |
212 | (not (or (channel-commit a) | |
213 | (channel-commit b)))))))) | |
f58f676b | 214 | |
af12790b RW |
215 | ;; Accumulate a list of instances. A list of processed channels is also |
216 | ;; accumulated to decide on duplicate channel specifications. | |
f58f676b LC |
217 | (define-values (resulting-channels instances) |
218 | (fold2 (lambda (channel previous-channels instances) | |
219 | (if (ignore? channel previous-channels) | |
220 | (values previous-channels instances) | |
221 | (begin | |
222 | (format (current-error-port) | |
223 | (G_ "Updating channel '~a' from Git repository at '~a'...~%") | |
224 | (channel-name channel) | |
225 | (channel-url channel)) | |
226 | (let-values (((checkout commit) | |
227 | (latest-repository-commit store (channel-url channel) | |
228 | #:ref (channel-reference | |
229 | channel)))) | |
230 | (let ((instance (channel-instance channel commit checkout))) | |
231 | (let-values (((new-instances new-channels) | |
232 | (latest-channel-instances | |
233 | store | |
234 | (channel-instance-dependencies instance) | |
235 | previous-channels))) | |
236 | (values (append (cons channel new-channels) | |
237 | previous-channels) | |
238 | (append (cons instance new-instances) | |
239 | instances)))))))) | |
240 | previous-channels | |
241 | '() ;instances | |
242 | channels)) | |
243 | ||
244 | (let ((instance-name (compose channel-name channel-instance-channel))) | |
245 | ;; Remove all earlier channel specifications if they are followed by a | |
246 | ;; more specific one. | |
247 | (values (delete-duplicates instances | |
248 | (lambda (a b) | |
249 | (eq? (instance-name a) (instance-name b)))) | |
250 | resulting-channels))) | |
0d39a3b9 | 251 | |
fe5db4eb LC |
252 | (define* (checkout->channel-instance checkout |
253 | #:key commit | |
254 | (url checkout) (name 'guix)) | |
255 | "Return a channel instance for CHECKOUT, which is assumed to be a checkout | |
256 | of COMMIT at URL. Use NAME as the channel name." | |
257 | (let* ((commit (or commit (make-string 40 #\0))) | |
258 | (channel (channel (name name) | |
259 | (commit commit) | |
260 | (url url)))) | |
261 | (channel-instance channel commit checkout))) | |
262 | ||
0d39a3b9 LC |
263 | (define %self-build-file |
264 | ;; The file containing code to build Guix. This serves the same purpose as | |
265 | ;; a makefile, and, similarly, is intended to always keep this name. | |
266 | "build-aux/build-self.scm") | |
267 | ||
268 | (define %pull-version | |
269 | ;; This is the version of the 'guix pull' protocol. It specifies what's | |
270 | ;; expected from %SELF-BUILD-FILE. The initial version ("0") was when we'd | |
271 | ;; place a set of compiled Guile modules in ~/.config/guix/latest. | |
272 | 1) | |
273 | ||
acefa740 LC |
274 | (define (standard-module-derivation name source core dependencies) |
275 | "Return a derivation that builds with CORE, a Guix instance, the Scheme | |
276 | modules in SOURCE and that depend on DEPENDENCIES, a list of lowerable | |
277 | objects. The assumption is that SOURCE contains package modules to be added | |
278 | to '%package-module-path'." | |
acefa740 | 279 | |
53f21642 | 280 | (let* ((metadata (read-channel-metadata-from-source source)) |
ce5d9ec8 | 281 | (directory (channel-metadata-directory metadata))) |
53f21642 JN |
282 | |
283 | (define build | |
284 | ;; This is code that we'll run in CORE, a Guix instance, with its own | |
285 | ;; modules and so on. That way, we make sure these modules are built for | |
286 | ;; the right Guile version, with the right dependencies, and that they get | |
287 | ;; to see the right (gnu packages …) modules. | |
288 | (with-extensions dependencies | |
289 | #~(begin | |
290 | (use-modules (guix build compile) | |
291 | (guix build utils) | |
292 | (srfi srfi-26)) | |
293 | ||
294 | (define go | |
295 | (string-append #$output "/lib/guile/" (effective-version) | |
296 | "/site-ccache")) | |
297 | (define scm | |
298 | (string-append #$output "/share/guile/site/" | |
299 | (effective-version))) | |
acefa740 | 300 | |
ce5d9ec8 | 301 | (let* ((subdir #$directory) |
53f21642 JN |
302 | (source (string-append #$source subdir))) |
303 | (compile-files source go (find-files source "\\.scm$")) | |
304 | (mkdir-p (dirname scm)) | |
305 | (symlink (string-append #$source subdir) scm)) | |
acefa740 | 306 | |
53f21642 | 307 | scm))) |
acefa740 | 308 | |
53f21642 | 309 | (gexp->derivation-in-inferior name build core))) |
0d39a3b9 | 310 | |
37c0d458 LC |
311 | (define (syscalls-reexports-local-variables? source) |
312 | "Return true if (guix build syscalls) contains the bug described at | |
313 | <https://bugs.gnu.org/36723>." | |
314 | (catch 'system-error | |
315 | (lambda () | |
316 | (define content | |
317 | (call-with-input-file (string-append source | |
318 | "/guix/build/syscalls.scm") | |
319 | read-string)) | |
320 | ||
321 | ;; The faulty code would use the 're-export' macro, causing the | |
322 | ;; 'AT_SYMLINK_NOFOLLOW' local variable to be re-exported when using | |
323 | ;; Guile > 2.2.4. | |
324 | (string-contains content "(re-export variable)")) | |
325 | (lambda args | |
326 | (if (= ENOENT (system-error-errno args)) | |
327 | #f | |
328 | (apply throw args))))) | |
329 | ||
330 | (define (guile-2.2.4) | |
331 | (module-ref (resolve-interface '(gnu packages guile)) | |
332 | 'guile-2.2.4)) | |
333 | ||
334 | (define %quirks | |
335 | ;; List of predicate/package pairs. This allows us provide information | |
336 | ;; about specific Guile versions that old Guix revisions might need to use | |
337 | ;; just to be able to build and run the trampoline in %SELF-BUILD-FILE. See | |
338 | ;; <https://bugs.gnu.org/37506> | |
339 | `((,syscalls-reexports-local-variables? . ,guile-2.2.4))) | |
340 | ||
341 | (define* (guile-for-source source #:optional (quirks %quirks)) | |
342 | "Return the Guile package to use when building SOURCE or #f if the default | |
343 | '%guile-for-build' should be good enough." | |
344 | (let loop ((quirks quirks)) | |
345 | (match quirks | |
346 | (() | |
347 | #f) | |
348 | (((predicate . guile) rest ...) | |
349 | (if (predicate source) (guile) (loop rest)))))) | |
350 | ||
0d39a3b9 | 351 | (define* (build-from-source name source |
acefa740 | 352 | #:key core verbose? commit |
0d39a3b9 LC |
353 | (dependencies '())) |
354 | "Return a derivation to build Guix from SOURCE, using the self-build script | |
acefa740 LC |
355 | contained therein; use COMMIT as the version string. When CORE is true, build |
356 | package modules under SOURCE using CORE, an instance of Guix." | |
0d39a3b9 LC |
357 | ;; Running the self-build script makes it easier to update the build |
358 | ;; procedure: the self-build script of the Guix-to-be-installed contains the | |
359 | ;; right dependencies, build procedure, etc., which the Guix-in-use may not | |
360 | ;; be know. | |
361 | (define script | |
362 | (string-append source "/" %self-build-file)) | |
363 | ||
364 | (if (file-exists? script) | |
365 | (let ((build (save-module-excursion | |
366 | (lambda () | |
3a8c4860 LC |
367 | ;; Disable deprecation warnings; it's OK for SCRIPT to |
368 | ;; use deprecated APIs and the user doesn't have to know | |
369 | ;; about it. | |
69962ab7 | 370 | (parameterize ((guix-warning-port |
3a8c4860 | 371 | (%make-void-port "w"))) |
37c0d458 LC |
372 | (primitive-load script))))) |
373 | (guile (guile-for-source source))) | |
0d39a3b9 LC |
374 | ;; BUILD must be a monadic procedure of at least one argument: the |
375 | ;; source tree. | |
376 | ;; | |
377 | ;; Note: BUILD can return #f if it does not support %PULL-VERSION. In | |
378 | ;; the future we'll fall back to a previous version of the protocol | |
379 | ;; when that happens. | |
37c0d458 LC |
380 | (mbegin %store-monad |
381 | (mwhen guile | |
382 | (set-guile-for-build guile)) | |
383 | (build source #:verbose? verbose? #:version commit | |
384 | #:pull-version %pull-version))) | |
0d39a3b9 LC |
385 | |
386 | ;; Build a set of modules that extend Guix using the standard method. | |
acefa740 | 387 | (standard-module-derivation name source core dependencies))) |
0d39a3b9 | 388 | |
acefa740 LC |
389 | (define* (build-channel-instance instance |
390 | #:optional core (dependencies '())) | |
0d39a3b9 LC |
391 | "Return, as a monadic value, the derivation for INSTANCE, a channel |
392 | instance. DEPENDENCIES is a list of extensions providing Guile modules that | |
393 | INSTANCE depends on." | |
394 | (build-from-source (symbol->string | |
395 | (channel-name (channel-instance-channel instance))) | |
396 | (channel-instance-checkout instance) | |
397 | #:commit (channel-instance-commit instance) | |
acefa740 | 398 | #:core core |
0d39a3b9 LC |
399 | #:dependencies dependencies)) |
400 | ||
ed75bdf3 LC |
401 | (define (resolve-dependencies instances) |
402 | "Return a procedure that, given one of the elements of INSTANCES, returns | |
403 | list of instances it depends on." | |
404 | (define channel-instance-name | |
405 | (compose channel-name channel-instance-channel)) | |
406 | ||
407 | (define table ;map a name to an instance | |
408 | (fold (lambda (instance table) | |
409 | (vhash-consq (channel-instance-name instance) | |
410 | instance table)) | |
411 | vlist-null | |
412 | instances)) | |
413 | ||
414 | (define edges | |
415 | (fold (lambda (instance edges) | |
416 | (fold (lambda (channel edges) | |
417 | (let ((name (channel-name channel))) | |
418 | (match (vhash-assq name table) | |
419 | ((_ . target) | |
420 | (vhash-consq instance target edges))))) | |
421 | edges | |
422 | (channel-instance-dependencies instance))) | |
423 | vlist-null | |
424 | instances)) | |
425 | ||
426 | (lambda (instance) | |
427 | (vhash-foldq* cons '() instance edges))) | |
428 | ||
0d39a3b9 LC |
429 | (define (channel-instance-derivations instances) |
430 | "Return the list of derivations to build INSTANCES, in the same order as | |
431 | INSTANCES." | |
432 | (define core-instance | |
433 | ;; The 'guix' channel is treated specially: it's an implicit dependency of | |
434 | ;; all the other channels. | |
435 | (find (lambda (instance) | |
436 | (guix-channel? (channel-instance-channel instance))) | |
437 | instances)) | |
438 | ||
ed75bdf3 LC |
439 | (define edges |
440 | (resolve-dependencies instances)) | |
441 | ||
442 | (define (instance->derivation instance) | |
cdf68947 LC |
443 | (mlet %store-monad ((system (current-system))) |
444 | (mcached (if (eq? instance core-instance) | |
445 | (build-channel-instance instance) | |
446 | (mlet %store-monad ((core (instance->derivation core-instance)) | |
447 | (deps (mapm %store-monad instance->derivation | |
448 | (edges instance)))) | |
449 | (build-channel-instance instance core deps))) | |
450 | instance | |
451 | system))) | |
ed75bdf3 | 452 | |
ab6025b5 LC |
453 | (unless core-instance |
454 | (let ((loc (and=> (any (compose channel-location channel-instance-channel) | |
455 | instances) | |
456 | source-properties->location))) | |
457 | (raise (apply make-compound-condition | |
458 | (condition | |
459 | (&message (message "'guix' channel is lacking"))) | |
460 | (if loc | |
461 | (list (condition (&error-location (location loc)))) | |
462 | '()))))) | |
463 | ||
ed75bdf3 | 464 | (mapm %store-monad instance->derivation instances)) |
0d39a3b9 | 465 | |
0d39a3b9 LC |
466 | (define (whole-package-for-legacy name modules) |
467 | "Return a full-blown Guix package for MODULES, a derivation that builds Guix | |
468 | modules in the old ~/.config/guix/latest style." | |
469 | (define packages | |
470 | (resolve-interface '(gnu packages guile))) | |
471 | ||
49c35bbb LC |
472 | (define modules+compiled |
473 | ;; Since MODULES contains both .scm and .go files at its root, re-bundle | |
474 | ;; it so that it has share/guile/site and lib/guile, which is what | |
475 | ;; 'whole-package' expects. | |
476 | (computed-file (derivation-name modules) | |
477 | (with-imported-modules '((guix build utils)) | |
478 | #~(begin | |
479 | (use-modules (guix build utils)) | |
480 | ||
481 | (define version | |
482 | (effective-version)) | |
483 | (define share | |
484 | (string-append #$output "/share/guile/site")) | |
485 | (define lib | |
486 | (string-append #$output "/lib/guile/" version)) | |
487 | ||
488 | (mkdir-p share) (mkdir-p lib) | |
489 | (symlink #$modules (string-append share "/" version)) | |
490 | (symlink #$modules (string-append lib "/site-ccache")))))) | |
491 | ||
0d39a3b9 LC |
492 | (letrec-syntax ((list (syntax-rules (->) |
493 | ((_) | |
494 | '()) | |
495 | ((_ (module -> variable) rest ...) | |
496 | (cons (module-ref (resolve-interface | |
497 | '(gnu packages module)) | |
498 | 'variable) | |
499 | (list rest ...))) | |
500 | ((_ variable rest ...) | |
501 | (cons (module-ref packages 'variable) | |
502 | (list rest ...)))))) | |
49c35bbb | 503 | (whole-package name modules+compiled |
0d39a3b9 LC |
504 | |
505 | ;; In the "old style", %SELF-BUILD-FILE would simply return a | |
506 | ;; derivation that builds modules. We have to infer what the | |
507 | ;; dependencies of these modules were. | |
b74ed909 | 508 | (list guile-json-3 guile-git guile-bytestructures |
0d39a3b9 LC |
509 | (ssh -> guile-ssh) (tls -> gnutls))))) |
510 | ||
511 | (define (old-style-guix? drv) | |
512 | "Return true if DRV corresponds to a ~/.config/guix/latest style of | |
513 | derivation." | |
514 | ;; Here we rely on a gross historical fact: that derivations produced by the | |
515 | ;; "old style" (before commit 8a0d9bc8a3f153159d9e239a151c0fa98f1e12d8, | |
516 | ;; dated May 30, 2018) did not depend on "guix-command.drv". | |
517 | (not (find (lambda (input) | |
9af75a26 LC |
518 | (string=? "guix-command" |
519 | (derivation-name | |
520 | (derivation-input-derivation input)))) | |
0d39a3b9 LC |
521 | (derivation-inputs drv)))) |
522 | ||
523 | (define (channel-instances->manifest instances) | |
524 | "Return a profile manifest with entries for all of INSTANCES, a list of | |
525 | channel instances." | |
d9e6217f LC |
526 | (define (instance->entry instance drv) |
527 | (let ((commit (channel-instance-commit instance)) | |
528 | (channel (channel-instance-channel instance))) | |
529 | (manifest-entry | |
530 | (name (symbol->string (channel-name channel))) | |
531 | (version (string-take commit 7)) | |
532 | (item (if (guix-channel? channel) | |
533 | (if (old-style-guix? drv) | |
534 | (whole-package-for-legacy (string-append name "-" version) | |
535 | drv) | |
536 | drv) | |
537 | drv)) | |
538 | (properties | |
539 | `((source (repository | |
540 | (version 0) | |
541 | (url ,(channel-url channel)) | |
542 | (branch ,(channel-branch channel)) | |
543 | (commit ,commit)))))))) | |
0d39a3b9 LC |
544 | |
545 | (mlet* %store-monad ((derivations (channel-instance-derivations instances)) | |
d9e6217f | 546 | (entries -> (map instance->entry instances derivations))) |
0d39a3b9 | 547 | (return (manifest entries)))) |
030f1367 | 548 | |
5fbdc9a5 LC |
549 | (define (package-cache-file manifest) |
550 | "Build a package cache file for the instance in MANIFEST. This is meant to | |
551 | be used as a profile hook." | |
552 | (mlet %store-monad ((profile (profile-derivation manifest | |
553 | #:hooks '()))) | |
554 | ||
555 | (define build | |
556 | #~(begin | |
557 | (use-modules (gnu packages)) | |
558 | ||
559 | (if (defined? 'generate-package-cache) | |
560 | (begin | |
561 | ;; Delegate package cache generation to the inferior. | |
562 | (format (current-error-port) | |
563 | "Generating package cache for '~a'...~%" | |
564 | #$profile) | |
565 | (generate-package-cache #$output)) | |
566 | (mkdir #$output)))) | |
567 | ||
568 | (gexp->derivation-in-inferior "guix-package-cache" build | |
569 | profile | |
4035fcba LC |
570 | |
571 | ;; If the Guix in PROFILE is too old and | |
572 | ;; lacks 'guix repl', don't build the cache | |
573 | ;; instead of failing. | |
574 | #:silent-failure? #t | |
575 | ||
5fbdc9a5 | 576 | #:properties '((type . profile-hook) |
f674bc66 LC |
577 | (hook . package-cache)) |
578 | #:local-build? #t))) | |
5fbdc9a5 LC |
579 | |
580 | (define %channel-profile-hooks | |
581 | ;; The default channel profile hooks. | |
582 | (cons package-cache-file %default-profile-hooks)) | |
583 | ||
c37f38bd LC |
584 | (define (channel-instances->derivation instances) |
585 | "Return the derivation of the profile containing INSTANCES, a list of | |
586 | channel instances." | |
587 | (mlet %store-monad ((manifest (channel-instances->manifest instances))) | |
5fbdc9a5 LC |
588 | (profile-derivation manifest |
589 | #:hooks %channel-profile-hooks))) | |
c37f38bd | 590 | |
030f1367 LC |
591 | (define latest-channel-instances* |
592 | (store-lift latest-channel-instances)) | |
593 | ||
594 | (define* (latest-channel-derivation #:optional (channels %default-channels)) | |
595 | "Return as a monadic value the derivation that builds the profile for the | |
596 | latest instances of CHANNELS." | |
c37f38bd LC |
597 | (mlet %store-monad ((instances (latest-channel-instances* channels))) |
598 | (channel-instances->derivation instances))) | |
a7c714d3 LC |
599 | |
600 | (define (profile-channels profile) | |
601 | "Return the list of channels corresponding to entries in PROFILE. If | |
602 | PROFILE is not a profile created by 'guix pull', return the empty list." | |
603 | (filter-map (lambda (entry) | |
604 | (match (assq 'source (manifest-entry-properties entry)) | |
605 | (('source ('repository ('version 0) | |
606 | ('url url) | |
607 | ('branch branch) | |
608 | ('commit commit) | |
609 | _ ...)) | |
610 | (channel (name (string->symbol | |
611 | (manifest-entry-name entry))) | |
612 | (url url) | |
613 | (commit commit))) | |
614 | ||
615 | ;; No channel information for this manifest entry. | |
616 | ;; XXX: Pre-0.15.0 Guix did not provide that information, | |
617 | ;; but there's not much we can do in that case. | |
618 | (_ #f))) | |
619 | ||
620 | ;; Show most recently installed packages last. | |
621 | (reverse | |
622 | (manifest-entries (profile-manifest profile))))) | |
8ba7fd3c LC |
623 | |
624 | \f | |
625 | ;;; | |
626 | ;;; News. | |
627 | ;;; | |
628 | ||
629 | ;; Channel news. | |
630 | (define-record-type <channel-news> | |
631 | (channel-news entries) | |
632 | channel-news? | |
633 | (entries channel-news-entries)) ;list of <channel-news-entry> | |
634 | ||
635 | ;; News entry, associated with a specific commit of the channel. | |
636 | (define-record-type <channel-news-entry> | |
9719e8d3 | 637 | (channel-news-entry commit tag title body) |
8ba7fd3c | 638 | channel-news-entry? |
9719e8d3 LC |
639 | (commit channel-news-entry-commit) ;hex string | #f |
640 | (tag channel-news-entry-tag) ;#f | string | |
8ba7fd3c LC |
641 | (title channel-news-entry-title) ;list of language tag/string pairs |
642 | (body channel-news-entry-body)) ;list of language tag/string pairs | |
643 | ||
644 | (define (sexp->channel-news-entry entry) | |
645 | "Return the <channel-news-entry> record corresponding to ENTRY, an sexp." | |
646 | (define (pair language message) | |
647 | (cons (symbol->string language) message)) | |
648 | ||
649 | (match entry | |
9719e8d3 | 650 | (('entry ((and (or 'commit 'tag) type) commit-or-tag) |
8ba7fd3c LC |
651 | ('title ((? symbol? title-tags) (? string? titles)) ...) |
652 | ('body ((? symbol? body-tags) (? string? bodies)) ...) | |
653 | _ ...) | |
9719e8d3 LC |
654 | (channel-news-entry (and (eq? type 'commit) commit-or-tag) |
655 | (and (eq? type 'tag) commit-or-tag) | |
8ba7fd3c LC |
656 | (map pair title-tags titles) |
657 | (map pair body-tags bodies))) | |
658 | (_ | |
659 | (raise (condition | |
660 | (&message (message "invalid channel news entry")) | |
661 | (&error-location | |
662 | (location (source-properties->location | |
663 | (source-properties entry))))))))) | |
664 | ||
665 | (define (read-channel-news port) | |
666 | "Read a channel news feed from PORT and return it as a <channel-news> | |
667 | record." | |
668 | (match (false-if-exception (read port)) | |
669 | (('channel-news ('version 0) entries ...) | |
670 | (channel-news (map sexp->channel-news-entry entries))) | |
671 | (('channel-news ('version version) _ ...) | |
672 | ;; This is an unsupported version from the future. There's nothing wrong | |
673 | ;; with that (the user may simply need to upgrade the 'guix' channel to | |
674 | ;; be able to read it), so silently ignore it. | |
675 | (channel-news '())) | |
676 | (#f | |
677 | (raise (condition | |
678 | (&message (message "syntactically invalid channel news file"))))) | |
679 | (sexp | |
680 | (raise (condition | |
681 | (&message (message "invalid channel news file")) | |
682 | (&error-location | |
683 | (location (source-properties->location | |
684 | (source-properties sexp))))))))) | |
685 | ||
9719e8d3 LC |
686 | (define (resolve-channel-news-entry-tag repository entry) |
687 | "If ENTRY has its 'commit' field set, return ENTRY. Otherwise, lookup | |
688 | ENTRY's 'tag' in REPOSITORY and return ENTRY with its 'commit' field set to | |
689 | the field its 'tag' refers to. A 'git-error' exception is raised if the tag | |
690 | cannot be found." | |
691 | (if (channel-news-entry-commit entry) | |
692 | entry | |
693 | (let* ((tag (channel-news-entry-tag entry)) | |
694 | (reference (string-append "refs/tags/" tag)) | |
695 | (oid (reference-name->oid repository reference))) | |
696 | (channel-news-entry (oid->string oid) tag | |
697 | (channel-news-entry-title entry) | |
698 | (channel-news-entry-body entry))))) | |
699 | ||
8ba7fd3c LC |
700 | (define* (channel-news-for-commit channel new #:optional old) |
701 | "Return a list of <channel-news-entry> for CHANNEL between commits OLD and | |
702 | NEW. When OLD is omitted or is #f, return all the news entries of CHANNEL." | |
703 | (catch 'git-error | |
704 | (lambda () | |
705 | (let* ((checkout (update-cached-checkout (channel-url channel) | |
706 | #:ref `(commit . ,new))) | |
707 | (metadata (read-channel-metadata-from-source checkout)) | |
708 | (news-file (channel-metadata-news-file metadata)) | |
709 | (news-file (and news-file | |
710 | (string-append checkout "/" news-file)))) | |
711 | (if (and news-file (file-exists? news-file)) | |
9719e8d3 LC |
712 | (with-repository checkout repository |
713 | (let* ((news (call-with-input-file news-file | |
714 | read-channel-news)) | |
715 | (entries (map (lambda (entry) | |
716 | (resolve-channel-news-entry-tag repository | |
717 | entry)) | |
718 | (channel-news-entries news)))) | |
719 | (if old | |
8ba7fd3c LC |
720 | (let* ((new (commit-lookup repository (string->oid new))) |
721 | (old (commit-lookup repository (string->oid old))) | |
722 | (commits (list->set | |
723 | (map (compose oid->string commit-id) | |
724 | (commit-difference new old))))) | |
725 | (filter (lambda (entry) | |
726 | (set-contains? commits | |
727 | (channel-news-entry-commit entry))) | |
9719e8d3 LC |
728 | entries)) |
729 | entries))) | |
8ba7fd3c LC |
730 | '()))) |
731 | (lambda (key error . rest) | |
732 | ;; If commit NEW or commit OLD cannot be found, then something must be | |
733 | ;; wrong (for example, the history of CHANNEL was rewritten and these | |
734 | ;; commits no longer exist upstream), so quietly return the empty list. | |
735 | (if (= GIT_ENOTFOUND (git-error-code error)) | |
736 | '() | |
737 | (apply throw key error rest))))) |