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 tests git)
  35   #:use-module (srfi srfi-1)
  36   #:use-module (srfi srfi-26)
  37   #:use-module (srfi srfi-34)
  38   #:use-module (srfi srfi-35)
  39   #:use-module (srfi srfi-64)
  40   #:use-module (ice-9 control)
  41   #:use-module (ice-9 match))
  42
  43 (test-begin "channels")
  44
  45 (define* (make-instance #:key
  46                         (name 'fake)
  47                         (commit "cafebabe")
  48                         (spec #f))
  49   (define instance-dir (mkdtemp! "/tmp/checkout.XXXXXX"))
  50   (when spec
  51     (call-with-output-file (string-append instance-dir "/.guix-channel")
  52       (lambda (port) (write spec port))))
  53   (checkout->channel-instance instance-dir
  54                               #:commit commit
  55                               #:name name))
  56
  57 (define instance--boring (make-instance))
  58 (define instance--unsupported-version
  59   (make-instance #:spec
  60                  '(channel (version 42) (dependencies whatever))))
  61 (define instance--no-deps
  62   (make-instance #:spec
  63                  '(channel (version 0))))
  64 (define instance--sub-directory
  65   (make-instance #:spec
  66                  '(channel (version 0) (directory "modules"))))
  67 (define instance--simple
  68   (make-instance #:spec
  69                  '(channel
  70                    (version 0)
  71                    (dependencies
  72                     (channel
  73                      (name test-channel)
  74                      (url "https://example.com/test-channel"))))))
  75 (define instance--with-dupes
  76   (make-instance #:spec
  77                  '(channel
  78                    (version 0)
  79                    (dependencies
  80                     (channel
  81                      (name test-channel)
  82                      (url "https://example.com/test-channel"))
  83                     (channel
  84                      (name test-channel)
  85                      (url "https://example.com/test-channel")
  86                      (commit "abc1234"))
  87                     (channel
  88                      (name test-channel)
  89                      (url "https://example.com/test-channel-elsewhere"))))))
  90
  91 (define channel-instance-metadata
  92   (@@ (guix channels) channel-instance-metadata))
  93 (define channel-metadata-directory
  94   (@@ (guix channels) channel-metadata-directory))
  95 (define channel-metadata-dependencies
  96   (@@ (guix channels) channel-metadata-dependencies))
  97
  98 \f
  99 (test-equal "channel-instance-metadata returns default if .guix-channel does not exist"
 100   '("/" ())
 101   (let ((metadata (channel-instance-metadata instance--boring)))
 102     (list (channel-metadata-directory metadata)
 103           (channel-metadata-dependencies metadata))))
 104
 105 (test-equal "channel-instance-metadata and default dependencies"
 106   '()
 107   (channel-metadata-dependencies (channel-instance-metadata instance--no-deps)))
 108
 109 (test-equal "channel-instance-metadata and directory"
 110   "/modules"
 111   (channel-metadata-directory
 112    (channel-instance-metadata instance--sub-directory)))
 113
 114 (test-equal "channel-instance-metadata rejects unsupported version"
 115   1                              ;line number in the generated '.guix-channel'
 116   (guard (c ((and (message-condition? c) (error-location? c))
 117              (location-line (error-location c))))
 118     (channel-instance-metadata instance--unsupported-version)))
 119
 120 (test-assert "channel-instance-metadata returns <channel-metadata>"
 121   (every (@@ (guix channels) channel-metadata?)
 122          (map channel-instance-metadata
 123               (list instance--no-deps
 124                     instance--simple
 125                     instance--with-dupes))))
 126
 127 (test-assert "channel-instance-metadata dependencies are channels"
 128   (let ((deps ((@@ (guix channels) channel-metadata-dependencies)
 129                (channel-instance-metadata instance--simple))))
 130     (match deps
 131       (((? channel? dep)) #t)
 132       (_ #f))))
 133
 134 (test-assert "latest-channel-instances includes channel dependencies"
 135   (let* ((channel (channel
 136                    (name 'test)
 137                    (url "test")))
 138          (test-dir (channel-instance-checkout instance--simple)))
 139     (mock ((guix git) update-cached-checkout
 140            (lambda* (url #:key ref starting-commit)
 141              (match url
 142                ("test" (values test-dir "caf3cabba9e" #f))
 143                (_      (values (channel-instance-checkout instance--no-deps)
 144                                "abcde1234" #f)))))
 145           (with-store store
 146             (let ((instances (latest-channel-instances store (list channel))))
 147               (and (eq? 2 (length instances))
 148                    (lset= eq?
 149                           '(test test-channel)
 150                           (map (compose channel-name channel-instance-channel)
 151                                instances))))))))
 152
 153 (test-assert "latest-channel-instances excludes duplicate channel dependencies"
 154   (let* ((channel (channel
 155                    (name 'test)
 156                    (url "test")))
 157          (test-dir (channel-instance-checkout instance--with-dupes)))
 158     (mock ((guix git) update-cached-checkout
 159            (lambda* (url #:key ref starting-commit)
 160              (match url
 161                ("test" (values test-dir "caf3cabba9e" #f))
 162                (_      (values (channel-instance-checkout instance--no-deps)
 163                                "abcde1234" #f)))))
 164           (with-store store
 165             (let ((instances (latest-channel-instances store (list channel))))
 166               (and (= 2 (length instances))
 167                    (lset= eq?
 168                           '(test test-channel)
 169                           (map (compose channel-name channel-instance-channel)
 170                                instances))
 171                    ;; only the most specific channel dependency should remain,
 172                    ;; i.e. the one with a specified commit.
 173                    (find (lambda (instance)
 174                            (and (eq? (channel-name
 175                                       (channel-instance-channel instance))
 176                                      'test-channel)
 177                                 (string=? (channel-commit
 178                                            (channel-instance-channel instance))
 179                                           "abc1234")))
 180                          instances)))))))
 181
 182 (unless (which (git-command)) (test-skip 1))
 183 (test-equal "latest-channel-instances #:validate-pull"
 184   'descendant
 185
 186   ;; Make sure the #:validate-pull procedure receives the right values.
 187   (let/ec return
 188     (with-temporary-git-repository directory
 189         '((add "a.txt" "A")
 190           (commit "first commit")
 191           (add "b.scm" "#t")
 192           (commit "second commit"))
 193       (with-repository directory repository
 194         (let* ((commit1 (find-commit repository "first"))
 195                (commit2 (find-commit repository "second"))
 196                (spec    (channel (url (string-append "file://" directory))
 197                                  (name 'foo)))
 198                (new     (channel (inherit spec)
 199                                  (commit (oid->string (commit-id commit2)))))
 200                (old     (channel (inherit spec)
 201                                  (commit (oid->string (commit-id commit1))))))
 202           (define (validate-pull channel current instance relation)
 203             (return (and (eq? channel old)
 204                          (string=? (oid->string (commit-id commit2))
 205                                    current)
 206                          (string=? (oid->string (commit-id commit1))
 207                                    (channel-instance-commit instance))
 208                          relation)))
 209
 210           (with-store store
 211             ;; Attempt a downgrade from NEW to OLD.
 212             (latest-channel-instances store (list old)
 213                                       #:current-channels (list new)
 214                                       #:validate-pull validate-pull)))))))
 215
 216 (test-assert "channel-instances->manifest"
 217   ;; Compute the manifest for a graph of instances and make sure we get a
 218   ;; derivation graph that mirrors the instance graph.  This test also ensures
 219   ;; we don't try to access Git repositores at all at this stage.
 220   (let* ((spec      (lambda deps
 221                       `(channel (version 0)
 222                                 (dependencies
 223                                  ,@(map (lambda (dep)
 224                                           `(channel
 225                                             (name ,dep)
 226                                             (url "http://example.org")))
 227                                         deps)))))
 228          (guix      (make-instance #:name 'guix))
 229          (instance0 (make-instance #:name 'a))
 230          (instance1 (make-instance #:name 'b #:spec (spec 'a)))
 231          (instance2 (make-instance #:name 'c #:spec (spec 'b)))
 232          (instance3 (make-instance #:name 'd #:spec (spec 'c 'a))))
 233     (%graft? #f)                                    ;don't try to build stuff
 234
 235     ;; Create 'build-self.scm' so that GUIX is recognized as the 'guix' channel.
 236     (let ((source (channel-instance-checkout guix)))
 237       (mkdir (string-append source "/build-aux"))
 238       (call-with-output-file (string-append source
 239                                             "/build-aux/build-self.scm")
 240         (lambda (port)
 241           (write '(begin
 242                     (use-modules (guix) (gnu packages bootstrap))
 243
 244                     (lambda _
 245                       (package->derivation %bootstrap-guile)))
 246                  port))))
 247
 248     (with-store store
 249       (let ()
 250         (define manifest
 251           (run-with-store store
 252             (channel-instances->manifest (list guix
 253                                                instance0 instance1
 254                                                instance2 instance3))))
 255
 256         (define entries
 257           (manifest-entries manifest))
 258
 259         (define (depends? drv in out)
 260           ;; Return true if DRV depends (directly or indirectly) on all of IN
 261           ;; and none of OUT.
 262           (let ((set (list->set
 263                       (requisites store
 264                                   (list (derivation-file-name drv)))))
 265                 (in  (map derivation-file-name in))
 266                 (out (map derivation-file-name out)))
 267             (and (every (cut set-contains? set <>) in)
 268                  (not (any (cut set-contains? set <>) out)))))
 269
 270         (define (lookup name)
 271           (run-with-store store
 272             (lower-object
 273              (manifest-entry-item
 274               (manifest-lookup manifest
 275                                (manifest-pattern (name name)))))))
 276
 277         (let ((drv-guix (lookup "guix"))
 278               (drv0     (lookup "a"))
 279               (drv1     (lookup "b"))
 280               (drv2     (lookup "c"))
 281               (drv3     (lookup "d")))
 282           (and (depends? drv-guix '() (list drv0 drv1 drv2 drv3))
 283                (depends? drv0
 284                          (list) (list drv1 drv2 drv3))
 285                (depends? drv1
 286                          (list drv0) (list drv2 drv3))
 287                (depends? drv2
 288                          (list drv1) (list drv3))
 289                (depends? drv3
 290                          (list drv2 drv0) (list))))))))
 291
 292 (unless (which (git-command)) (test-skip 1))
 293 (test-equal "channel-news, no news"
 294   '()
 295   (with-temporary-git-repository directory
 296       '((add "a.txt" "A")
 297         (commit "the commit"))
 298     (with-repository directory repository
 299       (let ((channel (channel (url (string-append "file://" directory))
 300                               (name 'foo)))
 301             (latest  (reference-name->oid repository "HEAD")))
 302         (channel-news-for-commit channel (oid->string latest))))))
 303
 304 (unless (which (git-command)) (test-skip 1))
 305 (test-assert "channel-news, one entry"
 306   (with-temporary-git-repository directory
 307       `((add ".guix-channel"
 308              ,(object->string
 309                '(channel (version 0)
 310                          (news-file "news.scm"))))
 311         (commit "first commit")
 312         (add "src/a.txt" "A")
 313         (commit "second commit")
 314         (tag "tag-for-first-news-entry")
 315         (add "news.scm"
 316              ,(lambda (repository)
 317                 (let ((previous
 318                        (reference-name->oid repository "HEAD")))
 319                   (object->string
 320                    `(channel-news
 321                      (version 0)
 322                      (entry (commit ,(oid->string previous))
 323                             (title (en "New file!")
 324                                    (eo "Nova dosiero!"))
 325                             (body (en "Yeah, a.txt."))))))))
 326         (commit "third commit")
 327         (add "src/b.txt" "B")
 328         (commit "fourth commit")
 329         (add "news.scm"
 330              ,(lambda (repository)
 331                 (let ((second
 332                        (commit-id
 333                         (find-commit repository "second commit")))
 334                       (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 "Another file!"))
 341                             (body (en "Yeah, b.txt.")))
 342                      (entry (tag "tag-for-first-news-entry")
 343                             (title (en "Old news.")
 344                                    (eo "Malnovaĵoj."))
 345                             (body (en "For a.txt"))))))))
 346         (commit "fifth commit"))
 347     (with-repository directory repository
 348       (define (find-commit* message)
 349         (oid->string (commit-id (find-commit repository message))))
 350
 351       (let ((channel (channel (url (string-append "file://" directory))
 352                               (name 'foo)))
 353             (commit1 (find-commit* "first commit"))
 354             (commit2 (find-commit* "second commit"))
 355             (commit3 (find-commit* "third commit"))
 356             (commit4 (find-commit* "fourth commit"))
 357             (commit5 (find-commit* "fifth commit")))
 358         ;; First try fetching all the news up to a given commit.
 359         (and (null? (channel-news-for-commit channel commit2))
 360              (lset= string=?
 361                     (map channel-news-entry-commit
 362                          (channel-news-for-commit channel commit5))
 363                     (list commit2 commit4))
 364              (lset= equal?
 365                     (map channel-news-entry-title
 366                          (channel-news-for-commit channel commit5))
 367                     '((("en" . "Another file!"))
 368                       (("en" . "Old news.") ("eo" . "Malnovaĵoj."))))
 369              (lset= string=?
 370                     (map channel-news-entry-commit
 371                          (channel-news-for-commit channel commit3))
 372                     (list commit2))
 373
 374              ;; Now fetch news entries that apply to a commit range.
 375              (lset= string=?
 376                     (map channel-news-entry-commit
 377                          (channel-news-for-commit channel commit3 commit1))
 378                     (list commit2))
 379              (lset= string=?
 380                     (map channel-news-entry-commit
 381                          (channel-news-for-commit channel commit5 commit3))
 382                     (list commit4))
 383              (lset= string=?
 384                     (map channel-news-entry-commit
 385                          (channel-news-for-commit channel commit5 commit1))
 386                     (list commit4 commit2))
 387              (lset= equal?
 388                     (map channel-news-entry-tag
 389                          (channel-news-for-commit channel commit5 commit1))
 390                     '(#f "tag-for-first-news-entry")))))))
 391
 392 (test-end "channels")