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