[jackhill/guix/guix.git] / guix / channels.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix channels)
  #:use-module (guix git)
  #:use-module (guix records)
  #:use-module (guix gexp)
  #:use-module (guix modules)
  #:use-module (guix discovery)
  #:use-module (guix monads)
  #:use-module (guix profiles)
  #:use-module (guix derivations)
  #:use-module (guix combinators)
  #:use-module (guix store)
  #:use-module (guix i18n)
  #:use-module ((guix utils)
                #:select (source-properties->location
                          &error-location))
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-2)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:autoload   (guix self) (whole-package make-config.scm)
  #:autoload   (guix inferior) (gexp->derivation-in-inferior) ;FIXME: circular dep
  #:use-module (ice-9 match)
  #:use-module (ice-9 vlist)
  #:export (channel
            channel?
            channel-name
            channel-url
            channel-branch
            channel-commit
            channel-location

            %default-channels

            channel-instance?
            channel-instance-channel
            channel-instance-commit
            channel-instance-checkout

            latest-channel-instances
            checkout->channel-instance
            latest-channel-derivation
            channel-instances->manifest
            %channel-profile-hooks
            channel-instances->derivation))

;;; Commentary:
;;;
;;; This module implements "channels."  A channel is usually a source of
;;; package definitions.  There's a special channel, the 'guix' channel, that
;;; provides all of Guix, including its commands and its documentation.
;;; User-defined channels are expected to typically provide a bunch of .scm
;;; files meant to be added to the '%package-search-path'.
;;;
;;; This module provides tools to fetch and update channels from a Git
;;; repository and to build them.
;;;
;;; Code:

(define-record-type* <channel> channel make-channel
  channel?
  (name      channel-name)
  (url       channel-url)
  (branch    channel-branch (default "master"))
  (commit    channel-commit (default #f))
  (location  channel-location
             (default (current-source-location)) (innate)))

(define %default-channels
  ;; Default list of channels.
  (list (channel
         (name 'guix)
         (branch "master")
         (url "https://git.savannah.gnu.org/git/guix.git"))))

(define (guix-channel? channel)
  "Return true if CHANNEL is the 'guix' channel."
  (eq? 'guix (channel-name channel)))

(define-record-type <channel-instance>
  (channel-instance channel commit checkout)
  channel-instance?
  (channel   channel-instance-channel)
  (commit    channel-instance-commit)
  (checkout  channel-instance-checkout))

(define-record-type <channel-metadata>
  (channel-metadata version dependencies)
  channel-metadata?
  (version       channel-metadata-version)
  (dependencies  channel-metadata-dependencies))

(define (channel-reference channel)
  "Return the \"reference\" for CHANNEL, an sexp suitable for
'latest-repository-commit'."
  (match (channel-commit channel)
    (#f      `(branch . ,(channel-branch channel)))
    (commit  `(commit . ,(channel-commit channel)))))

(define (read-channel-metadata instance)
  "Return a channel-metadata record read from the channel INSTANCE's
description file, or return #F if the channel instance does not include the
file."
  (let* ((source (channel-instance-checkout instance))
         (meta-file (string-append source "/.guix-channel")))
    (and (file-exists? meta-file)
         (and-let* ((raw (call-with-input-file meta-file read))
                    (version (and=> (assoc-ref raw 'version) first))
                    (dependencies (or (assoc-ref raw 'dependencies) '())))
           (channel-metadata
            version
            (map (lambda (item)
                   (let ((get (lambda* (key #:optional default)
                                (or (and=> (assoc-ref item key) first) default))))
                     (and-let* ((name (get 'name))
                                (url (get 'url))
                                (branch (get 'branch "master")))
                       (channel
                        (name name)
                        (branch branch)
                        (url url)
                        (commit (get 'commit))))))
                 dependencies))))))

(define (channel-instance-dependencies instance)
  "Return the list of channels that are declared as dependencies for the given
channel INSTANCE."
  (match (read-channel-metadata instance)
    (#f '())
    (($ <channel-metadata> version dependencies)
     dependencies)))

(define* (latest-channel-instances store channels #:optional (previous-channels '()))
  "Return a list of channel instances corresponding to the latest checkouts of
CHANNELS and the channels on which they depend.  PREVIOUS-CHANNELS is a list
of previously processed channels."
  ;; Only process channels that are unique, or that are more specific than a
  ;; previous channel specification.
  (define (ignore? channel others)
    (member channel others
            (lambda (a b)
              (and (eq? (channel-name a) (channel-name b))
                   (or (channel-commit b)
                       (not (or (channel-commit a)
                                (channel-commit b))))))))

  ;; Accumulate a list of instances.  A list of processed channels is also
  ;; accumulated to decide on duplicate channel specifications.
  (define-values (resulting-channels instances)
    (fold2 (lambda (channel previous-channels instances)
             (if (ignore? channel previous-channels)
                 (values previous-channels instances)
                 (begin
                   (format (current-error-port)
                           (G_ "Updating channel '~a' from Git repository at '~a'...~%")
                           (channel-name channel)
                           (channel-url channel))
                   (let-values (((checkout commit)
                                 (latest-repository-commit store (channel-url channel)
                                                           #:ref (channel-reference
                                                                  channel))))
                     (let ((instance (channel-instance channel commit checkout)))
                       (let-values (((new-instances new-channels)
                                     (latest-channel-instances
                                      store
                                      (channel-instance-dependencies instance)
                                      previous-channels)))
                         (values (append (cons channel new-channels)
                                         previous-channels)
                                 (append (cons instance new-instances)
                                         instances))))))))
           previous-channels
           '()                                    ;instances
           channels))

  (let ((instance-name (compose channel-name channel-instance-channel)))
    ;; Remove all earlier channel specifications if they are followed by a
    ;; more specific one.
    (values (delete-duplicates instances
                               (lambda (a b)
                                 (eq? (instance-name a) (instance-name b))))
            resulting-channels)))

(define* (checkout->channel-instance checkout
                                     #:key commit
                                     (url checkout) (name 'guix))
  "Return a channel instance for CHECKOUT, which is assumed to be a checkout
of COMMIT at URL.  Use NAME as the channel name."
  (let* ((commit  (or commit (make-string 40 #\0)))
         (channel (channel (name name)
                           (commit commit)
                           (url url))))
    (channel-instance channel commit checkout)))

(define %self-build-file
  ;; The file containing code to build Guix.  This serves the same purpose as
  ;; a makefile, and, similarly, is intended to always keep this name.
  "build-aux/build-self.scm")

(define %pull-version
  ;; This is the version of the 'guix pull' protocol.  It specifies what's
  ;; expected from %SELF-BUILD-FILE.  The initial version ("0") was when we'd
  ;; place a set of compiled Guile modules in ~/.config/guix/latest.
  1)

(define (standard-module-derivation name source core dependencies)
  "Return a derivation that builds with CORE, a Guix instance, the Scheme
modules in SOURCE and that depend on DEPENDENCIES, a list of lowerable
objects.  The assumption is that SOURCE contains package modules to be added
to '%package-module-path'."
  ;; FIXME: We should load, say SOURCE/.guix-channel.scm, which would allow
  ;; channel publishers to specify things such as the sub-directory where .scm
  ;; files live, files to exclude from the channel, preferred substitute URLs,
  ;; etc.

  (define build
    ;; This is code that we'll run in CORE, a Guix instance, with its own
    ;; modules and so on.  That way, we make sure these modules are built for
    ;; the right Guile version, with the right dependencies, and that they get
    ;; to see the right (gnu packages …) modules.
    (with-extensions dependencies
      #~(begin
          (use-modules (guix build compile)
                       (guix build utils)
                       (srfi srfi-26))

          (define go
            (string-append #$output "/lib/guile/" (effective-version)
                           "/site-ccache"))
          (define scm
            (string-append #$output "/share/guile/site/"
                           (effective-version)))

          (compile-files #$source go
                         (find-files #$source "\\.scm$"))
          (mkdir-p (dirname scm))
          (symlink #$source scm)
          scm)))

  (gexp->derivation-in-inferior name build core))

(define* (build-from-source name source
                            #:key core verbose? commit
                            (dependencies '()))
  "Return a derivation to build Guix from SOURCE, using the self-build script
contained therein; use COMMIT as the version string.  When CORE is true, build
package modules under SOURCE using CORE, an instance of Guix."
  ;; Running the self-build script makes it easier to update the build
  ;; procedure: the self-build script of the Guix-to-be-installed contains the
  ;; right dependencies, build procedure, etc., which the Guix-in-use may not
  ;; be know.
  (define script
    (string-append source "/" %self-build-file))

  (if (file-exists? script)
      (let ((build (save-module-excursion
                    (lambda ()
                      (primitive-load script)))))
        ;; BUILD must be a monadic procedure of at least one argument: the
        ;; source tree.
        ;;
        ;; Note: BUILD can return #f if it does not support %PULL-VERSION.  In
        ;; the future we'll fall back to a previous version of the protocol
        ;; when that happens.
        (build source #:verbose? verbose? #:version commit
               #:pull-version %pull-version))

      ;; Build a set of modules that extend Guix using the standard method.
      (standard-module-derivation name source core dependencies)))

(define* (build-channel-instance instance
                                 #:optional core (dependencies '()))
  "Return, as a monadic value, the derivation for INSTANCE, a channel
instance.  DEPENDENCIES is a list of extensions providing Guile modules that
INSTANCE depends on."
  (build-from-source (symbol->string
                      (channel-name (channel-instance-channel instance)))
                     (channel-instance-checkout instance)
                     #:commit (channel-instance-commit instance)
                     #:core core
                     #:dependencies dependencies))

(define (resolve-dependencies instances)
  "Return a procedure that, given one of the elements of INSTANCES, returns
list of instances it depends on."
  (define channel-instance-name
    (compose channel-name channel-instance-channel))

  (define table                                   ;map a name to an instance
    (fold (lambda (instance table)
            (vhash-consq (channel-instance-name instance)
                         instance table))
          vlist-null
          instances))

  (define edges
    (fold (lambda (instance edges)
            (fold (lambda (channel edges)
                    (let ((name (channel-name channel)))
                      (match (vhash-assq name table)
                        ((_ . target)
                         (vhash-consq instance target edges)))))
                  edges
                  (channel-instance-dependencies instance)))
          vlist-null
          instances))

  (lambda (instance)
    (vhash-foldq* cons '() instance edges)))

(define (channel-instance-derivations instances)
  "Return the list of derivations to build INSTANCES, in the same order as
INSTANCES."
  (define core-instance
    ;; The 'guix' channel is treated specially: it's an implicit dependency of
    ;; all the other channels.
    (find (lambda (instance)
            (guix-channel? (channel-instance-channel instance)))
          instances))

  (define edges
    (resolve-dependencies instances))

  (define (instance->derivation instance)
    (mcached (if (eq? instance core-instance)
                 (build-channel-instance instance)
                 (mlet %store-monad ((core (instance->derivation core-instance))
                                     (deps (mapm %store-monad instance->derivation
                                                 (edges instance))))
                   (build-channel-instance instance core deps)))
             instance))

  (unless core-instance
    (let ((loc (and=> (any (compose channel-location channel-instance-channel)
                           instances)
                      source-properties->location)))
      (raise (apply make-compound-condition
                    (condition
                     (&message (message "'guix' channel is lacking")))
                    (if loc
                        (list (condition (&error-location (location loc))))
                        '())))))

  (mapm %store-monad instance->derivation instances))

(define (whole-package-for-legacy name modules)
  "Return a full-blown Guix package for MODULES, a derivation that builds Guix
modules in the old ~/.config/guix/latest style."
  (define packages
    (resolve-interface '(gnu packages guile)))

  (define modules+compiled
    ;; Since MODULES contains both .scm and .go files at its root, re-bundle
    ;; it so that it has share/guile/site and lib/guile, which is what
    ;; 'whole-package' expects.
    (computed-file (derivation-name modules)
                   (with-imported-modules '((guix build utils))
                     #~(begin
                         (use-modules (guix build utils))

                         (define version
                           (effective-version))
                         (define share
                           (string-append #$output "/share/guile/site"))
                         (define lib
                           (string-append #$output "/lib/guile/" version))

                         (mkdir-p share) (mkdir-p lib)
                         (symlink #$modules (string-append share "/" version))
                         (symlink #$modules (string-append lib "/site-ccache"))))))

  (letrec-syntax ((list (syntax-rules (->)
                          ((_)
                           '())
                          ((_ (module -> variable) rest ...)
                           (cons (module-ref (resolve-interface
                                              '(gnu packages module))
                                             'variable)
                                 (list rest ...)))
                          ((_ variable rest ...)
                           (cons (module-ref packages 'variable)
                                 (list rest ...))))))
    (whole-package name modules+compiled

                   ;; In the "old style", %SELF-BUILD-FILE would simply return a
                   ;; derivation that builds modules.  We have to infer what the
                   ;; dependencies of these modules were.
                   (list guile-json guile-git guile-bytestructures
                         (ssh -> guile-ssh) (tls -> gnutls)))))

(define (old-style-guix? drv)
  "Return true if DRV corresponds to a ~/.config/guix/latest style of
derivation."
  ;; Here we rely on a gross historical fact: that derivations produced by the
  ;; "old style" (before commit 8a0d9bc8a3f153159d9e239a151c0fa98f1e12d8,
  ;; dated May 30, 2018) did not depend on "guix-command.drv".
  (not (find (lambda (input)
               (string-suffix? "-guix-command.drv"
                               (derivation-input-path input)))
             (derivation-inputs drv))))

(define (channel-instances->manifest instances)
  "Return a profile manifest with entries for all of INSTANCES, a list of
channel instances."
  (define instance->entry
    (match-lambda
      ((instance drv)
       (let ((commit  (channel-instance-commit instance))
             (channel (channel-instance-channel instance)))
         (with-monad %store-monad
           (return (manifest-entry
                     (name (symbol->string (channel-name channel)))
                     (version (string-take commit 7))
                     (item (if (guix-channel? channel)
                               (if (old-style-guix? drv)
                                   (whole-package-for-legacy
                                    (string-append name "-" version)
                                    drv)
                                   drv)
                               drv))
                     (properties
                      `((source (repository
                                 (version 0)
                                 (url ,(channel-url channel))
                                 (branch ,(channel-branch channel))
                                 (commit ,commit))))))))))))

  (mlet* %store-monad ((derivations (channel-instance-derivations instances))
                       (entries     (mapm %store-monad instance->entry
                                          (zip instances derivations))))
    (return (manifest entries))))

(define (package-cache-file manifest)
  "Build a package cache file for the instance in MANIFEST.  This is meant to
be used as a profile hook."
  (mlet %store-monad ((profile (profile-derivation manifest
                                                   #:hooks '())))

    (define build
      #~(begin
          (use-modules (gnu packages))

          (if (defined? 'generate-package-cache)
              (begin
                ;; Delegate package cache generation to the inferior.
                (format (current-error-port)
                        "Generating package cache for '~a'...~%"
                        #$profile)
                (generate-package-cache #$output))
              (mkdir #$output))))

    (gexp->derivation-in-inferior "guix-package-cache" build
                                  profile
                                  #:properties '((type . profile-hook)
                                                 (hook . package-cache)))))

(define %channel-profile-hooks
  ;; The default channel profile hooks.
  (cons package-cache-file %default-profile-hooks))

(define (channel-instances->derivation instances)
  "Return the derivation of the profile containing INSTANCES, a list of
channel instances."
  (mlet %store-monad ((manifest (channel-instances->manifest instances)))
    (profile-derivation manifest
                        #:hooks %channel-profile-hooks)))

(define latest-channel-instances*
  (store-lift latest-channel-instances))

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