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