tests/channels.scm

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