;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
;;;
;;; 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 <http://www.gnu.org/licenses/>.

(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 format)
  #: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-34)
  #:use-module (srfi srfi-35)
  #: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-no-valid-tags-error &error
  git-no-valid-tags-error?)

(define (git-no-valid-tags-error)
  (raise (condition (&message (message "no valid tags found"))
                    (&git-no-valid-tags-error))))

(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))))


;;; Updater

(define %pre-release-words
  '("alpha" "beta" "rc" "dev" "test"))

(define* (get-version-mapping tags #:key prefix suffix delim pre-releases?)
  (define (guess-delim)
    (let ((total (length tags))
          (dots (reduce + 0 (map (cut string-count <> #\.) tags)))
          (dashes (reduce + 0 (map (cut string-count <> #\-) tags)))
          (underscores (reduce + 0 (map (cut string-count <> #\_) tags))))
      (display (format #t "total: ~d, dots: ~d, dashes ~d, underscores ~d~%"
              total dots dashes underscores))
      (cond
       ((>= dots (* total 0.35)) ".")
       ((>= dashes (* total 0.8)) "-")
       ((>= underscores (* total 0.8)) "_")
       (else ""))))

  (define delim-rx (regexp-quote (or delim (guess-delim))))
  (define suffix-rx
    (string-append
     (or suffix
         (if pre-releases?
             (string-append ".*(" (string-join %pre-release-words "|") ").*")
             ""))
     "$"))
  
  (define prefix-rx (string-append "^" (or prefix "[^[:digit:]]*")))
  (pk delim-rx)

  (define tag-rx
     (string-append "([[:digit:]][^" delim-rx "[:punct:]]*"
                    "(" delim-rx "[^[:punct:]" delim-rx "]+)"
                    ;; If there is are no delimiters, it could mean that the
                    ;; version just contains one number (e.g., "2"), thus, use
                    ;; "*" instead of "+" to match zero or more numbers.
                    (if (string=? delim-rx "") "*" "+")
                    ")" suffix-rx))

  (define (get-version tag)
    (let ((tag-match (regexp-exec (make-regexp tag-rx) tag)))
      (pk tag)
      (pk tag-match)
      (pk tag-rx)
      (and tag-match
           (regexp-exec (make-regexp prefix-rx) (match:prefix tag-match))
           (regexp-substitute/global
            #f delim-rx (match:substring tag-match)
            ;; Don't insert "." if there aren't any delimiters in the first
            ;; place.
            'pre (if (string=? delim-rx "") "" ".") 'post))))

  (define (entry<? a b)
    (eq? (version-compare (car a) (car b)) '<))

  (let ((mapping (fold alist-cons '() (map get-version tags) tags)))
    (stable-sort! (filter car mapping) entry<?)))

(define* (get-latest-tag url #:key prefix suffix delim pre-releases?)
  "Return the latest tag available from the Git repository at URL."
  (define (pre-release? tag)
    (any (lambda (rx) (regexp-exec (make-regexp rx regexp/icase) tag))
              %pre-release-words))

  (let* ((tags (map (cut string-drop <> (string-length "refs/tags/"))
                    (ls-remote-refs url #:tags? #t)))
         (versions->tags
          (get-version-mapping (if pre-releases?
                                   tags
                                   (filter (negate pre-release?) tags))
                               #:prefix prefix
                               #:suffix suffix
                               #:delim delim
                               #:pre-releases? pre-releases?)))
    (display versions->tags)
    (newline)
    (cond
     ((null? tags)
      (git-no-tags-error))
     ((null? versions->tags)
      (git-no-valid-tags-error))
     (else
      (match (last versions->tags)
        ((version . tag)
         (values version tag)))))))

(define (latest-git-tag-version package tag-prefix tag-suffix
                                tag-version-delimiter refresh-pre-releases?)
  "Given a PACKAGE, the TAG-PREFIX, TAG-SUFFIX, TAG-VERSION-DELIMITER, and
REFRESH-PRE-RELEASES?  properties of PACKAGE, returns the latest version of
PACKAGE."
  (guard (c ((or (git-no-tags-error? c) (git-no-valid-tags-error? c))
             (warning (or (package-field-location package 'source)
                          (package-location package))
                      (G_ "~a for ~a~%")
                      (condition-message c)
                      (package-name package))
             #f)
            ((eq? (exception-kind c) 'git-error)
             (warning (or (package-field-location package 'source)
                          (package-location package))
                      (G_ "failed to fetch Git repository for ~a~%")
                      (package-name package))
             #f))
    (let* ((source (package-source package))
           (url (git-reference-url (origin-uri source))))
      ;;(format #t "~a~%" (package-name package))
      (get-latest-tag url #:prefix tag-prefix #:suffix tag-suffix
                      #:delim tag-version-delimiter
                      #:pre-releases? refresh-pre-releases?))))

(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))
         (refresh-pre-releases? (assq-ref properties 'refresh-pre-releases?))
         (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
                                              refresh-pre-releases?)))

    (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)))