guix/channels.scm

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