tests/upstream.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2022 Ricardo Wurmus <rekado@elephly.net>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (test-upstream)
  21   #:use-module (gnu packages base)
  22   #:use-module (guix download)
  23   #:use-module (guix packages)
  24   #:use-module (guix build-system gnu)
  25   #:use-module (guix import print)
  26   #:use-module ((guix licenses) #:prefix license:)
  27   #:use-module (guix upstream)
  28   #:use-module (guix tests)
  29   #:use-module (srfi srfi-64)
  30   #:use-module (ice-9 match))
  31
  32 \f
  33 (test-begin "upstream")
  34
  35 ;; FIXME: Temporarily skipping this test; see <https://bugs.gnu.org/34229>.
  36 (test-skip 1)
  37
  38 (test-equal "coalesce-sources same version"
  39   (list (upstream-source
  40          (package "foo") (version "1")
  41          (urls '("ftp://example.org/foo-1.tar.xz"
  42                  "ftp://example.org/foo-1.tar.gz"))
  43          (signature-urls '("ftp://example.org/foo-1.tar.xz.sig"
  44                            "ftp://example.org/foo-1.tar.gz.sig"))))
  45
  46   (coalesce-sources (list (upstream-source
  47                            (package "foo") (version "1")
  48                            (urls '("ftp://example.org/foo-1.tar.gz"))
  49                            (signature-urls
  50                             '("ftp://example.org/foo-1.tar.gz.sig")))
  51                           (upstream-source
  52                            (package "foo") (version "1")
  53                            (urls '("ftp://example.org/foo-1.tar.xz"))
  54                            (signature-urls
  55                             '("ftp://example.org/foo-1.tar.xz.sig"))))))
  56
  57 (define test-package
  58   (package
  59     (name "test")
  60     (version "2.10")
  61     (source (origin
  62               (method url-fetch)
  63               (uri (string-append "mirror://gnu/hello/hello-" version
  64                                   ".tar.gz"))
  65               (sha256
  66                (base32
  67                 "0ssi1wpaf7plaswqqjwigppsg5fyh99vdlb9kzl7c9lng89ndq1i"))))
  68     (build-system gnu-build-system)
  69     (inputs
  70      `(("hello" ,hello)))
  71     (native-inputs
  72      `(("sed" ,sed)
  73        ("tar" ,tar)))
  74     (propagated-inputs
  75      `(("grep" ,grep)))
  76     (home-page "http://localhost")
  77     (synopsis "test")
  78     (description "test")
  79     (license license:gpl3+)))
  80
  81 (define test-package-sexp
  82   '(package
  83     (name "test")
  84     (version "2.10")
  85     (source (origin
  86               (method url-fetch)
  87               (uri (string-append "mirror://gnu/hello/hello-" version
  88                                   ".tar.gz"))
  89               (sha256
  90                (base32
  91                 "0ssi1wpaf7plaswqqjwigppsg5fyh99vdlb9kzl7c9lng89ndq1i"))))
  92     (build-system gnu-build-system)
  93     (inputs
  94      `(("hello" ,hello)))
  95     (native-inputs
  96      `(("sed" ,sed)
  97        ("tar" ,tar)))
  98     (propagated-inputs
  99      `(("grep" ,grep)))
 100     (home-page "http://localhost")
 101     (synopsis "test")
 102     (description "test")
 103     (license license:gpl3+)))
 104
 105 (test-equal "changed-inputs returns no changes"
 106   '()
 107   (changed-inputs test-package test-package-sexp))
 108
 109 (test-assert "changed-inputs returns changes to labelled input list"
 110   (let ((changes (changed-inputs
 111                   (package
 112                     (inherit test-package)
 113                     (inputs `(("hello" ,hello)
 114                               ("sed" ,sed))))
 115                   test-package-sexp)))
 116     (match changes
 117       ;; Exactly one change
 118       (((? upstream-input-change? item))
 119        (and (equal? (upstream-input-change-type item)
 120                     'regular)
 121             (equal? (upstream-input-change-action item)
 122                     'remove)
 123             (string=? (upstream-input-change-name item)
 124                       "sed")))
 125       (else (pk else #false)))))
 126
 127 (test-assert "changed-inputs returns changes to all labelled input lists"
 128   (let ((changes (changed-inputs
 129                   (package
 130                     (inherit test-package)
 131                     (inputs '())
 132                     (native-inputs '())
 133                     (propagated-inputs '()))
 134                   test-package-sexp)))
 135     (match changes
 136       (((? upstream-input-change? items) ...)
 137        (and (equal? (map upstream-input-change-type items)
 138                     '(regular native native propagated))
 139             (equal? (map upstream-input-change-action items)
 140                     '(add add add add))
 141             (equal? (map upstream-input-change-name items)
 142                     '("hello" "sed" "tar" "grep"))))
 143       (else (pk else #false)))))
 144
 145 (define test-new-package
 146   (package
 147     (inherit test-package)
 148     (inputs
 149      (list hello))
 150     (native-inputs
 151      (list sed tar))
 152     (propagated-inputs
 153      (list grep))))
 154
 155 (define test-new-package-sexp
 156   '(package
 157     (name "test")
 158     (version "2.10")
 159     (source (origin
 160               (method url-fetch)
 161               (uri (string-append "mirror://gnu/hello/hello-" version
 162                                   ".tar.gz"))
 163               (sha256
 164                (base32
 165                 "0ssi1wpaf7plaswqqjwigppsg5fyh99vdlb9kzl7c9lng89ndq1i"))))
 166     (build-system gnu-build-system)
 167     (inputs
 168      (list hello))
 169     (native-inputs
 170      (list sed tar))
 171     (propagated-inputs
 172      (list grep))
 173     (home-page "http://localhost")
 174     (synopsis "test")
 175     (description "test")
 176     (license license:gpl3+)))
 177
 178 (test-assert "changed-inputs returns changes to plain input list"
 179   (let ((changes (changed-inputs
 180                   (package
 181                     (inherit test-new-package)
 182                     (inputs (list hello sed)))
 183                   test-new-package-sexp)))
 184     (match changes
 185       ;; Exactly one change
 186       (((? upstream-input-change? item))
 187        (and (equal? (upstream-input-change-type item)
 188                     'regular)
 189             (equal? (upstream-input-change-action item)
 190                     'remove)
 191             (string=? (upstream-input-change-name item)
 192                       "sed")))
 193       (else (pk else #false)))))
 194
 195 (test-assert "changed-inputs returns changes to all plain input lists"
 196   (let ((changes (changed-inputs
 197                   (package
 198                     (inherit test-new-package)
 199                     (inputs '())
 200                     (native-inputs '())
 201                     (propagated-inputs '()))
 202                   test-new-package-sexp)))
 203     (match changes
 204       (((? upstream-input-change? items) ...)
 205        (and (equal? (map upstream-input-change-type items)
 206                     '(regular native native propagated))
 207             (equal? (map upstream-input-change-action items)
 208                     '(add add add add))
 209             (equal? (map upstream-input-change-name items)
 210                     '("hello" "sed" "tar" "grep"))))
 211       (else (pk else #false)))))
 212
 213 (test-end)