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 (srfi srfi-1)
  32   #:use-module (srfi srfi-26)
  33   #:use-module (srfi srfi-34)
  34   #:use-module (srfi srfi-35)
  35   #:use-module (srfi srfi-64)
  36   #:use-module (ice-9 match))
  37
  38 (test-begin "channels")
  39
  40 (define* (make-instance #:key
  41                         (name 'fake)
  42                         (commit "cafebabe")
  43                         (spec #f))
  44   (define instance-dir (mkdtemp! "/tmp/checkout.XXXXXX"))
  45   (and spec
  46        (with-output-to-file (string-append instance-dir "/.guix-channel")
  47          (lambda _ (format #t "~a" spec))))
  48   (checkout->channel-instance instance-dir
  49                               #:commit commit
  50                               #:name name))
  51
  52 (define instance--boring (make-instance))
  53 (define instance--unsupported-version
  54   (make-instance #:spec
  55                  '(channel (version 42) (dependencies whatever))))
  56 (define instance--no-deps
  57   (make-instance #:spec
  58                  '(channel
  59                    (version 0)
  60                    (dependencies
  61                     (channel
  62                      (name test-channel)
  63                      (url "https://example.com/test-channel"))))))
  64 (define instance--simple
  65   (make-instance #:spec
  66                  '(channel
  67                    (version 0)
  68                    (dependencies
  69                     (channel
  70                      (name test-channel)
  71                      (url "https://example.com/test-channel"))))))
  72 (define instance--with-dupes
  73   (make-instance #:spec
  74                  '(channel
  75                    (version 0)
  76                    (dependencies
  77                     (channel
  78                      (name test-channel)
  79                      (url "https://example.com/test-channel"))
  80                     (channel
  81                      (name test-channel)
  82                      (url "https://example.com/test-channel")
  83                      (commit "abc1234"))
  84                     (channel
  85                      (name test-channel)
  86                      (url "https://example.com/test-channel-elsewhere"))))))
  87
  88 (define channel-instance-metadata
  89   (@@ (guix channels) channel-instance-metadata))
  90
  91 \f
  92 (test-equal "channel-instance-metadata returns #f if .guix-channel does not exist"
  93   #f
  94   (channel-instance-metadata instance--boring))
  95
  96 (test-equal "channel-instance-metadata rejects unsupported version"
  97   1                              ;line number in the generated '.guix-channel'
  98   (guard (c ((and (message-condition? c) (error-location? c))
  99              (location-line (error-location c))))
 100     (channel-instance-metadata instance--unsupported-version)))
 101
 102 (test-assert "channel-instance-metadata returns <channel-metadata>"
 103   (every (@@ (guix channels) channel-metadata?)
 104          (map channel-instance-metadata
 105               (list instance--no-deps
 106                     instance--simple
 107                     instance--with-dupes))))
 108
 109 (test-assert "channel-instance-metadata dependencies are channels"
 110   (let ((deps ((@@ (guix channels) channel-metadata-dependencies)
 111                (channel-instance-metadata instance--simple))))
 112     (match deps
 113       (((? channel? dep)) #t)
 114       (_ #f))))
 115
 116 (test-assert "latest-channel-instances includes channel dependencies"
 117   (let* ((channel (channel
 118                    (name 'test)
 119                    (url "test")))
 120          (test-dir (channel-instance-checkout instance--simple)))
 121     (mock ((guix git) latest-repository-commit
 122            (lambda* (store url #:key ref)
 123              (match url
 124                ("test" (values test-dir 'whatever))
 125                (_ (values "/not-important" 'not-important)))))
 126           (let ((instances (latest-channel-instances #f (list channel))))
 127             (and (eq? 2 (length instances))
 128                  (lset= eq?
 129                         '(test test-channel)
 130                         (map (compose channel-name channel-instance-channel)
 131                              instances)))))))
 132
 133 (test-assert "latest-channel-instances excludes duplicate channel dependencies"
 134   (let* ((channel (channel
 135                    (name 'test)
 136                    (url "test")))
 137          (test-dir (channel-instance-checkout instance--with-dupes)))
 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                  ;; only the most specific channel dependency should remain,
 150                  ;; i.e. the one with a specified commit.
 151                  (find (lambda (instance)
 152                          (and (eq? (channel-name
 153                                     (channel-instance-channel instance))
 154                                    'test-channel)
 155                               (eq? (channel-commit
 156                                     (channel-instance-channel instance))
 157                                    'abc1234)))
 158                        instances))))))
 159
 160 (test-assert "channel-instances->manifest"
 161   ;; Compute the manifest for a graph of instances and make sure we get a
 162   ;; derivation graph that mirrors the instance graph.  This test also ensures
 163   ;; we don't try to access Git repositores at all at this stage.
 164   (let* ((spec      (lambda deps
 165                       `(channel (version 0)
 166                                 (dependencies
 167                                  ,@(map (lambda (dep)
 168                                           `(channel
 169                                             (name ,dep)
 170                                             (url "http://example.org")))
 171                                         deps)))))
 172          (guix      (make-instance #:name 'guix))
 173          (instance0 (make-instance #:name 'a))
 174          (instance1 (make-instance #:name 'b #:spec (spec 'a)))
 175          (instance2 (make-instance #:name 'c #:spec (spec 'b)))
 176          (instance3 (make-instance #:name 'd #:spec (spec 'c 'a))))
 177     (%graft? #f)                                    ;don't try to build stuff
 178
 179     ;; Create 'build-self.scm' so that GUIX is recognized as the 'guix' channel.
 180     (let ((source (channel-instance-checkout guix)))
 181       (mkdir (string-append source "/build-aux"))
 182       (call-with-output-file (string-append source
 183                                             "/build-aux/build-self.scm")
 184         (lambda (port)
 185           (write '(begin
 186                     (use-modules (guix) (gnu packages bootstrap))
 187
 188                     (lambda _
 189                       (package->derivation %bootstrap-guile)))
 190                  port))))
 191
 192     (with-store store
 193       (let ()
 194         (define manifest
 195           (run-with-store store
 196             (channel-instances->manifest (list guix
 197                                                instance0 instance1
 198                                                instance2 instance3))))
 199
 200         (define entries
 201           (manifest-entries manifest))
 202
 203         (define (depends? drv in out)
 204           ;; Return true if DRV depends (directly or indirectly) on all of IN
 205           ;; and none of OUT.
 206           (let ((set (list->set
 207                       (requisites store
 208                                   (list (derivation-file-name drv)))))
 209                 (in  (map derivation-file-name in))
 210                 (out (map derivation-file-name out)))
 211             (and (every (cut set-contains? set <>) in)
 212                  (not (any (cut set-contains? set <>) out)))))
 213
 214         (define (lookup name)
 215           (run-with-store store
 216             (lower-object
 217              (manifest-entry-item
 218               (manifest-lookup manifest
 219                                (manifest-pattern (name name)))))))
 220
 221         (let ((drv-guix (lookup "guix"))
 222               (drv0     (lookup "a"))
 223               (drv1     (lookup "b"))
 224               (drv2     (lookup "c"))
 225               (drv3     (lookup "d")))
 226           (and (depends? drv-guix '() (list drv0 drv1 drv2 drv3))
 227                (depends? drv0
 228                          (list) (list drv1 drv2 drv3))
 229                (depends? drv1
 230                          (list drv0) (list drv2 drv3))
 231                (depends? drv2
 232                          (list drv1) (list drv3))
 233                (depends? drv3
 234                          (list drv2 drv0) (list))))))))
 235
 236 (test-end "channels")