;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2021 Xinglu Chen ;;; ;;; This file is part of GNU Guix. ;;; ;;; GNU Guix is free software; you can redistribute it and/or modify it ;;; under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or (at ;;; your option) any later version. ;;; ;;; GNU Guix is distributed in the hope that it will be useful, but ;;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with GNU Guix. If not, see . (define-module (guix import git) #:use-module (guix build utils) #:use-module (guix diagnostics) #:use-module (guix git) #:use-module (guix git-download) #:use-module (guix i18n) #:use-module (guix packages) #:use-module (guix upstream) #:use-module (guix utils) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-28) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (srfi srfi-71) #:export (%generic-git-updater)) ;;; Commentary: ;;; ;;; This module provides a generic package updater for packages hosted on Git ;;; repositories. ;;; ;;; It tries to be smart about tag names, but if it is not automatically able ;;; to parse the tag names correctly, users can set the `tag-prefix', ;;; `tag-suffix' and `tag-version-delimiter' properties of the package to make ;;; the updater parse the Git tag name correctly. ;;; ;;; Code: ;;; Errors & warnings (define-condition-type &git-tag-error &error git-tag-error? (kind git-tag-error-kind)) (define (git-tag-error kind) (raise (condition (&message (message (format "bad `~a' property"))) (&git-tag-error (kind kind))))) (define (git-tag-warning package c) (warning (package-location package) (G_ "~a for package `~a'~%") (condition-message c) (package-name package))) (define-condition-type &git-no-tags-error &error git-no-tags-error?) (define (git-no-tags-error) (raise (condition (&message (message "no tags were found")) (&git-no-tags-error)))) (define (git-no-tags-warning package c) (warning (package-location package) (G_ "~a for package `~a'~%") (condition-message c) (package-name package))) (define (git-fetch-warning package) (warning (package-location package) (G_ "failed to fetch Git repository for package `~a'~%") (package-name package))) ;;; Helper functions (define (string-split* str delim) "Like `string-split', but DELIM is a string instead of a char-set." (filter (lambda (str) (not (equal? str ""))) (string-split str (string->char-set delim)))) (define* (get-version package tag #:key prefix suffix delim) (define delim* (if delim delim ".")) (define prefix-regexp "^[^0-9]*") (define suffix-regexp (string-append "[^0-9" (regexp-quote delim*) "]*$")) (define delim-regexp (string-append "^[0-9]+" (regexp-quote delim*) "[0-9]+")) (define no-prefix (let ((match (string-match (or prefix prefix-regexp) tag))) (if match (regexp-substitute #f match 'post) (git-tag-error 'tag-prefix)))) (define no-suffix (let ((match (string-match (or suffix suffix-regexp) no-prefix))) (if match (regexp-substitute #f match 'pre) (git-tag-error 'tag-suffix)))) (define no-delims (if (string-match delim-regexp no-suffix) (string-split* no-suffix delim*) (git-tag-error 'tag-version-delimiter))) (string-join no-delims ".")) (define (sort-tags tags) "Sort TAGS, a list if Git tags, such that the latest tag is the last element." (sort tags (lambda (a b) (eq? (version-compare a b) '<)))) ;;; Updater (define (get-latest-tag url) "Return the latest tag available from the Git repository at URL." (let ((tags (map (cut string-drop <> (string-length "refs/tags/")) (ls-remote-refs url #:tags? #t)))) (if (null? tags) (git-no-tags-error) (last (sort-tags tags))))) (define (latest-git-tag-version package tag-prefix tag-suffix tag-version-delimiter) "Given a PACKAGE, the TAG-PREFIX, TAG-SUFFIX, and TAG-VERSION-DELIMITER properties of PACKAGE, returns the latest version of PACKAGE." (guard (c ((eq? (exception-kind c) 'git-error) (git-fetch-warning package) #f) ((git-tag-error? c) (git-tag-warning package c) #f) ((git-no-tags-error? c) (git-no-tags-warning package c) #f)) (let* ((source (package-source package)) (git-uri (origin-uri source)) (url (git-reference-url (origin-uri source))) (latest-tag (get-latest-tag url))) (get-version package latest-tag #:prefix tag-prefix #:suffix tag-suffix #:delim tag-version-delimiter)))) (define (git-package? package) "Whether the origin of PACKAGE is a Git repostiory." (match (package-source package) ((? origin? origin) (and (eq? (origin-method origin) git-fetch) (git-reference? (origin-uri origin)))) (_ #f))) (define (latest-git-release package) "Return the latest release of PACKAGE." (let* ((name (package-name package)) (properties (package-properties package)) (tag-prefix (assq-ref properties 'tag-prefix)) (tag-suffix (assq-ref properties 'tag-suffix)) (tag-version-delimiter (assq-ref properties 'tag-version-delimiter)) (old-version (package-version package)) (url (git-reference-url (origin-uri (package-source package)))) (new-version (latest-git-tag-version package tag-prefix tag-suffix tag-version-delimiter))) (if new-version (upstream-source (package name) (version new-version) (urls (list url))) ;; No new release or no tags available. #f))) (define %generic-git-updater (upstream-updater (name 'generic-git) (description "Updater for packages hosted on Git repositories") (pred git-package?) (latest latest-git-release)))