tests/import-github.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
   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-import-github)
  20   #:use-module (json)
  21   #:use-module (srfi srfi-35)
  22   #:use-module (srfi srfi-64)
  23   #:use-module (guix git-download)
  24   #:use-module (guix http-client)
  25   #:use-module (guix import github)
  26   #:use-module (guix packages)
  27   #:use-module (guix tests)
  28   #:use-module (guix upstream)
  29   #:use-module (web uri)
  30   #:use-module (ice-9 match))
  31
  32 (test-begin "github")
  33
  34 (define (call-with-releases thunk tags releases)
  35   (mock ((guix build download) open-connection-for-uri
  36          (lambda _
  37            ;; Return a fake socket.
  38            (%make-void-port "w+0")))
  39         (mock ((guix http-client) http-fetch
  40                (lambda* (uri #:key headers #:allow-other-keys)
  41                  (let ((uri (if (string? uri)
  42                                 (string->uri uri)
  43                                 uri)))
  44                    (unless (eq? 'mock (uri-scheme uri))
  45                      (error "the URI ~a should not be used" uri))
  46                    (define components
  47                      (string-tokenize (uri-path uri)
  48                                       (char-set-complement (char-set #\/))))
  49                    (pk 'stuff components headers)
  50                    (define (scm->json-port scm)
  51                      (open-input-string (scm->json-string scm)))
  52                    (match components
  53                      (("repos" "foo" "foomatics" "releases")
  54                       (scm->json-port releases))
  55                      (("repos" "foo" "foomatics" "tags")
  56                       (scm->json-port tags))
  57                      (rest (error "TODO ~a" rest))))))
  58               (parameterize ((%github-api "mock://"))
  59                 (thunk)))))
  60
  61 ;; Copied from tests/minetest.scm
  62 (define (upstream-source->sexp upstream-source)
  63   (define url (upstream-source-urls upstream-source))
  64   (unless (git-reference? url)
  65     (error "a <git-reference> is expected"))
  66   `(,(upstream-source-package upstream-source)
  67     ,(upstream-source-version upstream-source)
  68     ,(git-reference-url url)
  69     ,(git-reference-commit url)))
  70
  71 (define* (expected-sexp new-version new-commit)
  72   `("foomatics" ,new-version "https://github.com/foo/foomatics" ,new-commit))
  73
  74 (define (example-package old-version old-commit)
  75   (package
  76     (name "foomatics")
  77     (version old-version)
  78     (source
  79      (origin
  80        (method git-fetch)
  81        (uri (git-reference
  82              (url "https://github.com/foo/foomatics")
  83              (commit old-commit)))
  84        (sha256 #f) ; not important for following tests
  85        (file-name (git-file-name name version))))
  86     (build-system #f)
  87     (license #f)
  88     (synopsis #f)
  89     (description #f)
  90     (home-page #f)))
  91
  92 (define* (found-sexp old-version old-commit tags releases)
  93   (and=>
  94    (call-with-releases (lambda ()
  95                          ((upstream-updater-import %github-updater)
  96                           (example-package old-version old-commit)))
  97                        tags releases)
  98    upstream-source->sexp))
  99
 100 (define-syntax-rule (test-release test-case old-version
 101                                   old-commit new-version new-commit
 102                                   tags releases)
 103   (test-equal test-case
 104     (expected-sexp new-version new-commit)
 105     (found-sexp old-version old-commit tags releases)))
 106
 107 (test-release "newest release is choosen"
 108   "1.0.0" "v1.0.0" "1.9" "v1.9"
 109   #()
 110   ;; a mixture of current, older and newer versions
 111   #((("tag_name" . "v0.0"))
 112     (("tag_name" . "v1.0.1"))
 113     (("tag_name" . "v1.9"))
 114     (("tag_name" . "v1.0.0"))
 115     (("tag_name" . "v1.0.2"))))
 116
 117 (test-release "tags are used when there are no formal releases"
 118   "1.0.0" "v1.0.0" "1.9" "v1.9"
 119   ;; a mixture of current, older and newer versions
 120   #((("name" . "v0.0"))
 121     (("name" . "v1.0.1"))
 122     (("name" . "v1.9"))
 123     (("name" . "v1.0.0"))
 124     (("name" . "v1.0.2")))
 125   #())
 126
 127 (test-release "\"version-\" prefixes are recognised"
 128   "1.0.0" "v1.0.0" "1.9" "version-1.9"
 129   #((("name" . "version-1.9")))
 130   #())
 131
 132 (test-release "prefixes are optional"
 133   "1.0.0" "v1.0.0" "1.9" "1.9"
 134   #((("name" . "1.9")))
 135   #())
 136
 137 (test-release "prefixing by package name is acceptable"
 138   "1.0.0" "v1.0.0" "1.9" "foomatics-1.9"
 139   #((("name" . "foomatics-1.9")))
 140   #())
 141
 142 (test-release "not all prefixes are acceptable"
 143   "1.0.0" "v1.0.0" "1.0.0" "v1.0.0"
 144   #((("name" . "v1.0.0"))
 145     (("name" . "barstatics-1.9")))
 146   #())
 147
 148 (test-end "github")