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