guix/channels.scm

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