[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
bug#22629: [PATCH 3/3] DRAFT Add (guix channels) and use it in (guix scr
|
From: |
Ludovic Courtès |
|
Subject: |
bug#22629: [PATCH 3/3] DRAFT Add (guix channels) and use it in (guix scripts pull). |
|
Date: |
Tue, 28 Aug 2018 17:17:51 +0200 |
DRAFT: Missing documentation for ~/.config/guix/channels.scm.
* guix/channels.scm: New file.
* Makefile.am (MODULES): Add it.
* guix/scripts/pull.scm: Use it.
(%self-build-file, %pull-version, build-from-source)
(whole-package-for-legacy, derivation->manifest-entry): Remove. These
now exist in a similar formin (guix channels).
(build-and-install): Change 'source' to 'instances'. Remove #:url,
#:branch, and #:commit. Rewrite using 'channel-instances->manifest'.
(channel-list): New procedure.
(guix-pull): Parameterize %REPOSITORY-CACHE-DIRECTORY. Call
'honor-lets-encrypt-certificates!' unconditionally. Load
~/.config/guix/channels.scm. Rewrite to use (guix channels).
[use-le-certs?]: Remove.
* po/guix/POTFILES.in: Add (guix channels).
---
Makefile.am | 1 +
guix/channels.scm | 292 ++++++++++++++++++++++++++++++++++++++++++
guix/scripts/pull.scm | 198 +++++++++++-----------------
po/guix/POTFILES.in | 1 +
4 files changed, 372 insertions(+), 120 deletions(-)
create mode 100644 guix/channels.scm
diff --git a/Makefile.am b/Makefile.am
index b6efd6d62..af6870cf6 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -87,6 +87,7 @@ MODULES = \
guix/grafts.scm \
guix/inferior.scm \
guix/describe.scm \
+ guix/channels.scm \
guix/gnu-maintenance.scm \
guix/self.scm \
guix/upstream.scm \
diff --git a/guix/channels.scm b/guix/channels.scm
new file mode 100644
index 000000000..ec3e05eaf
--- /dev/null
+++ b/guix/channels.scm
@@ -0,0 +1,292 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Ludovic Courtès <address@hidden>
+;;;
+;;; 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 discovery)
+ #:use-module (guix monads)
+ #:use-module (guix profiles)
+ #:use-module (guix derivations)
+ #:use-module (guix store)
+ #:use-module (guix i18n)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-11)
+ #:autoload (guix self) (whole-package)
+ #:use-module (ice-9 match)
+ #: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
+ channel-instance-derivations
+ latest-channel-derivations
+ channel-instances->manifest))
+
+;;; 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)))
+;; TODO: Add a way to express dependencies among channels.
+
+(define %default-channels
+ ;; Default list of channels.
+ (list (channel
+ (name 'guix)
+ (branch "origin/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 (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 (latest-channel-instances store channels)
+ "Return a list of channel instances corresponding to the latest checkouts of
+CHANNELS."
+ (map (lambda (channel)
+ (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))))
+ (channel-instance channel commit checkout)))
+ channels))
+
+(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 dependencies)
+ "Return a derivation that builds 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'."
+ (define modules
+ (scheme-modules* source))
+
+ ;; 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.
+ (mlet* %store-monad ((compiled
+ (compiled-modules modules
+ #:name name
+ #:module-path (list source)
+ #:extensions dependencies)))
+
+ (gexp->derivation name
+ (with-extensions dependencies
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils))
+
+ (let ((go (string-append #$output "/lib/guile/"
+ (effective-version)
+ "/site-ccache"))
+ (scm (string-append #$output
+ "/share/guile/site/"
+ (effective-version))))
+ (mkdir-p (dirname go))
+ (symlink #$compiled go)
+ (mkdir-p (dirname scm))
+ (symlink #$source scm))))))))
+
+(define* (build-from-source name source
+ #:key verbose? commit
+ (dependencies '()))
+ "Return a derivation to build Guix from SOURCE, using the self-build script
+contained therein. Use COMMIT as the version string."
+ ;; 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 dependencies)))
+
+(define* (build-channel-instance instance #:optional (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)
+ #:dependencies dependencies))
+
+(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))
+
+ (mlet %store-monad ((core (build-channel-instance core-instance)))
+ (mapm %store-monad
+ (lambda (instance)
+ (if (eq? instance core-instance)
+ (return core)
+ (build-channel-instance instance
+ (list core))))
+ instances)))
+
+(define latest-channel-derivations
+ (let ((latest-channel-instances (store-lift latest-channel-instances)))
+ (lambda (channels)
+ "Return, as a monadic value, the list of derivations for the latest
+instances of CHANNELS."
+ (mlet %store-monad ((instances (latest-channel-instances channels)))
+ (channel-instance-derivations 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)))
+
+ (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
+
+ ;; 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))))
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index ee68c21a4..d7931506b 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -30,26 +30,19 @@
#:use-module (guix grafts)
#:use-module (guix memoization)
#:use-module (guix monads)
+ #:use-module (guix channels)
#:autoload (guix inferior) (open-inferior)
#:use-module (guix scripts build)
- #:autoload (guix self) (whole-package)
#:use-module (guix git)
#:use-module (git)
#:use-module (gnu packages)
- #:autoload (gnu packages ssh) (guile-ssh)
- #:autoload (gnu packages tls) (gnutls)
#:use-module ((guix scripts package) #:select (build-and-use-profile))
- #:use-module ((guix build utils)
- #:select (with-directory-excursion delete-file-recursively))
- #:use-module ((guix build download)
- #:select (%x509-certificate-directory))
#:use-module (gnu packages base)
#:use-module (gnu packages guile)
#:use-module ((gnu packages bootstrap)
#:select (%bootstrap-guile))
#:use-module ((gnu packages certs) #:select (le-certs))
#:use-module (srfi srfi-1)
- #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-35)
#:use-module (srfi srfi-37)
@@ -57,9 +50,6 @@
#:use-module (ice-9 vlist)
#:export (guix-pull))
-(define %repository-url
- (or (getenv "GUIX_PULL_URL") "https://git.savannah.gnu.org/git/guix.git";))
-
;;;
;;; Command-line options.
@@ -67,9 +57,7 @@
(define %default-options
;; Alist of default option values.
- `((repository-url . ,%repository-url)
- (ref . (branch . "origin/master"))
- (system . ,(%current-system))
+ `((system . ,(%current-system))
(substitutes? . #t)
(build-hook? . #t)
(graft? . #t)
@@ -142,70 +130,6 @@ Download and deploy the latest version of Guix.\n"))
(define indirect-root-added
(store-lift add-indirect-root))
-(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* (build-from-source source
- #:key verbose? commit)
- "Return a derivation to build Guix from SOURCE, using the self-build script
-contained therein. Use COMMIT as the version string."
- ;; 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.
- (let* ((script (string-append source "/" %self-build-file))
- (build (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)))
-
-(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."
- (whole-package name modules
-
- ;; 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
- guile-ssh gnutls)))
-
-(define* (derivation->manifest-entry drv
- #:key url branch commit)
- "Return a manifest entry for DRV, which represents Guix at COMMIT. Record
-URL, BRANCH, and COMMIT as a property in the manifest entry."
- (mbegin %store-monad
- (what-to-build (list drv))
- (built-derivations (list drv))
- (let ((out (derivation->output-path drv)))
- (return (manifest-entry
- (name "guix")
- (version (string-take commit 7))
- (item (if (file-exists? (string-append out "/bin/guix"))
- drv
- (whole-package-for-legacy (string-append name "-"
- version)
- drv)))
- (properties
- `((source (repository
- (version 0)
- (url ,url)
- (branch ,branch)
- (commit ,commit))))))))))
-
(define (display-profile-news profile)
"Display what's up in PROFILE--new packages, and all that."
(match (memv (generation-number profile)
@@ -223,8 +147,8 @@ URL, BRANCH, and COMMIT as a property in the manifest
entry."
#:heading (G_ "New in this
revision:\n"))))
(_ #t)))
-(define* (build-and-install source config-dir
- #:key verbose? url branch commit)
+(define* (build-and-install instances config-dir
+ #:key verbose?)
"Build the tool from SOURCE, and install it in CONFIG-DIR."
(define update-profile
(store-lift build-and-use-profile))
@@ -232,15 +156,9 @@ URL, BRANCH, and COMMIT as a property in the manifest
entry."
(define profile
(string-append config-dir "/current"))
- (mlet* %store-monad ((drv (build-from-source source
- #:commit commit
- #:verbose? verbose?))
- (entry (derivation->manifest-entry drv
- #:url url
- #:branch branch
- #:commit commit)))
+ (mlet %store-monad ((manifest (channel-instances->manifest instances)))
(mbegin %store-monad
- (update-profile profile (manifest (list entry)))
+ (update-profile profile manifest)
(return (display-profile-news profile)))))
(define (honor-lets-encrypt-certificates! store)
@@ -426,45 +344,91 @@ and ALIST2 differ, display HEADING upfront."
((numbers ...)
(list-generations profile numbers)))))))))
+(define (channel-list file opts)
+ "Return the list of channels to use. If FILE exists, channels are read from
+there; otherwise %DEFAULT-CHANNELS is used. Apply channel transformations
+specified in OPTS (resulting from '--url', '--commit', or '--branch'), if
+any."
+ (define channels
+ (if (file-exists? file)
+ (load* file (make-user-module '((guix channels))))
+ %default-channels))
+
+ (define (environment-variable)
+ (match (getenv "GUIX_PULL_URL")
+ (#f #f)
+ (url
+ (warning (G_ "The 'GUIX_PULL_URL' environment variable is deprecated.
+Use '~/.config/guix/channels.scm' instead."))
+ url)))
+
+ (let ((ref (assoc-ref opts 'ref))
+ (url (or (assoc-ref opts 'url)
+ (environment-variable))))
+ (if (or ref url)
+ (match channels
+ ((one)
+ ;; When there's only one channel, apply '--url', '--commit', and
+ ;; '--branch' to this specific channel.
+ (let ((url (or url (channel-url one))))
+ (list (match ref
+ (('commit . commit)
+ (channel (inherit one)
+ (url url) (commit commit) (branch #f)))
+ (('branch . branch)
+ (channel (inherit one)
+ (url url) (commit #f) (branch branch)))
+ (#f
+ (channel (inherit one) (url url)))))))
+ (_
+ ;; Otherwise bail out.
+ (leave
+ (G_ "'--url', '--commit', and '--branch' are not applicable~%"))))
+ channels)))
+
(define (guix-pull . args)
- (define (use-le-certs? url)
- (string-prefix? "https://git.savannah.gnu.org/"; url))
-
(with-error-handling
(with-git-error-handling
- (let* ((opts (parse-command-line args %options
- (list %default-options)))
- (url (assoc-ref opts 'repository-url))
- (ref (assoc-ref opts 'ref))
- (cache (string-append (cache-directory) "/pull")))
+ (let* ((opts (parse-command-line args %options
+ (list %default-options)))
+ (cache (string-append (cache-directory) "/pull"))
+ (channel-file (string-append (config-directory) "/channels.scm"))
+ (channels (channel-list channel-file opts)))
+
(cond ((assoc-ref opts 'query)
(process-query opts))
((assoc-ref opts 'dry-run?)
#t) ;XXX: not very useful
(else
(with-store store
- (parameterize ((%graft? (assoc-ref opts 'graft?)))
+ (parameterize ((%graft? (assoc-ref opts 'graft?))
+ (%repository-cache-directory cache))
(set-build-options-from-command-line store opts)
- ;; For reproducibility, always refer to the LE certificates
- ;; when we know we're talking to Savannah.
- (when (use-le-certs? url)
- (honor-lets-encrypt-certificates! store))
-
- (format (current-error-port)
- (G_ "Updating from Git repository at '~a'...~%")
- url)
-
- (let-values (((checkout commit)
- (latest-repository-commit store url
- #:ref ref
- #:cache-directory
- cache)))
+ ;; When certificates are already installed, use them.
+ ;; Otherwise, use the Let's Encrypt certificates, which we
+ ;; know Savannah uses.
+ (let ((certs (or (getenv "SSL_CERT_DIR") "/etc/ssl/certs")))
+ (unless (file-exists? certs)
+ (honor-lets-encrypt-certificates! store)))
+ (let ((instances (latest-channel-instances store channels)))
(format (current-error-port)
- (G_ "Building from Git commit ~a...~%")
- commit)
+ (N_ "Building from this channel:~%"
+ "Building from these channels:~%"
+ (length instances)))
+ (for-each (lambda (instance)
+ (let ((channel
+ (channel-instance-channel instance)))
+ (format (current-error-port)
+ " ~10a~a\t~a~%"
+ (channel-name channel)
+ (channel-url channel)
+ (string-take
+ (channel-instance-commit instance)
+ 7))))
+ instances)
(parameterize ((%guile-for-build
(package-derivation
store
@@ -472,13 +436,7 @@ and ALIST2 differ, display HEADING upfront."
%bootstrap-guile
(canonical-package guile-2.2)))))
(run-with-store store
- (build-and-install checkout (config-directory)
- #:url url
- #:branch (match ref
- (('branch . branch)
- branch)
- (_ #f))
- #:commit commit
+ (build-and-install instances (config-directory)
#:verbose?
(assoc-ref opts
'verbose?)))))))))))))
diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in
index d11f408d4..7f881355e 100644
--- a/po/guix/POTFILES.in
+++ b/po/guix/POTFILES.in
@@ -38,4 +38,5 @@ guix/upstream.scm
guix/ui.scm
guix/http-client.scm
guix/nar.scm
+guix/channels.scm
nix/nix-daemon/guix-daemon.cc
--
2.18.0