diff options
| author | Xinglu Chen <public@yoctocell.xyz> | 2021-09-17 10:04:49 +0200 |
|---|---|---|
| committer | Ludovic Courtès <ludo@gnu.org> | 2021-09-18 19:37:45 +0200 |
| commit | 59ee10754eddddb99e4a80b9e18aa12ed1b3d77a (patch) | |
| tree | 0e5b7e9961218577b7b4f8dcf682f8fec3403cc9 | |
| parent | 6597f80839142cd341cbf6cee2f34eaf4de14533 (diff) | |
import: Add 'generic-git' updater.
* guix/git.scm (ls-remote-refs): New procedure.
* tests/git.scm ("remote-refs" "remote-refs: only tags"): New tests.
* guix/import/git.scm: New file.
* doc/guix.texi (Invoking guix refresh): Document it.
* tests/import-git.scm: New test file.
* Makefile.am (MODULES, SCM_TESTS): Register the new files.
Co-authored-by: Sarah Morgensen <iskarian@mgsn.dev>
Signed-off-by: Ludovic Courtès <ludo@gnu.org>
| -rw-r--r-- | Makefile.am | 2 | ||||
| -rw-r--r-- | doc/guix.texi | 34 | ||||
| -rw-r--r-- | guix/git.scm | 41 | ||||
| -rw-r--r-- | guix/import/git.scm | 225 | ||||
| -rw-r--r-- | tests/git.scm | 28 | ||||
| -rw-r--r-- | tests/import-git.scm | 245 |
6 files changed, 575 insertions, 0 deletions
diff --git a/Makefile.am b/Makefile.am index 299bc0f7fba..f3bdc7448ea 100644 --- a/Makefile.am +++ b/Makefile.am | |||
| @@ -254,6 +254,7 @@ MODULES = \ | |||
| 254 | guix/import/egg.scm \ | 254 | guix/import/egg.scm \ |
| 255 | guix/import/elpa.scm \ | 255 | guix/import/elpa.scm \ |
| 256 | guix/import/gem.scm \ | 256 | guix/import/gem.scm \ |
| 257 | guix/import/git.scm \ | ||
| 257 | guix/import/github.scm \ | 258 | guix/import/github.scm \ |
| 258 | guix/import/gnome.scm \ | 259 | guix/import/gnome.scm \ |
| 259 | guix/import/gnu.scm \ | 260 | guix/import/gnu.scm \ |
| @@ -473,6 +474,7 @@ SCM_TESTS = \ | |||
| 473 | tests/graph.scm \ | 474 | tests/graph.scm \ |
| 474 | tests/gremlin.scm \ | 475 | tests/gremlin.scm \ |
| 475 | tests/hackage.scm \ | 476 | tests/hackage.scm \ |
| 477 | tests/import-git.scm \ | ||
| 476 | tests/import-utils.scm \ | 478 | tests/import-utils.scm \ |
| 477 | tests/inferior.scm \ | 479 | tests/inferior.scm \ |
| 478 | tests/lint.scm \ | 480 | tests/lint.scm \ |
diff --git a/doc/guix.texi b/doc/guix.texi index 2fc96879106..6436e83a7c8 100644 --- a/doc/guix.texi +++ b/doc/guix.texi | |||
| @@ -11928,6 +11928,40 @@ the updater for @uref{https://launchpad.net, Launchpad} packages. | |||
| 11928 | @item generic-html | 11928 | @item generic-html |
| 11929 | a generic updater that crawls the HTML page where the source tarball of | 11929 | a generic updater that crawls the HTML page where the source tarball of |
| 11930 | the package is hosted, when applicable. | 11930 | the package is hosted, when applicable. |
| 11931 | |||
| 11932 | @item generic-git | ||
| 11933 | a generic updater for packages hosted on Git repositories. It tries to | ||
| 11934 | be smart about parsing Git tag names, but if it is not able to parse the | ||
| 11935 | tag name and compare tags correctly, users can define the following | ||
| 11936 | properties for a package. | ||
| 11937 | |||
| 11938 | @itemize | ||
| 11939 | @item @code{release-tag-prefix}: a regular expression for matching a prefix of | ||
| 11940 | the tag name. | ||
| 11941 | |||
| 11942 | @item @code{release-tag-suffix}: a regular expression for matching a suffix of | ||
| 11943 | the tag name. | ||
| 11944 | |||
| 11945 | @item @code{release-tag-version-delimiter}: a string used as the delimiter in | ||
| 11946 | the tag name for separating the numbers of the version. | ||
| 11947 | |||
| 11948 | @item @code{accept-pre-releases}: by default, the updater will ignore | ||
| 11949 | pre-releases; to make it also look for pre-releases, set the this | ||
| 11950 | property to @code{#t}. | ||
| 11951 | |||
| 11952 | @end itemize | ||
| 11953 | |||
| 11954 | @lisp | ||
| 11955 | (package | ||
| 11956 | (name "foo") | ||
| 11957 | ;; ... | ||
| 11958 | (properties | ||
| 11959 | '((release-tag-prefix . "^release0-") | ||
| 11960 | (release-tag-suffix . "[a-z]?$") | ||
| 11961 | (release-tag-version-delimiter . ":")))) | ||
| 11962 | @end lisp | ||
| 11963 | |||
| 11964 | |||
| 11931 | @end table | 11965 | @end table |
| 11932 | 11966 | ||
| 11933 | For instance, the following command only checks for updates of Emacs | 11967 | For instance, the following command only checks for updates of Emacs |
diff --git a/guix/git.scm b/guix/git.scm index acc48fd12f5..bbff4fc8907 100644 --- a/guix/git.scm +++ b/guix/git.scm | |||
| @@ -57,6 +57,8 @@ | |||
| 57 | commit-difference | 57 | commit-difference |
| 58 | commit-relation | 58 | commit-relation |
| 59 | 59 | ||
| 60 | remote-refs | ||
| 61 | |||
| 60 | git-checkout | 62 | git-checkout |
| 61 | git-checkout? | 63 | git-checkout? |
| 62 | git-checkout-url | 64 | git-checkout-url |
| @@ -571,6 +573,45 @@ objects: 'ancestor (meaning that OLD is an ancestor of NEW), 'descendant, or | |||
| 571 | (if (set-contains? oldest new) | 573 | (if (set-contains? oldest new) |
| 572 | 'descendant | 574 | 'descendant |
| 573 | 'unrelated)))))) | 575 | 'unrelated)))))) |
| 576 | |||
| 577 | ;; | ||
| 578 | ;;; Remote operations. | ||
| 579 | ;;; | ||
| 580 | |||
| 581 | (define* (remote-refs url #:key tags?) | ||
| 582 | "Return the list of references advertised at Git repository URL. If TAGS? | ||
| 583 | is true, limit to only refs/tags." | ||
| 584 | (define (ref? ref) | ||
| 585 | ;; Like `git ls-remote --refs', only show actual references. | ||
| 586 | (and (string-prefix? "refs/" ref) | ||
| 587 | (not (string-suffix? "^{}" ref)))) | ||
| 588 | |||
| 589 | (define (tag? ref) | ||
| 590 | (string-prefix? "refs/tags/" ref)) | ||
| 591 | |||
| 592 | (define (include? ref) | ||
| 593 | (and (ref? ref) | ||
| 594 | (or (not tags?) (tag? ref)))) | ||
| 595 | |||
| 596 | (define (remote-head->ref remote) | ||
| 597 | (let ((name (remote-head-name remote))) | ||
| 598 | (and (include? name) | ||
| 599 | name))) | ||
| 600 | |||
| 601 | (with-libgit2 | ||
| 602 | (call-with-temporary-directory | ||
| 603 | (lambda (cache-directory) | ||
| 604 | (let* ((repository (repository-init cache-directory)) | ||
| 605 | ;; Create an in-memory remote so we don't touch disk. | ||
| 606 | (remote (remote-create-anonymous repository url))) | ||
| 607 | (remote-connect remote) | ||
| 608 | |||
| 609 | (let* ((remote-heads (remote-ls remote)) | ||
| 610 | (refs (filter-map remote-head->ref remote-heads))) | ||
| 611 | ;; Wait until we're finished with the repository before closing it. | ||
| 612 | (remote-disconnect remote) | ||
| 613 | (repository-close! repository) | ||
| 614 | refs)))))) | ||
| 574 | 615 | ||
| 575 | 616 | ||
| 576 | ;;; | 617 | ;;; |
diff --git a/guix/import/git.scm b/guix/import/git.scm new file mode 100644 index 00000000000..1eb219f3fe2 --- /dev/null +++ b/guix/import/git.scm | |||
| @@ -0,0 +1,225 @@ | |||
| 1 | ;;; GNU Guix --- Functional package management for GNU | ||
| 2 | ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> | ||
| 3 | ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> | ||
| 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 (guix import git) | ||
| 21 | #:use-module (guix build utils) | ||
| 22 | #:use-module (guix diagnostics) | ||
| 23 | #:use-module (guix git) | ||
| 24 | #:use-module (guix git-download) | ||
| 25 | #:use-module (guix i18n) | ||
| 26 | #:use-module (guix packages) | ||
| 27 | #:use-module (guix upstream) | ||
| 28 | #:use-module (guix utils) | ||
| 29 | #:use-module (ice-9 format) | ||
| 30 | #:use-module (ice-9 match) | ||
| 31 | #:use-module (ice-9 rdelim) | ||
| 32 | #:use-module (ice-9 regex) | ||
| 33 | #:use-module (srfi srfi-1) | ||
| 34 | #:use-module (srfi srfi-26) | ||
| 35 | #:use-module (srfi srfi-34) | ||
| 36 | #:use-module (srfi srfi-35) | ||
| 37 | #:export (%generic-git-updater | ||
| 38 | |||
| 39 | ;; For tests. | ||
| 40 | latest-git-tag-version)) | ||
| 41 | |||
| 42 | ;;; Commentary: | ||
| 43 | ;;; | ||
| 44 | ;;; This module provides a generic package updater for packages hosted on Git | ||
| 45 | ;;; repositories. | ||
| 46 | ;;; | ||
| 47 | ;;; It tries to be smart about tag names, but if it is not automatically able | ||
| 48 | ;;; to parse the tag names correctly, users can set the `release-tag-prefix', | ||
| 49 | ;;; `release-tag-suffix' and `release-tag-version-delimiter' properties of the | ||
| 50 | ;;; package to make the updater parse the Git tag name correctly. | ||
| 51 | ;;; | ||
| 52 | ;;; Possible improvements: | ||
| 53 | ;;; | ||
| 54 | ;;; * More robust method for trying to guess the delimiter. Maybe look at the | ||
| 55 | ;;; previous version/tag combo to determine the delimiter. | ||
| 56 | ;;; | ||
| 57 | ;;; * Differentiate between "normal" versions, e.g., 1.2.3, and dates, e.g., | ||
| 58 | ;;; 2021.12.31. Honor a `release-tag-date-scheme?' property? | ||
| 59 | ;;; | ||
| 60 | ;;; Code: | ||
| 61 | |||
| 62 | ;;; Errors & warnings | ||
| 63 | |||
| 64 | (define-condition-type &git-no-valid-tags-error &error | ||
| 65 | git-no-valid-tags-error?) | ||
| 66 | |||
| 67 | (define (git-no-valid-tags-error) | ||
| 68 | (raise (condition (&message (message "no valid tags found")) | ||
| 69 | (&git-no-valid-tags-error)))) | ||
| 70 | |||
| 71 | (define-condition-type &git-no-tags-error &error | ||
| 72 | git-no-tags-error?) | ||
| 73 | |||
| 74 | (define (git-no-tags-error) | ||
| 75 | (raise (condition (&message (message "no tags were found")) | ||
| 76 | (&git-no-tags-error)))) | ||
| 77 | |||
| 78 | |||
| 79 | ;;; Updater | ||
| 80 | |||
| 81 | (define %pre-release-words | ||
| 82 | '("alpha" "beta" "rc" "dev" "test" "pre")) | ||
| 83 | |||
| 84 | (define %pre-release-rx | ||
| 85 | (map (lambda (word) | ||
| 86 | (make-regexp (string-append ".+" word) regexp/icase)) | ||
| 87 | %pre-release-words)) | ||
| 88 | |||
| 89 | (define* (version-mapping tags #:key prefix suffix delim pre-releases?) | ||
| 90 | "Given a list of Git TAGS, return an association list where the car is the | ||
| 91 | version corresponding to the tag, and the cdr is the name of the tag." | ||
| 92 | (define (guess-delimiter) | ||
| 93 | (let ((total (length tags)) | ||
| 94 | (dots (reduce + 0 (map (cut string-count <> #\.) tags))) | ||
| 95 | (dashes (reduce + 0 (map (cut string-count <> #\-) tags))) | ||
| 96 | (underscores (reduce + 0 (map (cut string-count <> #\_) tags)))) | ||
| 97 | (cond | ||
| 98 | ((>= dots (* total 0.35)) ".") | ||
| 99 | ((>= dashes (* total 0.8)) "-") | ||
| 100 | ((>= underscores (* total 0.8)) "_") | ||
| 101 | (else "")))) | ||
| 102 | |||
| 103 | (define delim-rx (regexp-quote (or delim (guess-delimiter)))) | ||
| 104 | (define suffix-rx (string-append (or suffix "") "$")) | ||
| 105 | (define prefix-rx (string-append "^" (or prefix "[^[:digit:]]*"))) | ||
| 106 | (define pre-release-rx | ||
| 107 | (if pre-releases? | ||
| 108 | (string-append "(.*(" (string-join %pre-release-words "|") ").*)") | ||
| 109 | "")) | ||
| 110 | |||
| 111 | (define tag-rx | ||
| 112 | (string-append prefix-rx "([[:digit:]][^" delim-rx "[:punct:]]*" | ||
| 113 | "(" delim-rx "[^[:punct:]" delim-rx "]+)" | ||
| 114 | ;; If there are no delimiters, it could mean that the | ||
| 115 | ;; version just contains one number (e.g., "2"), thus, use | ||
| 116 | ;; "*" instead of "+" to match zero or more numbers. | ||
| 117 | (if (string=? delim-rx "") "*" "+") ")" | ||
| 118 | ;; We don't want the pre-release stuff (e.g., "-alpha") be | ||
| 119 | ;; part of the first group; otherwise, the "-" in "-alpha" | ||
| 120 | ;; might be interpreted as a delimiter, and thus replaced | ||
| 121 | ;; with "." | ||
| 122 | pre-release-rx suffix-rx)) | ||
| 123 | |||
| 124 | |||
| 125 | |||
| 126 | (define (get-version tag) | ||
| 127 | (let ((tag-match (regexp-exec (make-regexp tag-rx) tag))) | ||
| 128 | (and=> (and tag-match | ||
| 129 | (regexp-substitute/global | ||
| 130 | #f delim-rx (match:substring tag-match 1) | ||
| 131 | ;; If there were no delimiters, don't insert ".". | ||
| 132 | 'pre (if (string=? delim-rx "") "" ".") 'post)) | ||
| 133 | (lambda (version) | ||
| 134 | (if pre-releases? | ||
| 135 | (string-append version (match:substring tag-match 3)) | ||
| 136 | version))))) | ||
| 137 | |||
| 138 | (define (entry<? a b) | ||
| 139 | (eq? (version-compare (car a) (car b)) '<)) | ||
| 140 | |||
| 141 | (stable-sort (filter-map (lambda (tag) | ||
| 142 | (let ((version (get-version tag))) | ||
| 143 | (and version (cons version tag)))) | ||
| 144 | tags) | ||
| 145 | entry<?)) | ||
| 146 | |||
| 147 | (define* (latest-tag url #:key prefix suffix delim pre-releases?) | ||
| 148 | "Return the latest version and corresponding tag available from the Git | ||
| 149 | repository at URL." | ||
| 150 | (define (pre-release? tag) | ||
| 151 | (any (cut regexp-exec <> tag) | ||
| 152 | %pre-release-rx)) | ||
| 153 | |||
| 154 | (let* ((tags (map (cut string-drop <> (string-length "refs/tags/")) | ||
| 155 | (remote-refs url #:tags? #t))) | ||
| 156 | (versions->tags | ||
| 157 | (version-mapping (if pre-releases? | ||
| 158 | tags | ||
| 159 | (filter (negate pre-release?) tags)) | ||
| 160 | #:prefix prefix | ||
| 161 | #:suffix suffix | ||
| 162 | #:delim delim | ||
| 163 | #:pre-releases? pre-releases?))) | ||
| 164 | (cond | ||
| 165 | ((null? tags) | ||
| 166 | (git-no-tags-error)) | ||
| 167 | ((null? versions->tags) | ||
| 168 | (git-no-valid-tags-error)) | ||
| 169 | (else | ||
| 170 | (match (last versions->tags) | ||
| 171 | ((version . tag) | ||
| 172 | (values version tag))))))) | ||
| 173 | |||
| 174 | (define (latest-git-tag-version package) | ||
| 175 | "Given a PACKAGE, return the latest version of it, or #f if the latest version | ||
| 176 | could not be determined." | ||
| 177 | (guard (c ((or (git-no-tags-error? c) (git-no-valid-tags-error? c)) | ||
| 178 | (warning (or (package-field-location package 'source) | ||
| 179 | (package-location package)) | ||
| 180 | (G_ "~a for ~a~%") | ||
| 181 | (condition-message c) | ||
| 182 | (package-name package)) | ||
| 183 | #f) | ||
| 184 | ((eq? (exception-kind c) 'git-error) | ||
| 185 | (warning (or (package-field-location package 'source) | ||
| 186 | (package-location package)) | ||
| 187 | (G_ "failed to fetch Git repository for ~a~%") | ||
| 188 | (package-name package)) | ||
| 189 | #f)) | ||
| 190 | (let* ((source (package-source package)) | ||
| 191 | (url (git-reference-url (origin-uri source))) | ||
| 192 | (property (cute assq-ref (package-properties package) <>))) | ||
| 193 | (latest-tag url | ||
| 194 | #:prefix (property 'release-tag-prefix) | ||
| 195 | #:suffix (property 'release-tag-suffix) | ||
| 196 | #:delim (property 'release-tag-version-delimiter) | ||
| 197 | #:pre-releases? (property 'accept-pre-releases?))))) | ||
| 198 | |||
| 199 | (define (git-package? package) | ||
| 200 | "Return true if PACKAGE is hosted on a Git repository." | ||
| 201 | (match (package-source package) | ||
| 202 | ((? origin? origin) | ||
| 203 | (and (eq? (origin-method origin) git-fetch) | ||
| 204 | (git-reference? (origin-uri origin)))) | ||
| 205 | (_ #f))) | ||
| 206 | |||
| 207 | (define (latest-git-release package) | ||
| 208 | "Return an <upstream-source> for the latest release of PACKAGE." | ||
| 209 | (let* ((name (package-name package)) | ||
| 210 | (old-version (package-version package)) | ||
| 211 | (url (git-reference-url (origin-uri (package-source package)))) | ||
| 212 | (new-version (latest-git-tag-version package))) | ||
| 213 | |||
| 214 | (and new-version | ||
| 215 | (upstream-source | ||
| 216 | (package name) | ||
| 217 | (version new-version) | ||
| 218 | (urls (list url)))))) | ||
| 219 | |||
| 220 | (define %generic-git-updater | ||
| 221 | (upstream-updater | ||
| 222 | (name 'generic-git) | ||
| 223 | (description "Updater for packages hosted on Git repositories") | ||
| 224 | (pred git-package?) | ||
| 225 | (latest latest-git-release))) | ||
diff --git a/tests/git.scm b/tests/git.scm index aa4f03ca62c..d0646bbc85b 100644 --- a/tests/git.scm +++ b/tests/git.scm | |||
| @@ -1,5 +1,6 @@ | |||
| 1 | ;;; GNU Guix --- Functional package management for GNU | 1 | ;;; GNU Guix --- Functional package management for GNU |
| 2 | ;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org> | 2 | ;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org> |
| 3 | ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz | ||
| 3 | ;;; | 4 | ;;; |
| 4 | ;;; This file is part of GNU Guix. | 5 | ;;; This file is part of GNU Guix. |
| 5 | ;;; | 6 | ;;; |
| @@ -161,4 +162,31 @@ | |||
| 161 | (commit-relation master1 merge) | 162 | (commit-relation master1 merge) |
| 162 | (commit-relation merge master1)))))) | 163 | (commit-relation merge master1)))))) |
| 163 | 164 | ||
| 165 | (unless (which (git-command)) (test-skip 1)) | ||
| 166 | (test-equal "remote-refs" | ||
| 167 | '("refs/heads/develop" "refs/heads/master" | ||
| 168 | "refs/tags/v1.0" "refs/tags/v1.1") | ||
| 169 | (with-temporary-git-repository directory | ||
| 170 | '((add "a.txt" "A") | ||
| 171 | (commit "First commit") | ||
| 172 | (tag "v1.0" "release-1.0") | ||
| 173 | (branch "develop") | ||
| 174 | (checkout "develop") | ||
| 175 | (add "b.txt" "B") | ||
| 176 | (commit "Second commit") | ||
| 177 | (tag "v1.1" "release-1.1")) | ||
| 178 | (remote-refs directory))) | ||
| 179 | |||
| 180 | (unless (which (git-command)) (test-skip 1)) | ||
| 181 | (test-equal "remote-refs: only tags" | ||
| 182 | '("refs/tags/v1.0" "refs/tags/v1.1") | ||
| 183 | (with-temporary-git-repository directory | ||
| 184 | '((add "a.txt" "A") | ||
| 185 | (commit "First commit") | ||
| 186 | (tag "v1.0" "Release 1.0") | ||
| 187 | (add "b.txt" "B") | ||
| 188 | (commit "Second commit") | ||
| 189 | (tag "v1.1" "Release 1.1")) | ||
| 190 | (remote-refs directory #:tags? #t))) | ||
| 191 | |||
| 164 | (test-end "git") | 192 | (test-end "git") |
diff --git a/tests/import-git.scm b/tests/import-git.scm new file mode 100644 index 00000000000..f1bce154bb2 --- /dev/null +++ b/tests/import-git.scm | |||
| @@ -0,0 +1,245 @@ | |||
| 1 | ;;; GNU Guix --- Functional package management for GNU | ||
| 2 | ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz | ||
| 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-git) | ||
| 20 | #:use-module (git) | ||
| 21 | #:use-module (guix git) | ||
| 22 | #:use-module (guix tests) | ||
| 23 | #:use-module (guix packages) | ||
| 24 | #:use-module (guix import git) | ||
| 25 | #:use-module (guix git-download) | ||
| 26 | #:use-module (guix tests git) | ||
| 27 | #:use-module (guix build utils) | ||
| 28 | #:use-module (srfi srfi-1) | ||
| 29 | #:use-module (srfi srfi-64)) | ||
| 30 | |||
| 31 | ;; Test the (guix import git) tools. | ||
| 32 | |||
| 33 | (test-begin "git") | ||
| 34 | |||
| 35 | (define* (make-package directory version #:optional (properties '())) | ||
| 36 | (dummy-package "test-package" | ||
| 37 | (version version) | ||
| 38 | (properties properties) | ||
| 39 | (source | ||
| 40 | (origin | ||
| 41 | (method git-fetch) | ||
| 42 | (uri (git-reference | ||
| 43 | (url (string-append "file://" directory)) | ||
| 44 | (commit version))) | ||
| 45 | (sha256 | ||
| 46 | (base32 | ||
| 47 | "0000000000000000000000000000000000000000000000000000")))))) | ||
| 48 | |||
| 49 | (unless (which (git-command)) (test-skip 1)) | ||
| 50 | (test-equal "latest-git-tag-version: no custom prefix, suffix, and delimiter" | ||
| 51 | "1.0.1" | ||
| 52 | (with-temporary-git-repository directory | ||
| 53 | '((add "a.txt" "A") | ||
| 54 | (commit "First commit") | ||
| 55 | (tag "1.0.1" "Release 1.0.1")) | ||
| 56 | (let ((package (make-package directory "1.0.0"))) | ||
| 57 | (latest-git-tag-version package)))) | ||
| 58 | |||
| 59 | (unless (which (git-command)) (test-skip 1)) | ||
| 60 | (test-equal "latest-git-tag-version: custom prefix, no suffix and delimiter" | ||
| 61 | "1.0.1" | ||
| 62 | (with-temporary-git-repository directory | ||
| 63 | '((add "a.txt" "A") | ||
| 64 | (commit "First commit") | ||
| 65 | (tag "prefix-1.0.1" "Release 1.0.1")) | ||
| 66 | (let ((package (make-package directory "1.0.0" | ||
| 67 | '((release-tag-prefix . "prefix-"))))) | ||
| 68 | (latest-git-tag-version package)))) | ||
| 69 | |||
| 70 | (unless (which (git-command)) (test-skip 1)) | ||
| 71 | (test-equal "latest-git-tag-version: custom suffix, no prefix and delimiter" | ||
| 72 | "1.0.1" | ||
| 73 | (with-temporary-git-repository directory | ||
| 74 | '((add "a.txt" "A") | ||
| 75 | (commit "First commit") | ||
| 76 | (tag "1.0.1-suffix-123" "Release 1.0.1")) | ||
| 77 | (let ((package (make-package directory "1.0.0" | ||
| 78 | '((release-tag-suffix . "-suffix-[0-9]*"))))) | ||
| 79 | (latest-git-tag-version package)))) | ||
| 80 | |||
| 81 | (unless (which (git-command)) (test-skip 1)) | ||
| 82 | (test-equal "latest-git-tag-version: custom delimiter, no prefix and suffix" | ||
| 83 | "2021.09.07" | ||
| 84 | (with-temporary-git-repository directory | ||
| 85 | '((add "a.txt" "A") | ||
| 86 | (commit "First commit") | ||
| 87 | (tag "2021-09-07" "Release 2021-09-07")) | ||
| 88 | (let ((package (make-package directory "2021-09-06" | ||
| 89 | '((release-tag-version-delimiter . "-"))))) | ||
| 90 | (latest-git-tag-version package)))) | ||
| 91 | |||
| 92 | (unless (which (git-command)) (test-skip 1)) | ||
| 93 | (test-equal "latest-git-tag-version: empty delimiter, no prefix and suffix" | ||
| 94 | "20210907" | ||
| 95 | (with-temporary-git-repository directory | ||
| 96 | '((add "a.txt" "A") | ||
| 97 | (commit "First commit") | ||
| 98 | (tag "20210907" "Release 20210907")) | ||
| 99 | (let ((package (make-package directory "20210906" | ||
| 100 | '((release-tag-version-delimiter . ""))))) | ||
| 101 | (latest-git-tag-version package)))) | ||
| 102 | |||
| 103 | (unless (which (git-command)) (test-skip 1)) | ||
| 104 | (test-equal "latest-git-tag-version: custom prefix and suffix, no delimiter" | ||
| 105 | "2.0.0" | ||
| 106 | (with-temporary-git-repository directory | ||
| 107 | '((add "a.txt" "A") | ||
| 108 | (commit "First commit") | ||
| 109 | (tag "Release-2.0.0suffix-1" "Release 2.0.0")) | ||
| 110 | (let ((package (make-package directory "1.0.0" | ||
| 111 | '((release-tag-prefix . "Release-") | ||
| 112 | (release-tag-suffix . "suffix-[0-9]"))))) | ||
| 113 | (latest-git-tag-version package)))) | ||
| 114 | |||
| 115 | (unless (which (git-command)) (test-skip 1)) | ||
| 116 | (test-equal "latest-git-tag-version: custom prefix, suffix, and delimiter" | ||
| 117 | "2.0.0" | ||
| 118 | (with-temporary-git-repository directory | ||
| 119 | '((add "a.txt" "A") | ||
| 120 | (commit "First commit") | ||
| 121 | (tag "Release-2_0_0suffix-1" "Release 2.0.0")) | ||
| 122 | (let ((package (make-package directory "1.0.0" | ||
| 123 | '((release-tag-prefix . "Release-") | ||
| 124 | (release-tag-suffix . "suffix-[0-9]") | ||
| 125 | (release-tag-version-delimiter . "_"))))) | ||
| 126 | (latest-git-tag-version package)))) | ||
| 127 | |||
| 128 | (unless (which (git-command)) (test-skip 1)) | ||
| 129 | (test-equal "latest-git-tag-version: only pre-releases available" | ||
| 130 | #f | ||
| 131 | (with-temporary-git-repository directory | ||
| 132 | '((add "a.txt" "A") | ||
| 133 | (commit "First commit") | ||
| 134 | (tag "2.0.0-rc1" "Release candidate for 2.0.0")) | ||
| 135 | (let ((package (make-package directory "1.0.0"))) | ||
| 136 | (latest-git-tag-version package)))) | ||
| 137 | |||
| 138 | (unless (which (git-command)) (test-skip 1)) | ||
| 139 | (test-equal "latest-git-tag-version: accept pre-releases" | ||
| 140 | "2.0.0-rc1" | ||
| 141 | (with-temporary-git-repository directory | ||
| 142 | '((add "a.txt" "A") | ||
| 143 | (commit "First commit") | ||
| 144 | (tag "2.0.0-rc1" "Release candidate for 2.0.0")) | ||
| 145 | (let ((package (make-package directory "1.0.0" | ||
| 146 | '((accept-pre-releases? . #t))))) | ||
| 147 | (latest-git-tag-version package)))) | ||
| 148 | |||
| 149 | (unless (which (git-command)) (test-skip 1)) | ||
| 150 | (test-equal "latest-git-tag-version: accept pre-releases, and custom prefix" | ||
| 151 | "2.0.0-rc1" | ||
| 152 | (with-temporary-git-repository directory | ||
| 153 | '((add "a.txt" "A") | ||
| 154 | (commit "First commit") | ||
| 155 | (tag "version-2.0.0-rc1" "Release candidate for 2.0.0")) | ||
| 156 | (let ((package (make-package directory "1.0.0" | ||
| 157 | '((accept-pre-releases? . #t) | ||
| 158 | (release-tag-prefix . "version-"))))) | ||
| 159 | (latest-git-tag-version package)))) | ||
| 160 | |||
| 161 | (unless (which (git-command)) (test-skip 1)) | ||
| 162 | (test-equal "latest-git-tag-version: accept pre-releases, and custom suffix" | ||
| 163 | "2.0.0-rc1" | ||
| 164 | (with-temporary-git-repository directory | ||
| 165 | '((add "a.txt" "A") | ||
| 166 | (commit "First commit") | ||
| 167 | (tag "2.0.0-rc1-suffix" "Release candidate for 2.0.0")) | ||
| 168 | (let ((package (make-package directory "1.0.0" | ||
| 169 | '((accept-pre-releases? . #t) | ||
| 170 | (release-tag-suffix . "-suffix"))))) | ||
| 171 | (latest-git-tag-version package)))) | ||
| 172 | |||
| 173 | (unless (which (git-command)) (test-skip 1)) | ||
| 174 | (test-equal "latest-git-tag-version: accept pre-releases, delimiter conflicts with pre-release part" | ||
| 175 | "2.0.0_alpha" | ||
| 176 | (with-temporary-git-repository directory | ||
| 177 | '((add "a.txt" "A") | ||
| 178 | (commit "First commit") | ||
| 179 | (tag "2_0_0_alpha" "Alpha release for 2.0.0")) | ||
| 180 | (let ((package (make-package directory "1.0.0" | ||
| 181 | '((accept-pre-releases? . #t) | ||
| 182 | (release-tag-version-delimiter . "_"))))) | ||
| 183 | (latest-git-tag-version package)))) | ||
| 184 | |||
| 185 | (unless (which (git-command)) (test-skip 1)) | ||
| 186 | (test-equal "latest-git-tag-version: accept pre-releases, and custom suffix and prefix" | ||
| 187 | "2.0.0-alpha" | ||
| 188 | (with-temporary-git-repository directory | ||
| 189 | '((add "a.txt" "A") | ||
| 190 | (commit "First commit") | ||
| 191 | (tag "prefix123-2.0.0-alpha-suffix" "Alpha release for 2.0.0")) | ||
| 192 | (let ((package (make-package directory "1.0.0" | ||
| 193 | '((accept-pre-releases? . #t) | ||
| 194 | (release-tag-prefix . "prefix[0-9]{3}-") | ||
| 195 | (release-tag-suffix . "-suffix"))))) | ||
| 196 | (latest-git-tag-version package)))) | ||
| 197 | |||
| 198 | (unless (which (git-command)) (test-skip 1)) | ||
| 199 | (test-equal "latest-git-tag-version: accept pre-releases, and custom suffix, prefix, and delimiter" | ||
| 200 | "2.0.0-alpha" | ||
| 201 | (with-temporary-git-repository directory | ||
| 202 | '((add "a.txt" "A") | ||
| 203 | (commit "First commit") | ||
| 204 | (tag "prefix123-2-0-0-alpha-suffix" "Alpha release for 2.0.0")) | ||
| 205 | (let ((package (make-package directory "1.0.0" | ||
| 206 | '((accept-pre-releases? . #t) | ||
| 207 | (release-tag-prefix . "prefix[0-9]{3}-") | ||
| 208 | (release-tag-suffix . "-suffix") | ||
| 209 | (release-tag-version-delimiter . "-"))))) | ||
| 210 | (latest-git-tag-version package)))) | ||
| 211 | |||
| 212 | (unless (which (git-command)) (test-skip 1)) | ||
| 213 | (test-equal "latest-git-tag-version: accept pre-releases, no delimiter, and custom suffix, prefix" | ||
| 214 | "2alpha" | ||
| 215 | (with-temporary-git-repository directory | ||
| 216 | '((add "a.txt" "A") | ||
| 217 | (commit "First commit") | ||
| 218 | (tag "prefix123-2alpha-suffix" "Alpha release for version 2")) | ||
| 219 | (let ((package (make-package directory "1.0.0" | ||
| 220 | '((accept-pre-releases? . #t) | ||
| 221 | (release-tag-prefix . "prefix[0-9]{3}-") | ||
| 222 | (release-tag-suffix . "-suffix") | ||
| 223 | (release-tag-version-delimiter . ""))))) | ||
| 224 | (latest-git-tag-version package)))) | ||
| 225 | |||
| 226 | (unless (which (git-command)) (test-skip 1)) | ||
| 227 | (test-equal "latest-git-tag-version: no tags found" | ||
| 228 | #f | ||
| 229 | (with-temporary-git-repository directory | ||
| 230 | '((add "a.txt" "A") | ||
| 231 | (commit "First commit")) | ||
| 232 | (let ((package (make-package directory "1.0.0"))) | ||
| 233 | (latest-git-tag-version package)))) | ||
| 234 | |||
| 235 | (unless (which (git-command)) (test-skip 1)) | ||
| 236 | (test-equal "latest-git-tag-version: no valid tags found" | ||
| 237 | #f | ||
| 238 | (with-temporary-git-repository directory | ||
| 239 | '((add "a.txt" "A") | ||
| 240 | (commit "First commit") | ||
| 241 | (tag "Test" "Test tag")) | ||
| 242 | (let ((package (make-package directory "1.0.0"))) | ||
| 243 | (latest-git-tag-version package)))) | ||
| 244 | |||
| 245 | (test-end "git") | ||
