guix/channels.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018, 2019, 2020, 2021 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 (git)
  23   #:use-module (guix git)
  24   #:use-module (guix git-authenticate)
  25   #:use-module ((guix openpgp)
  26                 #:select (openpgp-public-key-fingerprint
  27                           openpgp-format-fingerprint))
  28   #:use-module (guix base16)
  29   #:use-module (guix records)
  30   #:use-module (guix gexp)
  31   #:use-module (guix modules)
  32   #:use-module (guix discovery)
  33   #:use-module (guix monads)
  34   #:use-module (guix profiles)
  35   #:use-module (guix packages)
  36   #:use-module (guix progress)
  37   #:use-module (guix derivations)
  38   #:use-module (guix combinators)
  39   #:use-module (guix diagnostics)
  40   #:use-module (guix sets)
  41   #:use-module (guix store)
  42   #:use-module (guix i18n)
  43   #:use-module (srfi srfi-1)
  44   #:use-module (srfi srfi-2)
  45   #:use-module (srfi srfi-9)
  46   #:use-module (srfi srfi-11)
  47   #:use-module (srfi srfi-26)
  48   #:use-module (srfi srfi-34)
  49   #:use-module (srfi srfi-35)
  50   #:autoload   (guix describe) (current-channels) ;XXX: circular dep
  51   #:autoload   (guix self) (whole-package make-config.scm)
  52   #:autoload   (guix inferior) (gexp->derivation-in-inferior) ;FIXME: circular dep
  53   #:autoload   (guix quirks) (%quirks %patches applicable-patch? apply-patch)
  54   #:use-module (ice-9 format)
  55   #:use-module (ice-9 match)
  56   #:use-module (ice-9 vlist)
  57   #:use-module ((ice-9 rdelim) #:select (read-string))
  58   #:use-module ((rnrs bytevectors) #:select (bytevector=?))
  59   #:export (channel
  60             channel?
  61             channel-name
  62             channel-url
  63             channel-branch
  64             channel-commit
  65             channel-introduction
  66             channel-location
  67
  68             channel-introduction?
  69             make-channel-introduction
  70             channel-introduction-first-signed-commit
  71             channel-introduction-first-commit-signer
  72
  73             openpgp-fingerprint->bytevector
  74             openpgp-fingerprint
  75
  76             %default-guix-channel
  77             %default-channels
  78             guix-channel?
  79
  80             channel-instance?
  81             channel-instance-channel
  82             channel-instance-commit
  83             channel-instance-checkout
  84
  85             authenticate-channel
  86             latest-channel-instances
  87             checkout->channel-instance
  88             latest-channel-derivation
  89             channel-instance->sexp
  90             channel-instances->manifest
  91             %channel-profile-hooks
  92             channel-instances->derivation
  93             ensure-forward-channel-update
  94
  95             profile-channels
  96             manifest-entry-channel
  97             sexp->channel
  98             channel->code
  99
 100             channel-news-entry?
 101             channel-news-entry-commit
 102             channel-news-entry-tag
 103             channel-news-entry-title
 104             channel-news-entry-body
 105
 106             channel-news-for-commit))
 107
 108 ;;; Commentary:
 109 ;;;
 110 ;;; This module implements "channels."  A channel is usually a source of
 111 ;;; package definitions.  There's a special channel, the 'guix' channel, that
 112 ;;; provides all of Guix, including its commands and its documentation.
 113 ;;; User-defined channels are expected to typically provide a bunch of .scm
 114 ;;; files meant to be added to the '%package-search-path'.
 115 ;;;
 116 ;;; This module provides tools to fetch and update channels from a Git
 117 ;;; repository and to build them.
 118 ;;;
 119 ;;; Code:
 120
 121 (define-record-type* <channel> channel make-channel
 122   channel?
 123   (name      channel-name)
 124   (url       channel-url)
 125   (branch    channel-branch (default "master"))
 126   (commit    channel-commit (default #f))
 127   (introduction channel-introduction (default #f))
 128   (location  channel-location
 129              (default (current-source-location)) (innate)))
 130
 131 ;; Channel introductions.  A "channel introduction" provides a commit/signer
 132 ;; pair that specifies the first commit of the authentication process as well
 133 ;; as its signer's fingerprint.  Introductions are used to bootstrap trust in
 134 ;; a channel.
 135 (define-record-type <channel-introduction>
 136   (%make-channel-introduction first-signed-commit first-commit-signer)
 137   channel-introduction?
 138   (first-signed-commit  channel-introduction-first-signed-commit)  ;hex string
 139   (first-commit-signer  channel-introduction-first-commit-signer)) ;bytevector
 140
 141 (define (make-channel-introduction commit signer)
 142   "Return a new channel introduction: COMMIT is the introductory where
 143 authentication starts, and SIGNER is the OpenPGP fingerprint (a bytevector) of
 144 the signer of that commit."
 145   (%make-channel-introduction commit signer))
 146
 147 (define (openpgp-fingerprint->bytevector str)
 148   "Convert STR, an OpenPGP fingerprint (hexadecimal string with whitespace),
 149 to the corresponding bytevector."
 150   (base16-string->bytevector
 151    (string-downcase (string-filter char-set:hex-digit str))))
 152
 153 (define-syntax openpgp-fingerprint
 154   (lambda (s)
 155     "Convert STR, an OpenPGP fingerprint (hexadecimal string with whitespace),
 156 to the corresponding bytevector."
 157     (syntax-case s ()
 158       ((_ str)
 159        (string? (syntax->datum #'str))
 160        (openpgp-fingerprint->bytevector (syntax->datum #'str)))
 161       ((_ str)
 162        #'(openpgp-fingerprint->bytevector str)))))
 163
 164 (define %guix-channel-introduction
 165   ;; Introduction of the official 'guix channel.  The chosen commit is the
 166   ;; first one that introduces '.guix-authorizations' on the 'staging'
 167   ;; branch that was eventually merged in 'master'.  Any branch starting
 168   ;; before that commit cannot be merged or it will be rejected by 'guix pull'
 169   ;; & co.
 170   (make-channel-introduction
 171    "9edb3f66fd807b096b48283debdcddccfea34bad"     ;2020-05-26
 172    (openpgp-fingerprint                           ;mbakke
 173     "BBB0 2DDF 2CEA F6A8 0D1D  E643 A2A0 6DF2 A33A 54FA")))
 174
 175 (define %default-channel-url
 176   ;; URL of the default 'guix' channel.
 177   "https://git.savannah.gnu.org/git/guix.git")
 178
 179 (define %default-guix-channel
 180   (channel
 181    (name 'guix)
 182    (branch "master")
 183    (url %default-channel-url)
 184    (introduction %guix-channel-introduction)))
 185
 186 (define %default-channels
 187   ;; Default list of channels.
 188   (list %default-guix-channel))
 189
 190 (define (guix-channel? channel)
 191   "Return true if CHANNEL is the 'guix' channel."
 192   (eq? 'guix (channel-name channel)))
 193
 194 (define (ensure-default-introduction chan)
 195   "If CHAN represents the \"official\" 'guix' channel and lacks an
 196 introduction, add it."
 197   (if (and (guix-channel? chan)
 198            (not (channel-introduction chan))
 199            (string=? (channel-url chan) %default-channel-url))
 200       (channel (inherit chan)
 201                (introduction %guix-channel-introduction))
 202       chan))
 203
 204 (define-record-type <channel-instance>
 205   (channel-instance channel commit checkout)
 206   channel-instance?
 207   (channel   channel-instance-channel)
 208   (commit    channel-instance-commit)
 209   (checkout  channel-instance-checkout))
 210
 211 (define-record-type <channel-metadata>
 212   (channel-metadata directory dependencies news-file keyring-reference url)
 213   channel-metadata?
 214   (directory     channel-metadata-directory)      ;string with leading slash
 215   (dependencies  channel-metadata-dependencies)   ;list of <channel>
 216   (news-file     channel-metadata-news-file)      ;string | #f
 217   (keyring-reference channel-metadata-keyring-reference) ;string
 218   (url           channel-metadata-url))           ;string | #f
 219
 220 (define %default-keyring-reference
 221   ;; Default value of the 'keyring-reference' field.
 222   "keyring")
 223
 224 (define (channel-reference channel)
 225   "Return the \"reference\" for CHANNEL, an sexp suitable for
 226 'latest-repository-commit'."
 227   (match (channel-commit channel)
 228     (#f      `(branch . ,(channel-branch channel)))
 229     (commit  `(commit . ,(channel-commit channel)))))
 230
 231 (define sexp->channel-introduction
 232   (match-lambda
 233     (('channel-introduction ('version 0)
 234                             ('commit commit) ('signer signer)
 235                             _ ...)
 236      (make-channel-introduction commit (openpgp-fingerprint signer)))
 237     (x #f)))
 238
 239 (define (read-channel-metadata port)
 240   "Read from PORT channel metadata in the format expected for the
 241 '.guix-channel' file.  Return a <channel-metadata> record, or raise an error
 242 if valid metadata could not be read from PORT."
 243   (match (read port)
 244     (('channel ('version 0) properties ...)
 245      (let ((directory    (and=> (assoc-ref properties 'directory) first))
 246            (dependencies (or (assoc-ref properties 'dependencies) '()))
 247            (news-file    (and=> (assoc-ref properties 'news-file) first))
 248            (url          (and=> (assoc-ref properties 'url) first))
 249            (keyring-reference
 250             (or (and=> (assoc-ref properties 'keyring-reference) first)
 251                 %default-keyring-reference)))
 252        (channel-metadata
 253         (cond ((not directory) "/")               ;directory
 254               ((string-prefix? "/" directory) directory)
 255               (else (string-append "/" directory)))
 256         (map (lambda (item)                       ;dependencies
 257                (let ((get (lambda* (key #:optional default)
 258                             (or (and=> (assoc-ref item key) first) default))))
 259                  (and-let* ((name (get 'name))
 260                             (url (get 'url))
 261                             (branch (get 'branch "master")))
 262                    (channel
 263                     (name name)
 264                     (branch branch)
 265                     (url url)
 266                     (commit (get 'commit))
 267                     (introduction (and=> (get 'introduction)
 268                                          sexp->channel-introduction))))))
 269              dependencies)
 270         news-file
 271         keyring-reference
 272         url)))
 273     ((and ('channel ('version version) _ ...) sexp)
 274      (raise (condition
 275              (&message (message "unsupported '.guix-channel' version"))
 276              (&error-location
 277               (location (source-properties->location
 278                          (source-properties sexp)))))))
 279     (sexp
 280      (raise (condition
 281              (&message (message "invalid '.guix-channel' file"))
 282              (&error-location
 283               (location (source-properties->location
 284                          (source-properties sexp)))))))))
 285
 286 (define (read-channel-metadata-from-source source)
 287   "Return a channel-metadata record read from channel's SOURCE/.guix-channel
 288 description file, or return the default channel-metadata record if that file
 289 doesn't exist."
 290   (catch 'system-error
 291     (lambda ()
 292       (call-with-input-file (string-append source "/.guix-channel")
 293         read-channel-metadata))
 294     (lambda args
 295       (if (= ENOENT (system-error-errno args))
 296           (channel-metadata "/" '() #f %default-keyring-reference #f)
 297           (apply throw args)))))
 298
 299 (define (channel-instance-metadata instance)
 300   "Return a channel-metadata record read from the channel INSTANCE's
 301 description file or its default value."
 302   (read-channel-metadata-from-source (channel-instance-checkout instance)))
 303
 304 (define (channel-instance-dependencies instance)
 305   "Return the list of channels that are declared as dependencies for the given
 306 channel INSTANCE."
 307   (channel-metadata-dependencies (channel-instance-metadata instance)))
 308
 309 (define (apply-patches checkout commit patches)
 310   "Apply the matching PATCHES to CHECKOUT, modifying files in place.  The
 311 result is unspecified."
 312   (let loop ((patches patches))
 313     (match patches
 314       (() #t)
 315       ((patch rest ...)
 316        (when (applicable-patch? patch checkout commit)
 317          (apply-patch patch checkout))
 318        (loop rest)))))
 319
 320 (define commit-short-id
 321   (compose (cut string-take <> 7) oid->string commit-id))
 322
 323 (define* (authenticate-channel channel checkout commit
 324                                #:key (keyring-reference-prefix "origin/"))
 325   "Authenticate the given COMMIT of CHANNEL, available at CHECKOUT, a
 326 directory containing a CHANNEL checkout.  Raise an error if authentication
 327 fails."
 328   (define intro
 329     (channel-introduction channel))
 330
 331   (define cache-key
 332     (string-append "channels/" (symbol->string (channel-name channel))))
 333
 334   (define keyring-reference
 335     (channel-metadata-keyring-reference
 336      (read-channel-metadata-from-source checkout)))
 337
 338   (define (make-reporter start-commit end-commit commits)
 339     (format (current-error-port)
 340             (G_ "Authenticating channel '~a', commits ~a to ~a (~h new \
 341 commits)...~%")
 342             (channel-name channel)
 343             (commit-short-id start-commit)
 344             (commit-short-id end-commit)
 345             (length commits))
 346
 347     (progress-reporter/bar (length commits)))
 348
 349   (define authentic-commits
 350     ;; Consider the currently-used commit of CHANNEL as authentic so
 351     ;; authentication can skip it and all its closure.
 352     (match (find (lambda (candidate)
 353                    (eq? (channel-name candidate) (channel-name channel)))
 354                  (current-channels))
 355       (#f '())
 356       (channel
 357        (if (channel-commit channel)
 358            (list (channel-commit channel))
 359            '()))))
 360
 361   ;; XXX: Too bad we need to re-open CHECKOUT.
 362   (with-repository checkout repository
 363     (authenticate-repository repository
 364                              (string->oid
 365                               (channel-introduction-first-signed-commit intro))
 366                              (channel-introduction-first-commit-signer intro)
 367                              #:end (string->oid commit)
 368                              #:keyring-reference
 369                              (string-append keyring-reference-prefix
 370                                             keyring-reference)
 371                              #:authentic-commits authentic-commits
 372                              #:make-reporter make-reporter
 373                              #:cache-key cache-key)))
 374
 375 (define* (latest-channel-instance store channel
 376                                   #:key (patches %patches)
 377                                   starting-commit
 378                                   (authenticate? #f)
 379                                   (validate-pull
 380                                    ensure-forward-channel-update))
 381   "Return the latest channel instance for CHANNEL.  When STARTING-COMMIT is
 382 true, call VALIDATE-PULL with CHANNEL, STARTING-COMMIT, the target commit, and
 383 their relation.  When AUTHENTICATE? is false, CHANNEL is not authenticated."
 384   (define (dot-git? file stat)
 385     (and (string=? (basename file) ".git")
 386          (eq? 'directory (stat:type stat))))
 387
 388   (let-values (((channel)
 389                 (ensure-default-introduction channel))
 390                ((checkout commit relation)
 391                 (update-cached-checkout (channel-url channel)
 392                                         #:ref (channel-reference channel)
 393                                         #:starting-commit starting-commit)))
 394     (when relation
 395       (validate-pull channel starting-commit commit relation))
 396
 397     (if authenticate?
 398         (if (channel-introduction channel)
 399             (authenticate-channel channel checkout commit)
 400             ;; TODO: Warn for all the channels once the authentication interface
 401             ;; is public.
 402             (when (guix-channel? channel)
 403               (raise (make-compound-condition
 404                       (formatted-message (G_ "channel '~a' lacks an \
 405 introduction and cannot be authenticated~%")
 406                                          (channel-name channel))
 407                       (condition
 408                        (&fix-hint
 409                         (hint (G_ "Add the missing introduction to your
 410 channels file to address the issue.  Alternatively, you can pass
 411 @option{--disable-authentication}, at the risk of running unauthenticated and
 412 thus potentially malicious code."))))))))
 413         (warning (G_ "channel authentication disabled~%")))
 414
 415     (when (guix-channel? channel)
 416       ;; Apply the relevant subset of PATCHES directly in CHECKOUT.  This is
 417       ;; safe to do because 'switch-to-ref' eventually does a hard reset.
 418       (apply-patches checkout commit patches))
 419
 420     (let* ((name     (url+commit->name (channel-url channel) commit))
 421            (checkout (add-to-store store name #t "sha256" checkout
 422                                    #:select? (negate dot-git?))))
 423       (channel-instance channel commit checkout))))
 424
 425 (define (ensure-forward-channel-update channel start commit relation)
 426   "Raise an error if RELATION is not 'ancestor, meaning that START is not an
 427 ancestor of COMMIT, unless CHANNEL specifies a commit.
 428
 429 This procedure implements a channel update policy meant to be used as a
 430 #:validate-pull argument."
 431   (match relation
 432     ('ancestor #t)
 433     ('self #t)
 434     (_
 435      (raise (make-compound-condition
 436              (condition
 437               (&message (message
 438                          (format #f (G_ "\
 439 aborting update of channel '~a' to commit ~a, which is not a descendant of ~a")
 440                                  (channel-name channel)
 441                                  commit start))))
 442
 443              ;; If the user asked for a specific commit, they might want
 444              ;; that to happen nevertheless, so tell them about the
 445              ;; relevant 'guix pull' option.
 446              (if (channel-commit channel)
 447                  (condition
 448                   (&fix-hint
 449                    (hint (G_ "Use @option{--allow-downgrades} to force
 450 this downgrade."))))
 451                  (condition
 452                   (&fix-hint
 453                    (hint (G_ "This could indicate that the channel has
 454 been tampered with and is trying to force a roll-back, preventing you from
 455 getting the latest updates.  If you think this is not the case, explicitly
 456 allow non-forward updates."))))))))))
 457
 458 (define (channel-instance-primary-url instance)
 459   "Return the primary URL advertised for INSTANCE, or #f if there is no such
 460 information."
 461   (channel-metadata-url (channel-instance-metadata instance)))
 462
 463 (define* (latest-channel-instances store channels
 464                                    #:key
 465                                    (current-channels '())
 466                                    (authenticate? #t)
 467                                    (validate-pull
 468                                     ensure-forward-channel-update))
 469   "Return a list of channel instances corresponding to the latest checkouts of
 470 CHANNELS and the channels on which they depend.
 471
 472 When AUTHENTICATE? is true, authenticate the subset of CHANNELS that has a
 473 \"channel introduction\".
 474
 475 CURRENT-CHANNELS is the list of currently used channels.  It is compared
 476 against the newly-fetched instances of CHANNELS, and VALIDATE-PULL is called
 477 for each channel update and can choose to emit warnings or raise an error,
 478 depending on the policy it implements."
 479   ;; Only process channels that are unique, or that are more specific than a
 480   ;; previous channel specification.
 481   (define (ignore? channel others)
 482     (member channel others
 483             (lambda (a b)
 484               (and (eq? (channel-name a) (channel-name b))
 485                    (or (channel-commit b)
 486                        (not (or (channel-commit a)
 487                                 (channel-commit b))))))))
 488
 489   (define (current-commit name)
 490     ;; Return the current commit for channel NAME.
 491     (any (lambda (channel)
 492            (and (eq? (channel-name channel) name)
 493                 (channel-commit channel)))
 494          current-channels))
 495
 496   (let loop ((channels channels)
 497              (previous-channels '()))
 498     ;; Accumulate a list of instances.  A list of processed channels is also
 499     ;; accumulated to decide on duplicate channel specifications.
 500     (define-values (resulting-channels instances)
 501       (fold2 (lambda (channel previous-channels instances)
 502                (if (ignore? channel previous-channels)
 503                    (values previous-channels instances)
 504                    (begin
 505                      (format (current-error-port)
 506                              (G_ "Updating channel '~a' from Git repository at '~a'...~%")
 507                              (channel-name channel)
 508                              (channel-url channel))
 509                      (let* ((current (current-commit (channel-name channel)))
 510                             (instance
 511                              (latest-channel-instance store channel
 512                                                       #:authenticate?
 513                                                       authenticate?
 514                                                       #:validate-pull
 515                                                       validate-pull
 516                                                       #:starting-commit
 517                                                       current)))
 518                        (when authenticate?
 519                          ;; CHANNEL is authenticated so we can trust the
 520                          ;; primary URL advertised in its metadata and warn
 521                          ;; about possibly stale mirrors.
 522                          (let ((primary-url (channel-instance-primary-url
 523                                              instance)))
 524                            (unless (or (not primary-url)
 525                                        (channel-commit channel)
 526                                        (string=? primary-url (channel-url channel)))
 527                              (warning (G_ "pulled channel '~a' from a mirror \
 528 of ~a, which might be stale~%")
 529                                       (channel-name channel)
 530                                       primary-url))))
 531
 532                        (let-values (((new-instances new-channels)
 533                                      (loop (channel-instance-dependencies instance)
 534                                            previous-channels)))
 535                          (values (append (cons channel new-channels)
 536                                          previous-channels)
 537                                  (append (cons instance new-instances)
 538                                          instances)))))))
 539              previous-channels
 540              '()                                  ;instances
 541              channels))
 542
 543     (let ((instance-name (compose channel-name channel-instance-channel)))
 544       ;; Remove all earlier channel specifications if they are followed by a
 545       ;; more specific one.
 546       (values (delete-duplicates instances
 547                                  (lambda (a b)
 548                                    (eq? (instance-name a) (instance-name b))))
 549               resulting-channels))))
 550
 551 (define* (checkout->channel-instance checkout
 552                                      #:key commit
 553                                      (url checkout) (name 'guix))
 554   "Return a channel instance for CHECKOUT, which is assumed to be a checkout
 555 of COMMIT at URL.  Use NAME as the channel name."
 556   (let* ((commit  (or commit (make-string 40 #\0)))
 557          (channel (channel (name name)
 558                            (commit commit)
 559                            (url url))))
 560     (channel-instance channel commit checkout)))
 561
 562 (define %self-build-file
 563   ;; The file containing code to build Guix.  This serves the same purpose as
 564   ;; a makefile, and, similarly, is intended to always keep this name.
 565   "build-aux/build-self.scm")
 566
 567 (define %pull-version
 568   ;; This is the version of the 'guix pull' protocol.  It specifies what's
 569   ;; expected from %SELF-BUILD-FILE.  The initial version ("0") was when we'd
 570   ;; place a set of compiled Guile modules in ~/.config/guix/latest.
 571   1)
 572
 573 (define (standard-module-derivation name source core dependencies)
 574   "Return a derivation that builds with CORE, a Guix instance, the Scheme
 575 modules in SOURCE and that depend on DEPENDENCIES, a list of lowerable
 576 objects.  The assumption is that SOURCE contains package modules to be added
 577 to '%package-module-path'."
 578
 579   (let* ((metadata (read-channel-metadata-from-source source))
 580          (directory (channel-metadata-directory metadata)))
 581
 582     (define build
 583       ;; This is code that we'll run in CORE, a Guix instance, with its own
 584       ;; modules and so on.  That way, we make sure these modules are built for
 585       ;; the right Guile version, with the right dependencies, and that they get
 586       ;; to see the right (gnu packages …) modules.
 587       (with-extensions dependencies
 588         #~(begin
 589             (use-modules (guix build compile)
 590                          (guix build utils)
 591                          (srfi srfi-26))
 592
 593             (define go
 594               (string-append #$output "/lib/guile/" (effective-version)
 595                              "/site-ccache"))
 596             (define scm
 597               (string-append #$output "/share/guile/site/"
 598                              (effective-version)))
 599
 600             (define optimizations-for-level
 601               ;; Guile 3.0 provides this procedure but Guile 2.2 didn't.
 602               ;; Since this code may be executed by either version, we can't
 603               ;; rely on its availability.
 604               (or (and=> (false-if-exception
 605                           (resolve-interface '(system base optimize)))
 606                          (lambda (iface)
 607                            (module-ref iface 'optimizations-for-level)))
 608                   (const '())))
 609
 610             (define -O1
 611               ;; Optimize for package module compilation speed.
 612               (optimizations-for-level 1))
 613
 614             (let* ((subdir #$directory)
 615                    (source (string-append #$source subdir)))
 616               (compile-files source go (find-files source "\\.scm$")
 617                              #:optimization-options (const -O1))
 618               (mkdir-p (dirname scm))
 619               (symlink (string-append #$source subdir) scm))
 620
 621             scm)))
 622
 623     (gexp->derivation-in-inferior name build core)))
 624
 625 (define* (guile-for-source source #:optional (quirks %quirks))
 626   "Return the Guile package to use when building SOURCE or #f if the default
 627 '%guile-for-build' should be good enough."
 628   (let loop ((quirks quirks))
 629     (match quirks
 630       (()
 631        #f)
 632       (((predicate . guile) rest ...)
 633        (if (predicate source) (guile) (loop rest))))))
 634
 635 (define (call-with-guile guile thunk)
 636   (lambda (store)
 637     (values (parameterize ((%guile-for-build
 638                             (if guile
 639                                 (package-derivation store guile)
 640                                 (%guile-for-build))))
 641               (run-with-store store (thunk)))
 642             store)))
 643
 644 (define-syntax-rule (with-guile guile exp ...)
 645   "Set GUILE as the '%guile-for-build' parameter for the dynamic extent of
 646 EXP, a series of monadic expressions."
 647   (call-with-guile guile (lambda ()
 648                            (mbegin %store-monad exp ...))))
 649
 650 (define (with-trivial-build-handler mvalue)
 651   "Run MVALUE, a monadic value, with a \"trivial\" build handler installed
 652 that unconditionally resumes the continuation."
 653   (lambda (store)
 654     (with-build-handler (lambda (continue . _)
 655                           (continue #t))
 656       (values (run-with-store store mvalue)
 657               store))))
 658
 659 (define* (build-from-source instance
 660                             #:key core verbose? (dependencies '()))
 661   "Return a derivation to build Guix from INSTANCE, using the self-build
 662 script contained therein.  When CORE is true, build package modules under
 663 SOURCE using CORE, an instance of Guix."
 664   (define name
 665     (symbol->string
 666      (channel-name (channel-instance-channel instance))))
 667   (define source
 668     (channel-instance-checkout instance))
 669   (define commit
 670     (channel-instance-commit instance))
 671
 672   ;; Running the self-build script makes it easier to update the build
 673   ;; procedure: the self-build script of the Guix-to-be-installed contains the
 674   ;; right dependencies, build procedure, etc., which the Guix-in-use may not
 675   ;; know.
 676   (define script
 677     (string-append source "/" %self-build-file))
 678
 679   (if (file-exists? script)
 680       (let ((build (save-module-excursion
 681                     (lambda ()
 682                       ;; Disable deprecation warnings; it's OK for SCRIPT to
 683                       ;; use deprecated APIs and the user doesn't have to know
 684                       ;; about it.
 685                       (parameterize ((guix-warning-port
 686                                       (%make-void-port "w")))
 687                         (primitive-load script)))))
 688             (guile (guile-for-source source)))
 689         ;; BUILD must be a monadic procedure of at least one argument: the
 690         ;; source tree.
 691         ;;
 692         ;; Note: BUILD can return #f if it does not support %PULL-VERSION.  In
 693         ;; the future we'll fall back to a previous version of the protocol
 694         ;; when that happens.
 695         (with-guile guile
 696           ;; BUILD is usually quite costly.  Install a "trivial" build handler
 697           ;; so we don't bounce an outer build-accumulator handler that could
 698           ;; cause us to redo half of the BUILD computation several times just
 699           ;; to realize it gives the same result.
 700           (with-trivial-build-handler
 701            (build source
 702                   #:verbose? verbose? #:version commit
 703                   #:channel-metadata (channel-instance->sexp instance)
 704                   #:pull-version %pull-version))))
 705
 706       ;; Build a set of modules that extend Guix using the standard method.
 707       (standard-module-derivation name source core dependencies)))
 708
 709 (define* (build-channel-instance instance
 710                                  #:optional core (dependencies '()))
 711   "Return, as a monadic value, the derivation for INSTANCE, a channel
 712 instance.  DEPENDENCIES is a list of extensions providing Guile modules that
 713 INSTANCE depends on."
 714   (build-from-source instance
 715                      #:core core
 716                      #:dependencies dependencies))
 717
 718 (define (resolve-dependencies instances)
 719   "Return a procedure that, given one of the elements of INSTANCES, returns
 720 list of instances it depends on."
 721   (define channel-instance-name
 722     (compose channel-name channel-instance-channel))
 723
 724   (define table                                   ;map a name to an instance
 725     (fold (lambda (instance table)
 726             (vhash-consq (channel-instance-name instance)
 727                          instance table))
 728           vlist-null
 729           instances))
 730
 731   (define edges
 732     (fold (lambda (instance edges)
 733             (fold (lambda (channel edges)
 734                     (let ((name (channel-name channel)))
 735                       (match (vhash-assq name table)
 736                         ((_ . target)
 737                          (vhash-consq instance target edges)))))
 738                   edges
 739                   (channel-instance-dependencies instance)))
 740           vlist-null
 741           instances))
 742
 743   (lambda (instance)
 744     (vhash-foldq* cons '() instance edges)))
 745
 746 (define (channel-instance-derivations instances)
 747   "Return the list of derivations to build INSTANCES, in the same order as
 748 INSTANCES."
 749   (define core-instance
 750     ;; The 'guix' channel is treated specially: it's an implicit dependency of
 751     ;; all the other channels.
 752     (find (lambda (instance)
 753             (guix-channel? (channel-instance-channel instance)))
 754           instances))
 755
 756   (define edges
 757     (resolve-dependencies instances))
 758
 759   (define (instance->derivation instance)
 760     (mlet %store-monad ((system (current-system)))
 761       (mcached (if (eq? instance core-instance)
 762                    (build-channel-instance instance)
 763                    (mlet %store-monad ((core (instance->derivation core-instance))
 764                                        (deps (mapm %store-monad instance->derivation
 765                                                    (edges instance))))
 766                      (build-channel-instance instance core deps)))
 767                instance
 768                system)))
 769
 770   (unless core-instance
 771     (let ((loc (and=> (any (compose channel-location channel-instance-channel)
 772                            instances)
 773                       source-properties->location)))
 774       (raise (apply make-compound-condition
 775                     (condition
 776                      (&message (message "'guix' channel is lacking")))
 777                     (condition
 778                      (&fix-hint (hint (G_ "Make sure your list of channels
 779 contains one channel named @code{guix} providing the core of Guix."))))
 780                     (if loc
 781                         (list (condition (&error-location (location loc))))
 782                         '())))))
 783
 784   (mapm %store-monad instance->derivation instances))
 785
 786 (define (whole-package-for-legacy name modules)
 787   "Return a full-blown Guix package for MODULES, a derivation that builds Guix
 788 modules in the old ~/.config/guix/latest style."
 789   (define packages
 790     (resolve-interface '(gnu packages guile)))
 791
 792   (define modules+compiled
 793     ;; Since MODULES contains both .scm and .go files at its root, re-bundle
 794     ;; it so that it has share/guile/site and lib/guile, which is what
 795     ;; 'whole-package' expects.
 796     (computed-file (derivation-name modules)
 797                    (with-imported-modules '((guix build utils))
 798                      #~(begin
 799                          (use-modules (guix build utils))
 800
 801                          (define version
 802                            (effective-version))
 803                          (define share
 804                            (string-append #$output "/share/guile/site"))
 805                          (define lib
 806                            (string-append #$output "/lib/guile/" version))
 807
 808                          (mkdir-p share) (mkdir-p lib)
 809                          (symlink #$modules (string-append share "/" version))
 810                          (symlink #$modules (string-append lib "/site-ccache"))))))
 811
 812   (letrec-syntax ((list (syntax-rules (->)
 813                           ((_)
 814                            '())
 815                           ((_ (module -> variable) rest ...)
 816                            (cons (module-ref (resolve-interface
 817                                               '(gnu packages module))
 818                                              'variable)
 819                                  (list rest ...)))
 820                           ((_ variable rest ...)
 821                            (cons (module-ref packages 'variable)
 822                                  (list rest ...))))))
 823     (whole-package name modules+compiled
 824
 825                    ;; In the "old style", %SELF-BUILD-FILE would simply return a
 826                    ;; derivation that builds modules.  We have to infer what the
 827                    ;; dependencies of these modules were.
 828                    (list guile-json-3 guile-git guile-bytestructures
 829                          (ssh -> guile-ssh) (tls -> gnutls))
 830                    #:guile (default-guile))))
 831
 832 (define (old-style-guix? drv)
 833   "Return true if DRV corresponds to a ~/.config/guix/latest style of
 834 derivation."
 835   ;; Here we rely on a gross historical fact: that derivations produced by the
 836   ;; "old style" (before commit 8a0d9bc8a3f153159d9e239a151c0fa98f1e12d8,
 837   ;; dated May 30, 2018) did not depend on "guix-command.drv".
 838   (not (find (lambda (input)
 839                (string=? "guix-command"
 840                          (derivation-name
 841                           (derivation-input-derivation input))))
 842              (derivation-inputs drv))))
 843
 844 (define (channel-instance->sexp instance)
 845   "Return an sexp representation of INSTANCE, a channel instance."
 846   (let* ((commit  (channel-instance-commit instance))
 847          (channel (channel-instance-channel instance))
 848          (intro   (channel-introduction channel)))
 849     `(repository
 850       (version 0)
 851       (url ,(channel-url channel))
 852       (branch ,(channel-branch channel))
 853       (commit ,commit)
 854       (name ,(channel-name channel))
 855       ,@(if intro
 856             `((introduction
 857                (channel-introduction
 858                 (version 0)
 859                 (commit
 860                  ,(channel-introduction-first-signed-commit
 861                    intro))
 862                 (signer
 863                  ,(openpgp-format-fingerprint
 864                    (channel-introduction-first-commit-signer
 865                     intro))))))
 866             '()))))
 867
 868 (define (channel-instances->manifest instances)
 869   "Return a profile manifest with entries for all of INSTANCES, a list of
 870 channel instances."
 871   (define (instance->entry instance drv)
 872     (let ((commit  (channel-instance-commit instance))
 873           (channel (channel-instance-channel instance)))
 874       (manifest-entry
 875         (name (symbol->string (channel-name channel)))
 876         (version (string-take commit 7))
 877         (item (if (guix-channel? channel)
 878                   (if (old-style-guix? drv)
 879                       (whole-package-for-legacy (string-append name "-" version)
 880                                                 drv)
 881                       drv)
 882                   drv))
 883         (properties
 884          `((source ,(channel-instance->sexp instance)))))))
 885
 886   (mlet* %store-monad ((derivations (channel-instance-derivations instances))
 887                        (entries ->  (map instance->entry instances derivations)))
 888     (return (manifest entries))))
 889
 890 (define (package-cache-file manifest)
 891   "Build a package cache file for the instance in MANIFEST.  This is meant to
 892 be used as a profile hook."
 893   (let ((profile (profile (content manifest) (hooks '()))))
 894     (define build
 895       #~(begin
 896           (use-modules (gnu packages))
 897
 898           (if (defined? 'generate-package-cache)
 899               (begin
 900                 ;; Delegate package cache generation to the inferior.
 901                 (format (current-error-port)
 902                         "Generating package cache for '~a'...~%"
 903                         #$profile)
 904                 (generate-package-cache #$output))
 905               (mkdir #$output))))
 906
 907     (gexp->derivation-in-inferior "guix-package-cache" build
 908                                   profile
 909
 910                                   ;; If the Guix in PROFILE is too old and
 911                                   ;; lacks 'guix repl', don't build the cache
 912                                   ;; instead of failing.
 913                                   #:silent-failure? #t
 914
 915                                   #:properties '((type . profile-hook)
 916                                                  (hook . package-cache))
 917                                   #:local-build? #t)))
 918
 919 (define %channel-profile-hooks
 920   ;; The default channel profile hooks.
 921   (cons package-cache-file %default-profile-hooks))
 922
 923 (define (channel-instances->derivation instances)
 924   "Return the derivation of the profile containing INSTANCES, a list of
 925 channel instances."
 926   (mlet %store-monad ((manifest (channel-instances->manifest instances)))
 927     (profile-derivation manifest
 928                         #:hooks %channel-profile-hooks)))
 929
 930 (define latest-channel-instances*
 931   (store-lift latest-channel-instances))
 932
 933 (define* (latest-channel-derivation #:optional (channels %default-channels)
 934                                     #:key
 935                                     (current-channels '())
 936                                     (validate-pull
 937                                      ensure-forward-channel-update))
 938   "Return as a monadic value the derivation that builds the profile for the
 939 latest instances of CHANNELS.  CURRENT-CHANNELS and VALIDATE-PULL are passed
 940 to 'latest-channel-instances'."
 941   (mlet %store-monad ((instances
 942                        (latest-channel-instances* channels
 943                                                   #:current-channels
 944                                                   current-channels
 945                                                   #:validate-pull
 946                                                   validate-pull)))
 947     (channel-instances->derivation instances)))
 948
 949 (define* (sexp->channel sexp #:optional (name 'channel))
 950   "Read SEXP, a provenance sexp as created by 'channel-instance->sexp'; use
 951 NAME as the channel name if SEXP does not specify it.  Return #f if the sexp
 952 does not have the expected structure."
 953   (match sexp
 954     (('repository ('version 0)
 955                   ('url url)
 956                   ('branch branch)
 957                   ('commit commit)
 958                   rest ...)
 959      ;; Historically channel sexps did not include the channel name.  It's OK
 960      ;; for channels created by 'channel-instances->manifest' because the
 961      ;; entry name is the channel name, but it was missing for entries created
 962      ;; by 'manifest-entry-with-provenance'.
 963      (channel (name (match (assq 'name rest)
 964                       (#f name)
 965                       (('name name) name)))
 966               (url url)
 967               (branch branch)
 968               (commit commit)
 969               (introduction
 970                (match (assq 'introduction rest)
 971                  (#f #f)
 972                  (('introduction intro)
 973                   (sexp->channel-introduction intro))))))
 974
 975     (_ #f)))
 976
 977 (define (manifest-entry-channel entry)
 978   "Return the channel ENTRY corresponds to, or #f if that information is
 979 missing or unreadable.  ENTRY must be an entry created by
 980 'channel-instances->manifest', with the 'source' property."
 981   (let ((name (string->symbol (manifest-entry-name entry))))
 982     (match (assq-ref (manifest-entry-properties entry) 'source)
 983       ((sexp)
 984        (sexp->channel sexp name))
 985       (_
 986        ;; No channel information for this manifest entry.
 987        ;; XXX: Pre-0.15.0 Guix did not provide that information,
 988        ;; but there's not much we can do in that case.
 989        #f))))
 990
 991 (define (profile-channels profile)
 992   "Return the list of channels corresponding to entries in PROFILE.  If
 993 PROFILE is not a profile created by 'guix pull', return the empty list."
 994   (filter-map manifest-entry-channel
 995               ;; Show most recently installed packages last.
 996               (reverse
 997                (manifest-entries (profile-manifest profile)))))
 998
 999 (define* (channel->code channel #:key (include-introduction? #t))
1000   "Return code (an sexp) to build CHANNEL.  When INCLUDE-INTRODUCTION? is
1001 true, include its introduction, if any."
1002   (let ((intro (and include-introduction?
1003                     (channel-introduction channel))))
1004     `(channel
1005       (name ',(channel-name channel))
1006       (url ,(channel-url channel))
1007       (commit ,(channel-commit channel))
1008       ,@(if intro
1009             `((introduction (make-channel-introduction
1010                              ,(channel-introduction-first-signed-commit intro)
1011                              (openpgp-fingerprint
1012                               ,(openpgp-format-fingerprint
1013                                 (channel-introduction-first-commit-signer
1014                                  intro))))))
1015             '()))))
1016
1017 \f
1018 ;;;
1019 ;;; News.
1020 ;;;
1021
1022 ;; Channel news.
1023 (define-record-type <channel-news>
1024   (channel-news entries)
1025   channel-news?
1026   (entries channel-news-entries))                 ;list of <channel-news-entry>
1027
1028 ;; News entry, associated with a specific commit of the channel.
1029 (define-record-type <channel-news-entry>
1030   (channel-news-entry commit tag title body)
1031   channel-news-entry?
1032   (commit  channel-news-entry-commit)             ;hex string | #f
1033   (tag     channel-news-entry-tag)                ;#f | string
1034   (title   channel-news-entry-title)              ;list of language tag/string pairs
1035   (body    channel-news-entry-body))              ;list of language tag/string pairs
1036
1037 (define (sexp->channel-news-entry entry)
1038   "Return the <channel-news-entry> record corresponding to ENTRY, an sexp."
1039   (define (pair language message)
1040     (cons (symbol->string language) message))
1041
1042   (match entry
1043     (('entry ((and (or 'commit 'tag) type) commit-or-tag)
1044              ('title ((? symbol? title-tags) (? string? titles)) ...)
1045              ('body ((? symbol? body-tags) (? string? bodies)) ...)
1046              _ ...)
1047      (channel-news-entry (and (eq? type 'commit) commit-or-tag)
1048                          (and (eq? type 'tag) commit-or-tag)
1049                          (map pair title-tags titles)
1050                          (map pair body-tags bodies)))
1051     (_
1052      (raise (condition
1053              (&message (message "invalid channel news entry"))
1054              (&error-location
1055               (location (source-properties->location
1056                          (source-properties entry)))))))))
1057
1058 (define (read-channel-news port)
1059   "Read a channel news feed from PORT and return it as a <channel-news>
1060 record."
1061   (match (false-if-exception (read port))
1062     (('channel-news ('version 0) entries ...)
1063      (channel-news (map sexp->channel-news-entry entries)))
1064     (('channel-news ('version version) _ ...)
1065      ;; This is an unsupported version from the future.  There's nothing wrong
1066      ;; with that (the user may simply need to upgrade the 'guix' channel to
1067      ;; be able to read it), so silently ignore it.
1068      (channel-news '()))
1069     (#f
1070      (raise (condition
1071              (&message (message "syntactically invalid channel news file")))))
1072     (sexp
1073      (raise (condition
1074              (&message (message "invalid channel news file"))
1075              (&error-location
1076               (location (source-properties->location
1077                          (source-properties sexp)))))))))
1078
1079 (define (resolve-channel-news-entry-tag repository entry)
1080   "If ENTRY has its 'commit' field set, return ENTRY.  Otherwise, lookup
1081 ENTRY's 'tag' in REPOSITORY and return ENTRY with its 'commit' field set to
1082 the field its 'tag' refers to.  A 'git-error' exception is raised if the tag
1083 cannot be found."
1084   (if (channel-news-entry-commit entry)
1085       entry
1086       (let* ((tag       (channel-news-entry-tag entry))
1087              (reference (string-append "refs/tags/" tag))
1088              (oid       (reference-name->oid repository reference)))
1089         (channel-news-entry (oid->string oid) tag
1090                             (channel-news-entry-title entry)
1091                             (channel-news-entry-body entry)))))
1092
1093 (define* (channel-news-for-commit channel new #:optional old)
1094   "Return a list of <channel-news-entry> for CHANNEL between commits OLD and
1095 NEW.  When OLD is omitted or is #f, return all the news entries of CHANNEL."
1096   (catch 'git-error
1097     (lambda ()
1098       (let* ((checkout  (update-cached-checkout (channel-url channel)
1099                                                 #:ref `(commit . ,new)))
1100              (metadata  (read-channel-metadata-from-source checkout))
1101              (news-file (channel-metadata-news-file metadata))
1102              (news-file (and news-file
1103                              (string-append checkout "/" news-file))))
1104         (if (and news-file (file-exists? news-file))
1105             (with-repository checkout repository
1106               (let* ((news    (call-with-input-file news-file
1107                                 read-channel-news))
1108                      (entries (map (lambda (entry)
1109                                      (resolve-channel-news-entry-tag repository
1110                                                                      entry))
1111                                    (channel-news-entries news))))
1112                 (if old
1113                     (let* ((new     (commit-lookup repository (string->oid new)))
1114                            (old     (commit-lookup repository (string->oid old)))
1115                            (commits (list->set
1116                                      (map (compose oid->string commit-id)
1117                                           (commit-difference new old)))))
1118                       (filter (lambda (entry)
1119                                 (set-contains? commits
1120                                                (channel-news-entry-commit entry)))
1121                               entries))
1122                     entries)))
1123             '())))
1124     (lambda (key error . rest)
1125       ;; If commit NEW or commit OLD cannot be found, then something must be
1126       ;; wrong (for example, the history of CHANNEL was rewritten and these
1127       ;; commits no longer exist upstream), so quietly return the empty list.
1128       (if (= GIT_ENOTFOUND (git-error-code error))
1129           '()
1130           (apply throw key error rest)))))
1131
1132 ;;; Local Variables:
1133 ;;; eval: (put 'with-guile 'scheme-indent-function 1)
1134 ;;; End: