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) update-cached-checkout
 139            (lambda* (url #:key ref starting-commit)
 140              (match url
 141                ("test" (values test-dir "caf3cabba9e" #f))
 142                (_      (values (channel-instance-checkout instance--no-deps)
 143                                "abcde1234" #f)))))
 144           (with-store store
 145             (let ((instances (latest-channel-instances store (list channel))))
 146               (and (eq? 2 (length instances))
 147                    (lset= eq?
 148                           '(test test-channel)
 149                           (map (compose channel-name channel-instance-channel)
 150                                instances))))))))
 151
 152 (test-assert "latest-channel-instances excludes duplicate channel dependencies"
 153   (let* ((channel (channel
 154                    (name 'test)
 155                    (url "test")))
 156          (test-dir (channel-instance-checkout instance--with-dupes)))
 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 (= 2 (length instances))
 166                    (lset= eq?
 167                           '(test test-channel)
 168                           (map (compose channel-name channel-instance-channel)
 169                                instances))
 170                    ;; only the most specific channel dependency should remain,
 171                    ;; i.e. the one with a specified commit.
 172                    (find (lambda (instance)
 173                            (and (eq? (channel-name
 174                                       (channel-instance-channel instance))
 175                                      'test-channel)
 176                                 (string=? (channel-commit
 177                                            (channel-instance-channel instance))
 178                                           "abc1234")))
 179                          instances)))))))
 180
 181 (test-assert "channel-instances->manifest"
 182   ;; Compute the manifest for a graph of instances and make sure we get a
 183   ;; derivation graph that mirrors the instance graph.  This test also ensures
 184   ;; we don't try to access Git repositores at all at this stage.
 185   (let* ((spec      (lambda deps
 186                       `(channel (version 0)
 187                                 (dependencies
 188                                  ,@(map (lambda (dep)
 189                                           `(channel
 190                                             (name ,dep)
 191                                             (url "http://example.org")))
 192                                         deps)))))
 193          (guix      (make-instance #:name 'guix))
 194          (instance0 (make-instance #:name 'a))
 195          (instance1 (make-instance #:name 'b #:spec (spec 'a)))
 196          (instance2 (make-instance #:name 'c #:spec (spec 'b)))
 197          (instance3 (make-instance #:name 'd #:spec (spec 'c 'a))))
 198     (%graft? #f)                                    ;don't try to build stuff
 199
 200     ;; Create 'build-self.scm' so that GUIX is recognized as the 'guix' channel.
 201     (let ((source (channel-instance-checkout guix)))
 202       (mkdir (string-append source "/build-aux"))
 203       (call-with-output-file (string-append source
 204                                             "/build-aux/build-self.scm")
 205         (lambda (port)
 206           (write '(begin
 207                     (use-modules (guix) (gnu packages bootstrap))
 208
 209                     (lambda _
 210                       (package->derivation %bootstrap-guile)))
 211                  port))))
 212
 213     (with-store store
 214       (let ()
 215         (define manifest
 216           (run-with-store store
 217             (channel-instances->manifest (list guix
 218                                                instance0 instance1
 219                                                instance2 instance3))))
 220
 221         (define entries
 222           (manifest-entries manifest))
 223
 224         (define (depends? drv in out)
 225           ;; Return true if DRV depends (directly or indirectly) on all of IN
 226           ;; and none of OUT.
 227           (let ((set (list->set
 228                       (requisites store
 229                                   (list (derivation-file-name drv)))))
 230                 (in  (map derivation-file-name in))
 231                 (out (map derivation-file-name out)))
 232             (and (every (cut set-contains? set <>) in)
 233                  (not (any (cut set-contains? set <>) out)))))
 234
 235         (define (lookup name)
 236           (run-with-store store
 237             (lower-object
 238              (manifest-entry-item
 239               (manifest-lookup manifest
 240                                (manifest-pattern (name name)))))))
 241
 242         (let ((drv-guix (lookup "guix"))
 243               (drv0     (lookup "a"))
 244               (drv1     (lookup "b"))
 245               (drv2     (lookup "c"))
 246               (drv3     (lookup "d")))
 247           (and (depends? drv-guix '() (list drv0 drv1 drv2 drv3))
 248                (depends? drv0
 249                          (list) (list drv1 drv2 drv3))
 250                (depends? drv1
 251                          (list drv0) (list drv2 drv3))
 252                (depends? drv2
 253                          (list drv1) (list drv3))
 254                (depends? drv3
 255                          (list drv2 drv0) (list))))))))
 256
 257 (unless (which (git-command)) (test-skip 1))
 258 (test-equal "channel-news, no news"
 259   '()
 260   (with-temporary-git-repository directory
 261       '((add "a.txt" "A")
 262         (commit "the commit"))
 263     (with-repository directory repository
 264       (let ((channel (channel (url (string-append "file://" directory))
 265                               (name 'foo)))
 266             (latest  (reference-name->oid repository "HEAD")))
 267         (channel-news-for-commit channel (oid->string latest))))))
 268
 269 (unless (which (git-command)) (test-skip 1))
 270 (test-assert "channel-news, one entry"
 271   (with-temporary-git-repository directory
 272       `((add ".guix-channel"
 273              ,(object->string
 274                '(channel (version 0)
 275                          (news-file "news.scm"))))
 276         (commit "first commit")
 277         (add "src/a.txt" "A")
 278         (commit "second commit")
 279         (tag "tag-for-first-news-entry")
 280         (add "news.scm"
 281              ,(lambda (repository)
 282                 (let ((previous
 283                        (reference-name->oid repository "HEAD")))
 284                   (object->string
 285                    `(channel-news
 286                      (version 0)
 287                      (entry (commit ,(oid->string previous))
 288                             (title (en "New file!")
 289                                    (eo "Nova dosiero!"))
 290                             (body (en "Yeah, a.txt."))))))))
 291         (commit "third commit")
 292         (add "src/b.txt" "B")
 293         (commit "fourth commit")
 294         (add "news.scm"
 295              ,(lambda (repository)
 296                 (let ((second
 297                        (commit-id
 298                         (find-commit repository "second commit")))
 299                       (previous
 300                        (reference-name->oid repository "HEAD")))
 301                   (object->string
 302                    `(channel-news
 303                      (version 0)
 304                      (entry (commit ,(oid->string previous))
 305                             (title (en "Another file!"))
 306                             (body (en "Yeah, b.txt.")))
 307                      (entry (tag "tag-for-first-news-entry")
 308                             (title (en "Old news.")
 309                                    (eo "Malnovaĵoj."))
 310                             (body (en "For a.txt"))))))))
 311         (commit "fifth commit"))
 312     (with-repository directory repository
 313       (define (find-commit* message)
 314         (oid->string (commit-id (find-commit repository message))))
 315
 316       (let ((channel (channel (url (string-append "file://" directory))
 317                               (name 'foo)))
 318             (commit1 (find-commit* "first commit"))
 319             (commit2 (find-commit* "second commit"))
 320             (commit3 (find-commit* "third commit"))
 321             (commit4 (find-commit* "fourth commit"))
 322             (commit5 (find-commit* "fifth commit")))
 323         ;; First try fetching all the news up to a given commit.
 324         (and (null? (channel-news-for-commit channel commit2))
 325              (lset= string=?
 326                     (map channel-news-entry-commit
 327                          (channel-news-for-commit channel commit5))
 328                     (list commit2 commit4))
 329              (lset= equal?
 330                     (map channel-news-entry-title
 331                          (channel-news-for-commit channel commit5))
 332                     '((("en" . "Another file!"))
 333                       (("en" . "Old news.") ("eo" . "Malnovaĵoj."))))
 334              (lset= string=?
 335                     (map channel-news-entry-commit
 336                          (channel-news-for-commit channel commit3))
 337                     (list commit2))
 338
 339              ;; Now fetch news entries that apply to a commit range.
 340              (lset= string=?
 341                     (map channel-news-entry-commit
 342                          (channel-news-for-commit channel commit3 commit1))
 343                     (list commit2))
 344              (lset= string=?
 345                     (map channel-news-entry-commit
 346                          (channel-news-for-commit channel commit5 commit3))
 347                     (list commit4))
 348              (lset= string=?
 349                     (map channel-news-entry-commit
 350                          (channel-news-for-commit channel commit5 commit1))
 351                     (list commit4 commit2))
 352              (lset= equal?
 353                     (map channel-news-entry-tag
 354                          (channel-news-for-commit channel commit5 commit1))
 355                     '(#f "tag-for-first-news-entry")))))))
 356
 357 (test-end "channels")