tests/channels.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
   3 ;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
   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 (test-channels)
  21   #:use-module (guix channels)
  22   #:use-module (guix profiles)
  23   #:use-module ((guix build syscalls) #:select (mkdtemp!))
  24   #:use-module (guix tests)
  25   #:use-module (guix store)
  26   #:use-module ((guix grafts) #:select (%graft?))
  27   #:use-module (guix derivations)
  28   #:use-module (guix sets)
  29   #:use-module (guix gexp)
  30   #:use-module ((guix diagnostics)
  31                 #:select (error-location?
  32                           error-location location-line
  33                           formatted-message?
  34                           formatted-message-string
  35                           formatted-message-arguments))
  36   #:use-module ((guix build utils) #:select (which))
  37   #:use-module (git)
  38   #:use-module (guix git)
  39   #:use-module (guix git-authenticate)
  40   #:use-module (guix openpgp)
  41   #:use-module (guix tests git)
  42   #:use-module (guix tests gnupg)
  43   #:use-module (srfi srfi-1)
  44   #:use-module (srfi srfi-26)
  45   #:use-module (srfi srfi-34)
  46   #:use-module (srfi srfi-35)
  47   #:use-module (srfi srfi-64)
  48   #:use-module (rnrs bytevectors)
  49   #:use-module (rnrs io ports)
  50   #:use-module (ice-9 control)
  51   #:use-module (ice-9 match))
  52
  53 (define (gpg+git-available?)
  54   (and (which (git-command))
  55        (which (gpg-command)) (which (gpgconf-command))))
  56
  57 (define commit-id-string
  58   (compose oid->string commit-id))
  59
  60 \f
  61 (test-begin "channels")
  62
  63 (define* (make-instance #:key
  64                         (name 'fake)
  65                         (commit "cafebabe")
  66                         (spec #f))
  67   (define instance-dir (mkdtemp! "/tmp/checkout.XXXXXX"))
  68   (when spec
  69     (call-with-output-file (string-append instance-dir "/.guix-channel")
  70       (lambda (port) (write spec port))))
  71   (checkout->channel-instance instance-dir
  72                               #:commit commit
  73                               #:name name))
  74
  75 (define instance--boring (make-instance))
  76 (define instance--unsupported-version
  77   (make-instance #:spec
  78                  '(channel (version 42) (dependencies whatever))))
  79 (define instance--no-deps
  80   (make-instance #:spec
  81                  '(channel (version 0))))
  82 (define instance--sub-directory
  83   (make-instance #:spec
  84                  '(channel (version 0) (directory "modules"))))
  85 (define instance--simple
  86   (make-instance #:spec
  87                  '(channel
  88                    (version 0)
  89                    (dependencies
  90                     (channel
  91                      (name test-channel)
  92                      (url "https://example.com/test-channel"))))))
  93 (define instance--with-dupes
  94   (make-instance #:spec
  95                  '(channel
  96                    (version 0)
  97                    (dependencies
  98                     (channel
  99                      (name test-channel)
 100                      (url "https://example.com/test-channel"))
 101                     (channel
 102                      (name test-channel)
 103                      (url "https://example.com/test-channel")
 104                      (commit "abc1234"))
 105                     (channel
 106                      (name test-channel)
 107                      (url "https://example.com/test-channel-elsewhere"))))))
 108
 109 (define channel-instance-metadata
 110   (@@ (guix channels) channel-instance-metadata))
 111 (define channel-metadata-directory
 112   (@@ (guix channels) channel-metadata-directory))
 113 (define channel-metadata-dependencies
 114   (@@ (guix channels) channel-metadata-dependencies))
 115
 116 \f
 117 (test-equal "channel-instance-metadata returns default if .guix-channel does not exist"
 118   '("/" ())
 119   (let ((metadata (channel-instance-metadata instance--boring)))
 120     (list (channel-metadata-directory metadata)
 121           (channel-metadata-dependencies metadata))))
 122
 123 (test-equal "channel-instance-metadata and default dependencies"
 124   '()
 125   (channel-metadata-dependencies (channel-instance-metadata instance--no-deps)))
 126
 127 (test-equal "channel-instance-metadata and directory"
 128   "/modules"
 129   (channel-metadata-directory
 130    (channel-instance-metadata instance--sub-directory)))
 131
 132 (test-equal "channel-instance-metadata rejects unsupported version"
 133   1                              ;line number in the generated '.guix-channel'
 134   (guard (c ((and (message-condition? c) (error-location? c))
 135              (location-line (error-location c))))
 136     (channel-instance-metadata instance--unsupported-version)))
 137
 138 (test-assert "channel-instance-metadata returns <channel-metadata>"
 139   (every (@@ (guix channels) channel-metadata?)
 140          (map channel-instance-metadata
 141               (list instance--no-deps
 142                     instance--simple
 143                     instance--with-dupes))))
 144
 145 (test-assert "channel-instance-metadata dependencies are channels"
 146   (let ((deps ((@@ (guix channels) channel-metadata-dependencies)
 147                (channel-instance-metadata instance--simple))))
 148     (match deps
 149       (((? channel? dep)) #t)
 150       (_ #f))))
 151
 152 (test-assert "latest-channel-instances includes channel dependencies"
 153   (let* ((channel (channel
 154                    (name 'test)
 155                    (url "test")))
 156          (test-dir (channel-instance-checkout instance--simple)))
 157     (mock ((guix git) update-cached-checkout
 158            (lambda* (url #:key ref starting-commit)
 159              (match url
 160                ("test" (values test-dir "caf3cabba9e" #f))
 161                (_      (values (channel-instance-checkout instance--no-deps)
 162                                "abcde1234" #f)))))
 163           (with-store store
 164             (let ((instances (latest-channel-instances store (list channel))))
 165               (and (eq? 2 (length instances))
 166                    (lset= eq?
 167                           '(test test-channel)
 168                           (map (compose channel-name channel-instance-channel)
 169                                instances))))))))
 170
 171 (test-assert "latest-channel-instances excludes duplicate channel dependencies"
 172   (let* ((channel (channel
 173                    (name 'test)
 174                    (url "test")))
 175          (test-dir (channel-instance-checkout instance--with-dupes)))
 176     (mock ((guix git) update-cached-checkout
 177            (lambda* (url #:key ref starting-commit)
 178              (match url
 179                ("test" (values test-dir "caf3cabba9e" #f))
 180                (_      (values (channel-instance-checkout instance--no-deps)
 181                                "abcde1234" #f)))))
 182           (with-store store
 183             (let ((instances (latest-channel-instances store (list channel))))
 184               (and (= 2 (length instances))
 185                    (lset= eq?
 186                           '(test test-channel)
 187                           (map (compose channel-name channel-instance-channel)
 188                                instances))
 189                    ;; only the most specific channel dependency should remain,
 190                    ;; i.e. the one with a specified commit.
 191                    (find (lambda (instance)
 192                            (and (eq? (channel-name
 193                                       (channel-instance-channel instance))
 194                                      'test-channel)
 195                                 (string=? (channel-commit
 196                                            (channel-instance-channel instance))
 197                                           "abc1234")))
 198                          instances)))))))
 199
 200 (unless (which (git-command)) (test-skip 1))
 201 (test-equal "latest-channel-instances #:validate-pull"
 202   'descendant
 203
 204   ;; Make sure the #:validate-pull procedure receives the right values.
 205   (let/ec return
 206     (with-temporary-git-repository directory
 207         '((add "a.txt" "A")
 208           (commit "first commit")
 209           (add "b.scm" "#t")
 210           (commit "second commit"))
 211       (with-repository directory repository
 212         (let* ((commit1 (find-commit repository "first"))
 213                (commit2 (find-commit repository "second"))
 214                (spec    (channel (url (string-append "file://" directory))
 215                                  (name 'foo)))
 216                (new     (channel (inherit spec)
 217                                  (commit (oid->string (commit-id commit2)))))
 218                (old     (channel (inherit spec)
 219                                  (commit (oid->string (commit-id commit1))))))
 220           (define (validate-pull channel current commit relation)
 221             (return (and (eq? channel old)
 222                          (string=? (oid->string (commit-id commit2))
 223                                    current)
 224                          (string=? (oid->string (commit-id commit1))
 225                                    commit)
 226                          relation)))
 227
 228           (with-store store
 229             ;; Attempt a downgrade from NEW to OLD.
 230             (latest-channel-instances store (list old)
 231                                       #:current-channels (list new)
 232                                       #:validate-pull validate-pull)))))))
 233
 234 (test-assert "channel-instances->manifest"
 235   ;; Compute the manifest for a graph of instances and make sure we get a
 236   ;; derivation graph that mirrors the instance graph.  This test also ensures
 237   ;; we don't try to access Git repositores at all at this stage.
 238   (let* ((spec      (lambda deps
 239                       `(channel (version 0)
 240                                 (dependencies
 241                                  ,@(map (lambda (dep)
 242                                           `(channel
 243                                             (name ,dep)
 244                                             (url "http://example.org")))
 245                                         deps)))))
 246          (guix      (make-instance #:name 'guix))
 247          (instance0 (make-instance #:name 'a))
 248          (instance1 (make-instance #:name 'b #:spec (spec 'a)))
 249          (instance2 (make-instance #:name 'c #:spec (spec 'b)))
 250          (instance3 (make-instance #:name 'd #:spec (spec 'c 'a))))
 251     (%graft? #f)                                    ;don't try to build stuff
 252
 253     ;; Create 'build-self.scm' so that GUIX is recognized as the 'guix' channel.
 254     (let ((source (channel-instance-checkout guix)))
 255       (mkdir (string-append source "/build-aux"))
 256       (call-with-output-file (string-append source
 257                                             "/build-aux/build-self.scm")
 258         (lambda (port)
 259           (write '(begin
 260                     (use-modules (guix) (gnu packages bootstrap))
 261
 262                     (lambda _
 263                       (package->derivation %bootstrap-guile)))
 264                  port))))
 265
 266     (with-store store
 267       (let ()
 268         (define manifest
 269           (run-with-store store
 270             (channel-instances->manifest (list guix
 271                                                instance0 instance1
 272                                                instance2 instance3))))
 273
 274         (define entries
 275           (manifest-entries manifest))
 276
 277         (define (depends? drv in out)
 278           ;; Return true if DRV depends (directly or indirectly) on all of IN
 279           ;; and none of OUT.
 280           (let ((set (list->set
 281                       (requisites store
 282                                   (list (derivation-file-name drv)))))
 283                 (in  (map derivation-file-name in))
 284                 (out (map derivation-file-name out)))
 285             (and (every (cut set-contains? set <>) in)
 286                  (not (any (cut set-contains? set <>) out)))))
 287
 288         (define (lookup name)
 289           (run-with-store store
 290             (lower-object
 291              (manifest-entry-item
 292               (manifest-lookup manifest
 293                                (manifest-pattern (name name)))))))
 294
 295         (let ((drv-guix (lookup "guix"))
 296               (drv0     (lookup "a"))
 297               (drv1     (lookup "b"))
 298               (drv2     (lookup "c"))
 299               (drv3     (lookup "d")))
 300           (and (depends? drv-guix '() (list drv0 drv1 drv2 drv3))
 301                (depends? drv0
 302                          (list) (list drv1 drv2 drv3))
 303                (depends? drv1
 304                          (list drv0) (list drv2 drv3))
 305                (depends? drv2
 306                          (list drv1) (list drv3))
 307                (depends? drv3
 308                          (list drv2 drv0) (list))))))))
 309
 310 (unless (which (git-command)) (test-skip 1))
 311 (test-equal "channel-news, no news"
 312   '()
 313   (with-temporary-git-repository directory
 314       '((add "a.txt" "A")
 315         (commit "the commit"))
 316     (with-repository directory repository
 317       (let ((channel (channel (url (string-append "file://" directory))
 318                               (name 'foo)))
 319             (latest  (reference-name->oid repository "HEAD")))
 320         (channel-news-for-commit channel (oid->string latest))))))
 321
 322 (unless (which (git-command)) (test-skip 1))
 323 (test-assert "channel-news, one entry"
 324   (with-temporary-git-repository directory
 325       `((add ".guix-channel"
 326              ,(object->string
 327                '(channel (version 0)
 328                          (news-file "news.scm"))))
 329         (commit "first commit")
 330         (add "src/a.txt" "A")
 331         (commit "second commit")
 332         (tag "tag-for-first-news-entry")
 333         (add "news.scm"
 334              ,(lambda (repository)
 335                 (let ((previous
 336                        (reference-name->oid repository "HEAD")))
 337                   (object->string
 338                    `(channel-news
 339                      (version 0)
 340                      (entry (commit ,(oid->string previous))
 341                             (title (en "New file!")
 342                                    (eo "Nova dosiero!"))
 343                             (body (en "Yeah, a.txt."))))))))
 344         (commit "third commit")
 345         (add "src/b.txt" "B")
 346         (commit "fourth commit")
 347         (add "news.scm"
 348              ,(lambda (repository)
 349                 (let ((second
 350                        (commit-id
 351                         (find-commit repository "second commit")))
 352                       (previous
 353                        (reference-name->oid repository "HEAD")))
 354                   (object->string
 355                    `(channel-news
 356                      (version 0)
 357                      (entry (commit ,(oid->string previous))
 358                             (title (en "Another file!"))
 359                             (body (en "Yeah, b.txt.")))
 360                      (entry (tag "tag-for-first-news-entry")
 361                             (title (en "Old news.")
 362                                    (eo "Malnovaĵoj."))
 363                             (body (en "For a.txt"))))))))
 364         (commit "fifth commit"))
 365     (with-repository directory repository
 366       (define (find-commit* message)
 367         (oid->string (commit-id (find-commit repository message))))
 368
 369       (let ((channel (channel (url (string-append "file://" directory))
 370                               (name 'foo)))
 371             (commit1 (find-commit* "first commit"))
 372             (commit2 (find-commit* "second commit"))
 373             (commit3 (find-commit* "third commit"))
 374             (commit4 (find-commit* "fourth commit"))
 375             (commit5 (find-commit* "fifth commit")))
 376         ;; First try fetching all the news up to a given commit.
 377         (and (null? (channel-news-for-commit channel commit2))
 378              (lset= string=?
 379                     (map channel-news-entry-commit
 380                          (channel-news-for-commit channel commit5))
 381                     (list commit2 commit4))
 382              (lset= equal?
 383                     (map channel-news-entry-title
 384                          (channel-news-for-commit channel commit5))
 385                     '((("en" . "Another file!"))
 386                       (("en" . "Old news.") ("eo" . "Malnovaĵoj."))))
 387              (lset= string=?
 388                     (map channel-news-entry-commit
 389                          (channel-news-for-commit channel commit3))
 390                     (list commit2))
 391
 392              ;; Now fetch news entries that apply to a commit range.
 393              (lset= string=?
 394                     (map channel-news-entry-commit
 395                          (channel-news-for-commit channel commit3 commit1))
 396                     (list commit2))
 397              (lset= string=?
 398                     (map channel-news-entry-commit
 399                          (channel-news-for-commit channel commit5 commit3))
 400                     (list commit4))
 401              (lset= string=?
 402                     (map channel-news-entry-commit
 403                          (channel-news-for-commit channel commit5 commit1))
 404                     (list commit4 commit2))
 405              (lset= equal?
 406                     (map channel-news-entry-tag
 407                          (channel-news-for-commit channel commit5 commit1))
 408                     '(#f "tag-for-first-news-entry")))))))
 409
 410 (unless (which (git-command)) (test-skip 1))
 411 (test-assert "latest-channel-instances, missing introduction for 'guix'"
 412   (with-temporary-git-repository directory
 413       '((add "a.txt" "A")
 414         (commit "first commit")
 415         (add "b.scm" "#t")
 416         (commit "second commit"))
 417     (with-repository directory repository
 418       (let* ((commit1 (find-commit repository "first"))
 419              (commit2 (find-commit repository "second"))
 420              (channel (channel (url (string-append "file://" directory))
 421                                (name 'guix))))
 422
 423         (guard (c ((formatted-message? c)
 424                    (->bool (string-contains (formatted-message-string c)
 425                                             "introduction"))))
 426           (with-store store
 427             ;; Attempt a downgrade from NEW to OLD.
 428             (latest-channel-instances store (list channel))
 429             #f))))))
 430
 431 (unless (gpg+git-available?) (test-skip 1))
 432 (test-equal "authenticate-channel, wrong first commit signer"
 433   #t
 434   (with-fresh-gnupg-setup (list %ed25519-public-key-file
 435                                 %ed25519-secret-key-file
 436                                 %ed25519bis-public-key-file
 437                                 %ed25519bis-secret-key-file)
 438     (with-temporary-git-repository directory
 439         `((add ".guix-channel"
 440                ,(object->string
 441                  '(channel (version 0)
 442                            (keyring-reference "master"))))
 443           (add ".guix-authorizations"
 444                ,(object->string
 445                  `(authorizations (version 0)
 446                                   ((,(key-fingerprint
 447                                       %ed25519-public-key-file)
 448                                     (name "Charlie"))))))
 449           (add "signer.key" ,(call-with-input-file %ed25519-public-key-file
 450                                get-string-all))
 451           (commit "first commit"
 452                   (signer ,(key-fingerprint %ed25519-public-key-file)))
 453           (add "random" ,(random-text))
 454           (commit "second commit"
 455                   (signer ,(key-fingerprint %ed25519-public-key-file))))
 456       (with-repository directory repository
 457         (let* ((commit1 (find-commit repository "first"))
 458                (commit2 (find-commit repository "second"))
 459                (intro   (make-channel-introduction
 460                          (commit-id-string commit1)
 461                          (openpgp-public-key-fingerprint
 462                           (read-openpgp-packet
 463                            %ed25519bis-public-key-file)))) ;different key
 464                (channel (channel (name 'example)
 465                                  (url (string-append "file://" directory))
 466                                  (introduction intro))))
 467           (guard (c ((formatted-message? c)
 468                      (and (string-contains (formatted-message-string c)
 469                                            "initial commit")
 470                           (equal? (formatted-message-arguments c)
 471                                   (list
 472                                    (oid->string (commit-id commit1))
 473                                    (key-fingerprint %ed25519-public-key-file)
 474                                    (key-fingerprint
 475                                     %ed25519bis-public-key-file))))))
 476             (authenticate-channel channel directory
 477                                   (commit-id-string commit2)
 478                                   #:keyring-reference-prefix "")
 479             'failed))))))
 480
 481 (unless (gpg+git-available?) (test-skip 1))
 482 (test-equal "authenticate-channel, .guix-authorizations"
 483   #t
 484   (with-fresh-gnupg-setup (list %ed25519-public-key-file
 485                                 %ed25519-secret-key-file
 486                                 %ed25519bis-public-key-file
 487                                 %ed25519bis-secret-key-file)
 488     (with-temporary-git-repository directory
 489         `((add ".guix-channel"
 490                ,(object->string
 491                  '(channel (version 0)
 492                            (keyring-reference "channel-keyring"))))
 493           (add ".guix-authorizations"
 494                ,(object->string
 495                  `(authorizations (version 0)
 496                                   ((,(key-fingerprint
 497                                       %ed25519-public-key-file)
 498                                     (name "Charlie"))))))
 499           (commit "zeroth commit")
 500           (add "a.txt" "A")
 501           (commit "first commit"
 502                   (signer ,(key-fingerprint %ed25519-public-key-file)))
 503           (add "b.txt" "B")
 504           (commit "second commit"
 505                   (signer ,(key-fingerprint %ed25519-public-key-file)))
 506           (add "c.txt" "C")
 507           (commit "third commit"
 508                   (signer ,(key-fingerprint %ed25519bis-public-key-file)))
 509           (branch "channel-keyring")
 510           (checkout "channel-keyring")
 511           (add "signer.key" ,(call-with-input-file %ed25519-public-key-file
 512                                get-string-all))
 513           (add "other.key" ,(call-with-input-file %ed25519bis-public-key-file
 514                               get-string-all))
 515           (commit "keyring commit")
 516           (checkout "master"))
 517       (with-repository directory repository
 518         (let* ((commit1 (find-commit repository "first"))
 519                (commit2 (find-commit repository "second"))
 520                (commit3 (find-commit repository "third"))
 521                (intro   (make-channel-introduction
 522                          (commit-id-string commit1)
 523                          (openpgp-public-key-fingerprint
 524                           (read-openpgp-packet
 525                            %ed25519-public-key-file))))
 526                (channel (channel (name 'example)
 527                                  (url (string-append "file://" directory))
 528                                  (introduction intro))))
 529           ;; COMMIT1 and COMMIT2 are fine.
 530           (and (authenticate-channel channel directory
 531                                      (commit-id-string commit2)
 532                                      #:keyring-reference-prefix "")
 533
 534                ;; COMMIT3 is signed by an unauthorized key according to its
 535                ;; parent's '.guix-authorizations' file.
 536                (guard (c ((unauthorized-commit-error? c)
 537                           (and (oid=? (git-authentication-error-commit c)
 538                                       (commit-id commit3))
 539                                (bytevector=?
 540                                 (openpgp-public-key-fingerprint
 541                                  (unauthorized-commit-error-signing-key c))
 542                                 (openpgp-public-key-fingerprint
 543                                  (read-openpgp-packet
 544                                   %ed25519bis-public-key-file))))))
 545                  (authenticate-channel channel directory
 546                                        (commit-id-string commit3)
 547                                        #:keyring-reference-prefix "")
 548                  'failed)))))))
 549
 550 (unless (gpg+git-available?) (test-skip 1))
 551 (test-equal "latest-channel-instances, authenticate dependency"
 552   #t
 553   ;; Make sure that a channel dependency that has an introduction is
 554   ;; authenticated.  This test checks that an authentication error is raised
 555   ;; as it should when authenticating the dependency.
 556   (with-fresh-gnupg-setup (list %ed25519-public-key-file
 557                                 %ed25519-secret-key-file)
 558     (with-temporary-git-repository dependency-directory
 559         `((add ".guix-channel"
 560                ,(object->string
 561                  '(channel (version 0)
 562                            (keyring-reference "master"))))
 563           (add ".guix-authorizations"
 564                ,(object->string
 565                  `(authorizations (version 0) ())))
 566           (add "signer.key" ,(call-with-input-file %ed25519-public-key-file
 567                                get-string-all))
 568           (commit "zeroth commit"
 569                   (signer ,(key-fingerprint %ed25519-public-key-file)))
 570           (add "foo.txt" "evil")
 571           (commit "unsigned commit"))
 572       (with-repository dependency-directory dependency
 573         (let* ((commit0 (find-commit dependency "zeroth"))
 574                (commit1 (find-commit dependency "unsigned"))
 575                (intro   `(channel-introduction
 576                           (version 0)
 577                           (commit ,(commit-id-string commit0))
 578                           (signer ,(openpgp-format-fingerprint
 579                                     (openpgp-public-key-fingerprint
 580                                      (read-openpgp-packet
 581                                       %ed25519-public-key-file)))))))
 582           (with-temporary-git-repository directory
 583               `((add ".guix-channel"
 584                      ,(object->string
 585                        `(channel (version 0)
 586                                  (dependencies
 587                                   (channel
 588                                    (name test-channel)
 589                                    (url ,dependency-directory)
 590                                    (introduction ,intro))))))
 591                 (commit "single commit"))
 592             (let ((channel (channel (name 'test) (url directory))))
 593               (guard (c ((unsigned-commit-error? c)
 594                          (oid=? (git-authentication-error-commit c)
 595                                 (commit-id commit1))))
 596                 (with-store store
 597                   (latest-channel-instances store (list channel))
 598                   'failed)))))))))
 599
 600 (test-end "channels")