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