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