From mboxrd@z Thu Jan 1 00:00:00 1970 From: Ludovic =?UTF-8?Q?Court=C3=A8s?= 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 Message-ID: <20180828151751.4657-3-ludo@gnu.org> References: <87pny2iks2.fsf@gnu.org> <20180828151751.4657-1-ludo@gnu.org> Mime-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:44032) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1fug1I-0007LI-P2 for bug-guix@gnu.org; Tue, 28 Aug 2018 11:35:09 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1fufln-0000zJ-A5 for bug-guix@gnu.org; Tue, 28 Aug 2018 11:19:05 -0400 Received: from debbugs.gnu.org ([208.118.235.43]:59031) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1fufln-0000z4-3S for bug-guix@gnu.org; Tue, 28 Aug 2018 11:19:03 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1fuflm-0000IV-U9 for bug-guix@gnu.org; Tue, 28 Aug 2018 11:19:02 -0400 Sender: "Debbugs-submit" Resent-Message-ID: In-Reply-To: <20180828151751.4657-1-ludo@gnu.org> List-Id: Bug reports for GNU Guix List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-guix-bounces+gcggb-bug-guix=m.gmane.org@gnu.org Sender: "bug-Guix" To: 22629@debbugs.gnu.org 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 +;;; +;;; 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 . + +(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 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 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