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