1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
4 ;;; Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
6 ;;; This file is part of GNU Guix.
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.
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.
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/>.
21 (define-module (guix channels)
23 #:use-module (guix git)
24 #:use-module (guix git-authenticate)
25 #:use-module ((guix openpgp)
26 #:select (openpgp-public-key-fingerprint
27 openpgp-format-fingerprint))
28 #:use-module (guix base16)
29 #:use-module (guix records)
30 #:use-module (guix gexp)
31 #:use-module (guix modules)
32 #:use-module (guix discovery)
33 #:use-module (guix monads)
34 #:use-module (guix profiles)
35 #:use-module (guix packages)
36 #:use-module (guix progress)
37 #:use-module (guix derivations)
38 #:use-module (guix combinators)
39 #:use-module (guix diagnostics)
40 #:use-module (guix sets)
41 #:use-module (guix store)
42 #:use-module (guix i18n)
43 #:use-module ((guix utils)
44 #:select (source-properties->location
47 #:use-module (srfi srfi-1)
48 #:use-module (srfi srfi-2)
49 #:use-module (srfi srfi-9)
50 #:use-module (srfi srfi-11)
51 #:use-module (srfi srfi-26)
52 #:use-module (srfi srfi-34)
53 #:use-module (srfi srfi-35)
54 #:autoload (guix self) (whole-package make-config.scm)
55 #:autoload (guix inferior) (gexp->derivation-in-inferior) ;FIXME: circular dep
56 #:autoload (guix quirks) (%quirks %patches applicable-patch? apply-patch)
57 #:use-module (ice-9 format)
58 #:use-module (ice-9 match)
59 #:use-module (ice-9 vlist)
60 #:use-module ((ice-9 rdelim) #:select (read-string))
61 #:use-module ((rnrs bytevectors) #:select (bytevector=?))
72 ;; <channel-introduction> accessors purposefully omitted for now.
78 channel-instance-channel
79 channel-instance-commit
80 channel-instance-checkout
83 latest-channel-instances
84 checkout->channel-instance
85 latest-channel-derivation
86 channel-instances->manifest
87 %channel-profile-hooks
88 channel-instances->derivation
89 ensure-forward-channel-update
94 channel-news-entry-commit
95 channel-news-entry-tag
96 channel-news-entry-title
97 channel-news-entry-body
99 channel-news-for-commit))
103 ;;; This module implements "channels." A channel is usually a source of
104 ;;; package definitions. There's a special channel, the 'guix' channel, that
105 ;;; provides all of Guix, including its commands and its documentation.
106 ;;; User-defined channels are expected to typically provide a bunch of .scm
107 ;;; files meant to be added to the '%package-search-path'.
109 ;;; This module provides tools to fetch and update channels from a Git
110 ;;; repository and to build them.
114 (define-record-type* <channel> channel make-channel
118 (branch channel-branch (default "master"))
119 (commit channel-commit (default #f))
120 (introduction channel-introduction (default #f))
121 (location channel-location
122 (default (current-source-location)) (innate)))
124 ;; Channel introductions. A "channel introduction" provides a commit/signer
125 ;; pair that specifies the first commit of the authentication process as well
126 ;; as its signer's fingerprint. The pair must be signed by the signer of that
127 ;; commit so that only them may emit this introduction. Introductions are
128 ;; used to bootstrap trust in a channel.
129 (define-record-type <channel-introduction>
130 (make-channel-introduction first-signed-commit first-commit-signer
132 channel-introduction?
133 (first-signed-commit channel-introduction-first-signed-commit) ;hex string
134 (first-commit-signer channel-introduction-first-commit-signer) ;bytevector
135 (signature channel-introduction-signature)) ;string
137 (define %guix-channel-introduction
138 ;; Introduction of the official 'guix channel. The chosen commit is the
139 ;; first one that introduces '.guix-authorizations' on the 'staging'
140 ;; branch that was eventually merged in 'master'. Any branch starting
141 ;; before that commit cannot be merged or it will be rejected by 'guix pull'
143 (make-channel-introduction
144 "9edb3f66fd807b096b48283debdcddccfea34bad" ;2020-05-26
145 (base16-string->bytevector
147 (string-filter char-set:hex-digit ;mbakke
148 "BBB0 2DDF 2CEA F6A8 0D1D E643 A2A0 6DF2 A33A 54FA")))
149 #f)) ;TODO: Add an intro signature so it can be exported.
151 (define %default-channel-url
152 ;; URL of the default 'guix' channel.
153 "https://git.savannah.gnu.org/git/guix.git")
155 (define %default-channels
156 ;; Default list of channels.
160 (url %default-channel-url)
161 (introduction %guix-channel-introduction))))
163 (define (guix-channel? channel)
164 "Return true if CHANNEL is the 'guix' channel."
165 (eq? 'guix (channel-name channel)))
167 (define (ensure-default-introduction chan)
168 "If CHAN represents the \"official\" 'guix' channel and lacks an
169 introduction, add it."
170 (if (and (guix-channel? chan)
171 (not (channel-introduction chan))
172 (string=? (channel-url chan) %default-channel-url))
173 (channel (inherit chan)
174 (introduction %guix-channel-introduction))
177 (define-record-type <channel-instance>
178 (channel-instance channel commit checkout)
180 (channel channel-instance-channel)
181 (commit channel-instance-commit)
182 (checkout channel-instance-checkout))
184 (define-record-type <channel-metadata>
185 (channel-metadata directory dependencies news-file keyring-reference url)
187 (directory channel-metadata-directory) ;string with leading slash
188 (dependencies channel-metadata-dependencies) ;list of <channel>
189 (news-file channel-metadata-news-file) ;string | #f
190 (keyring-reference channel-metadata-keyring-reference) ;string
191 (url channel-metadata-url)) ;string | #f
193 (define %default-keyring-reference
194 ;; Default value of the 'keyring-reference' field.
197 (define (channel-reference channel)
198 "Return the \"reference\" for CHANNEL, an sexp suitable for
199 'latest-repository-commit'."
200 (match (channel-commit channel)
201 (#f `(branch . ,(channel-branch channel)))
202 (commit `(commit . ,(channel-commit channel)))))
204 (define (read-channel-metadata port)
205 "Read from PORT channel metadata in the format expected for the
206 '.guix-channel' file. Return a <channel-metadata> record, or raise an error
207 if valid metadata could not be read from PORT."
209 (('channel ('version 0) properties ...)
210 (let ((directory (and=> (assoc-ref properties 'directory) first))
211 (dependencies (or (assoc-ref properties 'dependencies) '()))
212 (news-file (and=> (assoc-ref properties 'news-file) first))
213 (url (and=> (assoc-ref properties 'url) first))
215 (or (and=> (assoc-ref properties 'keyring-reference) first)
216 %default-keyring-reference)))
218 (cond ((not directory) "/") ;directory
219 ((string-prefix? "/" directory) directory)
220 (else (string-append "/" directory)))
221 (map (lambda (item) ;dependencies
222 (let ((get (lambda* (key #:optional default)
223 (or (and=> (assoc-ref item key) first) default))))
224 (and-let* ((name (get 'name))
226 (branch (get 'branch "master")))
231 (commit (get 'commit))))))
236 ((and ('channel ('version version) _ ...) sexp)
238 (&message (message "unsupported '.guix-channel' version"))
240 (location (source-properties->location
241 (source-properties sexp)))))))
244 (&message (message "invalid '.guix-channel' file"))
246 (location (source-properties->location
247 (source-properties sexp)))))))))
249 (define (read-channel-metadata-from-source source)
250 "Return a channel-metadata record read from channel's SOURCE/.guix-channel
251 description file, or return the default channel-metadata record if that file
255 (call-with-input-file (string-append source "/.guix-channel")
256 read-channel-metadata))
258 (if (= ENOENT (system-error-errno args))
259 (channel-metadata "/" '() #f %default-keyring-reference #f)
260 (apply throw args)))))
262 (define (channel-instance-metadata instance)
263 "Return a channel-metadata record read from the channel INSTANCE's
264 description file or its default value."
265 (read-channel-metadata-from-source (channel-instance-checkout instance)))
267 (define (channel-instance-dependencies instance)
268 "Return the list of channels that are declared as dependencies for the given
270 (channel-metadata-dependencies (channel-instance-metadata instance)))
272 (define (apply-patches checkout commit patches)
273 "Apply the matching PATCHES to CHECKOUT, modifying files in place. The
274 result is unspecified."
275 (let loop ((patches patches))
279 (when (applicable-patch? patch checkout commit)
280 (apply-patch patch checkout))
283 (define commit-short-id
284 (compose (cut string-take <> 7) oid->string commit-id))
286 (define (verify-introductory-commit repository introduction keyring)
287 "Raise an exception if the first commit described in INTRODUCTION doesn't
288 have the expected signer."
290 (channel-introduction-first-signed-commit introduction))
292 (define actual-signer
293 (openpgp-public-key-fingerprint
294 (commit-signing-key repository (string->oid commit-id)
297 (define expected-signer
298 (channel-introduction-first-commit-signer introduction))
300 (unless (bytevector=? expected-signer actual-signer)
303 (message (format #f (G_ "initial commit ~a is signed by '~a' \
306 (openpgp-format-fingerprint actual-signer)
307 (openpgp-format-fingerprint expected-signer))))))))
309 (define* (authenticate-channel channel checkout commit
310 #:key (keyring-reference-prefix "origin/"))
311 "Authenticate the given COMMIT of CHANNEL, available at CHECKOUT, a
312 directory containing a CHANNEL checkout. Raise an error if authentication
314 ;; XXX: Too bad we need to re-open CHECKOUT.
315 (with-repository checkout repository
317 (commit-lookup repository
319 (channel-introduction-first-signed-commit
320 (channel-introduction channel)))))
323 (commit-lookup repository (string->oid commit)))
326 (string-append "channels/" (symbol->string (channel-name channel))))
328 (define keyring-reference
329 (channel-metadata-keyring-reference
330 (read-channel-metadata-from-source checkout)))
333 (load-keyring-from-reference repository
334 (string-append keyring-reference-prefix
337 (define authenticated-commits
338 ;; Previously-authenticated commits that don't need to be checked again.
339 (filter-map (lambda (id)
341 (commit-lookup repository (string->oid id))))
342 (previously-authenticated-commits cache-key)))
345 ;; Commits to authenticate, excluding the closure of
346 ;; AUTHENTICATED-COMMITS.
347 (commit-difference end-commit start-commit
348 authenticated-commits))
351 (progress-reporter/bar (length commits)))
353 ;; When COMMITS is empty, it's either because AUTHENTICATED-COMMITS
354 ;; contains END-COMMIT or because END-COMMIT is not a descendant of
355 ;; START-COMMIT. Check that.
357 (match (commit-relation start-commit end-commit)
358 ((or 'self 'ancestor 'descendant) #t) ;nothing to do!
364 (format #f (G_ "'~a' is not related to introductory \
365 commit of channel '~a'~%")
366 (oid->string (commit-id end-commit))
367 (channel-name channel))))))))
369 (format (current-error-port)
370 (G_ "Authenticating channel '~a', \
371 commits ~a to ~a (~h new commits)...~%")
372 (channel-name channel)
373 (commit-short-id start-commit)
374 (commit-short-id end-commit)
377 ;; If it's our first time, verify CHANNEL's introductory commit.
378 (when (null? authenticated-commits)
379 (verify-introductory-commit repository
380 (channel-introduction channel)
383 (call-with-progress-reporter reporter
385 (authenticate-commits repository commits
387 #:report-progress report)))
389 (cache-authenticated-commit cache-key
391 (commit-id end-commit)))))))
393 (define* (latest-channel-instance store channel
394 #:key (patches %patches)
398 ensure-forward-channel-update))
399 "Return the latest channel instance for CHANNEL. When STARTING-COMMIT is
400 true, call VALIDATE-PULL with CHANNEL, STARTING-COMMIT, the target commit, and
401 their relation. When AUTHENTICATE? is false, CHANNEL is not authenticated."
402 (define (dot-git? file stat)
403 (and (string=? (basename file) ".git")
404 (eq? 'directory (stat:type stat))))
406 (let-values (((channel)
407 (ensure-default-introduction channel))
408 ((checkout commit relation)
409 (update-cached-checkout (channel-url channel)
410 #:ref (channel-reference channel)
411 #:starting-commit starting-commit)))
413 (validate-pull channel starting-commit commit relation))
416 (if (channel-introduction channel)
417 (authenticate-channel channel checkout commit)
418 ;; TODO: Warn for all the channels once the authentication interface
420 (when (guix-channel? channel)
421 (warning (G_ "channel '~a' lacks an introduction and \
422 cannot be authenticated~%")
423 (channel-name channel))))
424 (warning (G_ "channel authentication disabled~%")))
426 (when (guix-channel? channel)
427 ;; Apply the relevant subset of PATCHES directly in CHECKOUT. This is
428 ;; safe to do because 'switch-to-ref' eventually does a hard reset.
429 (apply-patches checkout commit patches))
431 (let* ((name (url+commit->name (channel-url channel) commit))
432 (checkout (add-to-store store name #t "sha256" checkout
433 #:select? (negate dot-git?))))
434 (channel-instance channel commit checkout))))
436 (define (ensure-forward-channel-update channel start commit relation)
437 "Raise an error if RELATION is not 'ancestor, meaning that START is not an
438 ancestor of COMMIT, unless CHANNEL specifies a commit.
440 This procedure implements a channel update policy meant to be used as a
441 #:validate-pull argument."
446 (raise (make-compound-condition
450 aborting update of channel '~a' to commit ~a, which is not a descendant of ~a")
451 (channel-name channel)
454 ;; If the user asked for a specific commit, they might want
455 ;; that to happen nevertheless, so tell them about the
456 ;; relevant 'guix pull' option.
457 (if (channel-commit channel)
460 (hint (G_ "Use @option{--allow-downgrades} to force
464 (hint (G_ "This could indicate that the channel has
465 been tampered with and is trying to force a roll-back, preventing you from
466 getting the latest updates. If you think this is not the case, explicitly
467 allow non-forward updates."))))))))))
469 (define (channel-instance-primary-url instance)
470 "Return the primary URL advertised for INSTANCE, or #f if there is no such
472 (channel-metadata-url (channel-instance-metadata instance)))
474 (define* (latest-channel-instances store channels
476 (current-channels '())
479 ensure-forward-channel-update))
480 "Return a list of channel instances corresponding to the latest checkouts of
481 CHANNELS and the channels on which they depend.
483 When AUTHENTICATE? is true, authenticate the subset of CHANNELS that has a
484 \"channel introduction\".
486 CURRENT-CHANNELS is the list of currently used channels. It is compared
487 against the newly-fetched instances of CHANNELS, and VALIDATE-PULL is called
488 for each channel update and can choose to emit warnings or raise an error,
489 depending on the policy it implements."
490 ;; Only process channels that are unique, or that are more specific than a
491 ;; previous channel specification.
492 (define (ignore? channel others)
493 (member channel others
495 (and (eq? (channel-name a) (channel-name b))
496 (or (channel-commit b)
497 (not (or (channel-commit a)
498 (channel-commit b))))))))
500 (define (current-commit name)
501 ;; Return the current commit for channel NAME.
502 (any (lambda (channel)
503 (and (eq? (channel-name channel) name)
504 (channel-commit channel)))
507 (let loop ((channels channels)
508 (previous-channels '()))
509 ;; Accumulate a list of instances. A list of processed channels is also
510 ;; accumulated to decide on duplicate channel specifications.
511 (define-values (resulting-channels instances)
512 (fold2 (lambda (channel previous-channels instances)
513 (if (ignore? channel previous-channels)
514 (values previous-channels instances)
516 (format (current-error-port)
517 (G_ "Updating channel '~a' from Git repository at '~a'...~%")
518 (channel-name channel)
519 (channel-url channel))
520 (let* ((current (current-commit (channel-name channel)))
522 (latest-channel-instance store channel
530 ;; CHANNEL is authenticated so we can trust the
531 ;; primary URL advertised in its metadata and warn
532 ;; about possibly stale mirrors.
533 (let ((primary-url (channel-instance-primary-url
535 (unless (or (not primary-url)
536 (channel-commit channel)
537 (string=? primary-url (channel-url channel)))
538 (warning (G_ "pulled channel '~a' from a mirror \
539 of ~a, which might be stale~%")
540 (channel-name channel)
543 (let-values (((new-instances new-channels)
544 (loop (channel-instance-dependencies instance)
546 (values (append (cons channel new-channels)
548 (append (cons instance new-instances)
554 (let ((instance-name (compose channel-name channel-instance-channel)))
555 ;; Remove all earlier channel specifications if they are followed by a
556 ;; more specific one.
557 (values (delete-duplicates instances
559 (eq? (instance-name a) (instance-name b))))
560 resulting-channels))))
562 (define* (checkout->channel-instance checkout
564 (url checkout) (name 'guix))
565 "Return a channel instance for CHECKOUT, which is assumed to be a checkout
566 of COMMIT at URL. Use NAME as the channel name."
567 (let* ((commit (or commit (make-string 40 #\0)))
568 (channel (channel (name name)
571 (channel-instance channel commit checkout)))
573 (define %self-build-file
574 ;; The file containing code to build Guix. This serves the same purpose as
575 ;; a makefile, and, similarly, is intended to always keep this name.
576 "build-aux/build-self.scm")
578 (define %pull-version
579 ;; This is the version of the 'guix pull' protocol. It specifies what's
580 ;; expected from %SELF-BUILD-FILE. The initial version ("0") was when we'd
581 ;; place a set of compiled Guile modules in ~/.config/guix/latest.
584 (define (standard-module-derivation name source core dependencies)
585 "Return a derivation that builds with CORE, a Guix instance, the Scheme
586 modules in SOURCE and that depend on DEPENDENCIES, a list of lowerable
587 objects. The assumption is that SOURCE contains package modules to be added
588 to '%package-module-path'."
590 (let* ((metadata (read-channel-metadata-from-source source))
591 (directory (channel-metadata-directory metadata)))
594 ;; This is code that we'll run in CORE, a Guix instance, with its own
595 ;; modules and so on. That way, we make sure these modules are built for
596 ;; the right Guile version, with the right dependencies, and that they get
597 ;; to see the right (gnu packages …) modules.
598 (with-extensions dependencies
600 (use-modules (guix build compile)
605 (string-append #$output "/lib/guile/" (effective-version)
608 (string-append #$output "/share/guile/site/"
609 (effective-version)))
611 (let* ((subdir #$directory)
612 (source (string-append #$source subdir)))
613 (compile-files source go (find-files source "\\.scm$"))
614 (mkdir-p (dirname scm))
615 (symlink (string-append #$source subdir) scm))
619 (gexp->derivation-in-inferior name build core)))
621 (define* (guile-for-source source #:optional (quirks %quirks))
622 "Return the Guile package to use when building SOURCE or #f if the default
623 '%guile-for-build' should be good enough."
624 (let loop ((quirks quirks))
628 (((predicate . guile) rest ...)
629 (if (predicate source) (guile) (loop rest))))))
631 (define (call-with-guile guile thunk)
633 (values (parameterize ((%guile-for-build
635 (package-derivation store guile)
636 (%guile-for-build))))
637 (run-with-store store (thunk)))
640 (define-syntax-rule (with-guile guile exp ...)
641 "Set GUILE as the '%guile-for-build' parameter for the dynamic extent of
642 EXP, a series of monadic expressions."
643 (call-with-guile guile (lambda ()
644 (mbegin %store-monad exp ...))))
646 (define (with-trivial-build-handler mvalue)
647 "Run MVALUE, a monadic value, with a \"trivial\" build handler installed
648 that unconditionally resumes the continuation."
650 (with-build-handler (lambda (continue . _)
652 (values (run-with-store store mvalue)
655 (define* (build-from-source name source
656 #:key core verbose? commit
658 "Return a derivation to build Guix from SOURCE, using the self-build script
659 contained therein; use COMMIT as the version string. When CORE is true, build
660 package modules under SOURCE using CORE, an instance of Guix."
661 ;; Running the self-build script makes it easier to update the build
662 ;; procedure: the self-build script of the Guix-to-be-installed contains the
663 ;; right dependencies, build procedure, etc., which the Guix-in-use may not
666 (string-append source "/" %self-build-file))
668 (if (file-exists? script)
669 (let ((build (save-module-excursion
671 ;; Disable deprecation warnings; it's OK for SCRIPT to
672 ;; use deprecated APIs and the user doesn't have to know
674 (parameterize ((guix-warning-port
675 (%make-void-port "w")))
676 (primitive-load script)))))
677 (guile (guile-for-source source)))
678 ;; BUILD must be a monadic procedure of at least one argument: the
681 ;; Note: BUILD can return #f if it does not support %PULL-VERSION. In
682 ;; the future we'll fall back to a previous version of the protocol
683 ;; when that happens.
685 ;; BUILD is usually quite costly. Install a "trivial" build handler
686 ;; so we don't bounce an outer build-accumulator handler that could
687 ;; cause us to redo half of the BUILD computation several times just
688 ;; to realize it gives the same result.
689 (with-trivial-build-handler
690 (build source #:verbose? verbose? #:version commit
691 #:pull-version %pull-version))))
693 ;; Build a set of modules that extend Guix using the standard method.
694 (standard-module-derivation name source core dependencies)))
696 (define* (build-channel-instance instance
697 #:optional core (dependencies '()))
698 "Return, as a monadic value, the derivation for INSTANCE, a channel
699 instance. DEPENDENCIES is a list of extensions providing Guile modules that
700 INSTANCE depends on."
701 (build-from-source (symbol->string
702 (channel-name (channel-instance-channel instance)))
703 (channel-instance-checkout instance)
704 #:commit (channel-instance-commit instance)
706 #:dependencies dependencies))
708 (define (resolve-dependencies instances)
709 "Return a procedure that, given one of the elements of INSTANCES, returns
710 list of instances it depends on."
711 (define channel-instance-name
712 (compose channel-name channel-instance-channel))
714 (define table ;map a name to an instance
715 (fold (lambda (instance table)
716 (vhash-consq (channel-instance-name instance)
722 (fold (lambda (instance edges)
723 (fold (lambda (channel edges)
724 (let ((name (channel-name channel)))
725 (match (vhash-assq name table)
727 (vhash-consq instance target edges)))))
729 (channel-instance-dependencies instance)))
734 (vhash-foldq* cons '() instance edges)))
736 (define (channel-instance-derivations instances)
737 "Return the list of derivations to build INSTANCES, in the same order as
739 (define core-instance
740 ;; The 'guix' channel is treated specially: it's an implicit dependency of
741 ;; all the other channels.
742 (find (lambda (instance)
743 (guix-channel? (channel-instance-channel instance)))
747 (resolve-dependencies instances))
749 (define (instance->derivation instance)
750 (mlet %store-monad ((system (current-system)))
751 (mcached (if (eq? instance core-instance)
752 (build-channel-instance instance)
753 (mlet %store-monad ((core (instance->derivation core-instance))
754 (deps (mapm %store-monad instance->derivation
756 (build-channel-instance instance core deps)))
760 (unless core-instance
761 (let ((loc (and=> (any (compose channel-location channel-instance-channel)
763 source-properties->location)))
764 (raise (apply make-compound-condition
766 (&message (message "'guix' channel is lacking")))
768 (&fix-hint (hint (G_ "Make sure your list of channels
769 contains one channel named @code{guix} providing the core of Guix."))))
771 (list (condition (&error-location (location loc))))
774 (mapm %store-monad instance->derivation instances))
776 (define (whole-package-for-legacy name modules)
777 "Return a full-blown Guix package for MODULES, a derivation that builds Guix
778 modules in the old ~/.config/guix/latest style."
780 (resolve-interface '(gnu packages guile)))
782 (define modules+compiled
783 ;; Since MODULES contains both .scm and .go files at its root, re-bundle
784 ;; it so that it has share/guile/site and lib/guile, which is what
785 ;; 'whole-package' expects.
786 (computed-file (derivation-name modules)
787 (with-imported-modules '((guix build utils))
789 (use-modules (guix build utils))
794 (string-append #$output "/share/guile/site"))
796 (string-append #$output "/lib/guile/" version))
798 (mkdir-p share) (mkdir-p lib)
799 (symlink #$modules (string-append share "/" version))
800 (symlink #$modules (string-append lib "/site-ccache"))))))
802 (letrec-syntax ((list (syntax-rules (->)
805 ((_ (module -> variable) rest ...)
806 (cons (module-ref (resolve-interface
807 '(gnu packages module))
810 ((_ variable rest ...)
811 (cons (module-ref packages 'variable)
813 (whole-package name modules+compiled
815 ;; In the "old style", %SELF-BUILD-FILE would simply return a
816 ;; derivation that builds modules. We have to infer what the
817 ;; dependencies of these modules were.
818 (list guile-json-3 guile-git guile-bytestructures
819 (ssh -> guile-ssh) (tls -> gnutls)))))
821 (define (old-style-guix? drv)
822 "Return true if DRV corresponds to a ~/.config/guix/latest style of
824 ;; Here we rely on a gross historical fact: that derivations produced by the
825 ;; "old style" (before commit 8a0d9bc8a3f153159d9e239a151c0fa98f1e12d8,
826 ;; dated May 30, 2018) did not depend on "guix-command.drv".
827 (not (find (lambda (input)
828 (string=? "guix-command"
830 (derivation-input-derivation input))))
831 (derivation-inputs drv))))
833 (define (channel-instances->manifest instances)
834 "Return a profile manifest with entries for all of INSTANCES, a list of
836 (define (instance->entry instance drv)
837 (let ((commit (channel-instance-commit instance))
838 (channel (channel-instance-channel instance)))
840 (name (symbol->string (channel-name channel)))
841 (version (string-take commit 7))
842 (item (if (guix-channel? channel)
843 (if (old-style-guix? drv)
844 (whole-package-for-legacy (string-append name "-" version)
849 `((source (repository
851 (url ,(channel-url channel))
852 (branch ,(channel-branch channel))
853 (commit ,commit))))))))
855 (mlet* %store-monad ((derivations (channel-instance-derivations instances))
856 (entries -> (map instance->entry instances derivations)))
857 (return (manifest entries))))
859 (define (package-cache-file manifest)
860 "Build a package cache file for the instance in MANIFEST. This is meant to
861 be used as a profile hook."
862 (let ((profile (profile (content manifest) (hooks '()))))
865 (use-modules (gnu packages))
867 (if (defined? 'generate-package-cache)
869 ;; Delegate package cache generation to the inferior.
870 (format (current-error-port)
871 "Generating package cache for '~a'...~%"
873 (generate-package-cache #$output))
876 (gexp->derivation-in-inferior "guix-package-cache" build
879 ;; If the Guix in PROFILE is too old and
880 ;; lacks 'guix repl', don't build the cache
881 ;; instead of failing.
884 #:properties '((type . profile-hook)
885 (hook . package-cache))
888 (define %channel-profile-hooks
889 ;; The default channel profile hooks.
890 (cons package-cache-file %default-profile-hooks))
892 (define (channel-instances->derivation instances)
893 "Return the derivation of the profile containing INSTANCES, a list of
895 (mlet %store-monad ((manifest (channel-instances->manifest instances)))
896 (profile-derivation manifest
897 #:hooks %channel-profile-hooks)))
899 (define latest-channel-instances*
900 (store-lift latest-channel-instances))
902 (define* (latest-channel-derivation #:optional (channels %default-channels)
904 (current-channels '())
906 ensure-forward-channel-update))
907 "Return as a monadic value the derivation that builds the profile for the
908 latest instances of CHANNELS. CURRENT-CHANNELS and VALIDATE-PULL are passed
909 to 'latest-channel-instances'."
910 (mlet %store-monad ((instances
911 (latest-channel-instances* channels
916 (channel-instances->derivation instances)))
918 (define (profile-channels profile)
919 "Return the list of channels corresponding to entries in PROFILE. If
920 PROFILE is not a profile created by 'guix pull', return the empty list."
921 (filter-map (lambda (entry)
922 (match (assq 'source (manifest-entry-properties entry))
923 (('source ('repository ('version 0)
928 (channel (name (string->symbol
929 (manifest-entry-name entry)))
933 ;; No channel information for this manifest entry.
934 ;; XXX: Pre-0.15.0 Guix did not provide that information,
935 ;; but there's not much we can do in that case.
938 ;; Show most recently installed packages last.
940 (manifest-entries (profile-manifest profile)))))
948 (define-record-type <channel-news>
949 (channel-news entries)
951 (entries channel-news-entries)) ;list of <channel-news-entry>
953 ;; News entry, associated with a specific commit of the channel.
954 (define-record-type <channel-news-entry>
955 (channel-news-entry commit tag title body)
957 (commit channel-news-entry-commit) ;hex string | #f
958 (tag channel-news-entry-tag) ;#f | string
959 (title channel-news-entry-title) ;list of language tag/string pairs
960 (body channel-news-entry-body)) ;list of language tag/string pairs
962 (define (sexp->channel-news-entry entry)
963 "Return the <channel-news-entry> record corresponding to ENTRY, an sexp."
964 (define (pair language message)
965 (cons (symbol->string language) message))
968 (('entry ((and (or 'commit 'tag) type) commit-or-tag)
969 ('title ((? symbol? title-tags) (? string? titles)) ...)
970 ('body ((? symbol? body-tags) (? string? bodies)) ...)
972 (channel-news-entry (and (eq? type 'commit) commit-or-tag)
973 (and (eq? type 'tag) commit-or-tag)
974 (map pair title-tags titles)
975 (map pair body-tags bodies)))
978 (&message (message "invalid channel news entry"))
980 (location (source-properties->location
981 (source-properties entry)))))))))
983 (define (read-channel-news port)
984 "Read a channel news feed from PORT and return it as a <channel-news>
986 (match (false-if-exception (read port))
987 (('channel-news ('version 0) entries ...)
988 (channel-news (map sexp->channel-news-entry entries)))
989 (('channel-news ('version version) _ ...)
990 ;; This is an unsupported version from the future. There's nothing wrong
991 ;; with that (the user may simply need to upgrade the 'guix' channel to
992 ;; be able to read it), so silently ignore it.
996 (&message (message "syntactically invalid channel news file")))))
999 (&message (message "invalid channel news file"))
1001 (location (source-properties->location
1002 (source-properties sexp)))))))))
1004 (define (resolve-channel-news-entry-tag repository entry)
1005 "If ENTRY has its 'commit' field set, return ENTRY. Otherwise, lookup
1006 ENTRY's 'tag' in REPOSITORY and return ENTRY with its 'commit' field set to
1007 the field its 'tag' refers to. A 'git-error' exception is raised if the tag
1009 (if (channel-news-entry-commit entry)
1011 (let* ((tag (channel-news-entry-tag entry))
1012 (reference (string-append "refs/tags/" tag))
1013 (oid (reference-name->oid repository reference)))
1014 (channel-news-entry (oid->string oid) tag
1015 (channel-news-entry-title entry)
1016 (channel-news-entry-body entry)))))
1018 (define* (channel-news-for-commit channel new #:optional old)
1019 "Return a list of <channel-news-entry> for CHANNEL between commits OLD and
1020 NEW. When OLD is omitted or is #f, return all the news entries of CHANNEL."
1023 (let* ((checkout (update-cached-checkout (channel-url channel)
1024 #:ref `(commit . ,new)))
1025 (metadata (read-channel-metadata-from-source checkout))
1026 (news-file (channel-metadata-news-file metadata))
1027 (news-file (and news-file
1028 (string-append checkout "/" news-file))))
1029 (if (and news-file (file-exists? news-file))
1030 (with-repository checkout repository
1031 (let* ((news (call-with-input-file news-file
1033 (entries (map (lambda (entry)
1034 (resolve-channel-news-entry-tag repository
1036 (channel-news-entries news))))
1038 (let* ((new (commit-lookup repository (string->oid new)))
1039 (old (commit-lookup repository (string->oid old)))
1041 (map (compose oid->string commit-id)
1042 (commit-difference new old)))))
1043 (filter (lambda (entry)
1044 (set-contains? commits
1045 (channel-news-entry-commit entry)))
1049 (lambda (key error . rest)
1050 ;; If commit NEW or commit OLD cannot be found, then something must be
1051 ;; wrong (for example, the history of CHANNEL was rewritten and these
1052 ;; commits no longer exist upstream), so quietly return the empty list.
1053 (if (= GIT_ENOTFOUND (git-error-code error))
1055 (apply throw key error rest)))))
1057 ;;; Local Variables:
1058 ;;; eval: (put 'with-guile 'scheme-indent-function 1)