;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2022 Xinglu Chen <public@yoctocell.xyz>
;;;
;;; 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 repology)
  #:use-module (guix diagnostics)
  #:use-module (guix git-download)
  #:use-module (guix http-client)
  #:use-module (guix i18n)
  #:use-module (guix import json)
  #:use-module (guix import utils)
  #:use-module (guix memoization)
  #:use-module (guix packages)
  #:use-module (guix upstream)
  #:use-module (guix utils)
  #:use-module (ice-9 match)
  #:use-module (json)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-2)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-43)
  #:export (%repology-url
            repology-fetch-info
            repology-latest-release
            %repology-updater))

;;; Commentary:
;;;
;;; This module provides an updater which scans Repology, a site that monitors
;;; several package repolsitories, for updates.  This means that if any other
;;; package repository has a version of a package that is newer than the
;;; version in Guix, the package should be able to be updated.  The updater
;;; should in theory work for all packages in Guix, but the names of some
;;; packages on Repology don't match the name in Guix.  The 'repology-name'
;;; package property can be used to fix this.
;;;
;;; Guix already has many different updaters for language-specific packages,
;;; and these typically provide more accurate data, e.g., input changes,
;;; signature URLs.  The Repology updater should really be treated as a last
;;; resort for those packages that don't have any other updater to rely on.
;;;
;;; See <https://repology.org/api/v1> for the API.
;;;
;;; Code:

(define %repology-url
   "https://repology.org/api/v1/project")

(define* (package-name->repology-name name #:key (attempt 1))
  "Convert NAME, the name of a Guix package, to the name of the package on
Repology.  It doesn't always guess the correct name on the first attempt, so
on the second attempt it will try to guess another name."
  (match attempt
    (1 (cond
        ((string-prefix? "ghc-" name)
         (string-append "haskell:"
                        (string-drop name (string-length "ghc-"))))
        ((string-prefix? "ocaml-" name)
         (string-append "ocaml:"
                        (string-drop name (string-length "ocaml-"))))
        ((string-prefix? "perl-" name)
         (string-append "perl:"
                        (string-drop name (string-length "perl-"))))
        ((string-prefix? "emacs-" name)
         (string-append "emacs:"
                        (string-drop name (string-length "emacs-"))))
        ((string-prefix? "go-" name)
         (string-append "go:"
                        (string-drop name (string-length "go-"))))
        ((string-prefix? "rust-" name)
         (string-append "rust:"
                        (string-drop name (string-length "rust-"))))
        ((string-prefix? "lua-" name)
         (string-append "lua:"
                        (string-drop name (string-length "lua-"))))
        ((string-prefix? "node-" name)
         (string-append "node:"
                        (string-drop name (string-length "node-"))))
        ((string-prefix? "python-" name)
         (string-append "python:"
                        (string-drop name (string-length "python-"))))
        ((string-prefix? "java-" name)
         (string-append "java:"
                        (string-drop name (string-length "java-"))))
        ((string-prefix? "r-" name)
         (string-append "r:"
                        (string-drop name (string-length "r-"))))
        ((string-prefix? "ruby-" name)
         (string-append "ruby:"
                        (string-drop name (string-length "ruby-"))))
        ((string-prefix? "xf86-" name)
         (string-append "xdrv:"
                        (string-drop name (string-length "xf86-"))))
        ((string-prefix? "font-" name)
         (string-append "fonts:"
                        (string-drop name (string-length "font-"))))
        ((string-prefix? "trytond-" name)
         (string-append "tryton:"
                        (string-drop name (string-length "trytond-"))))
        ((string-prefix? "python-trytond-" name)
         (string-append "tryton:"
                        (string-drop name (string-length "python-trytond-"))))
        ((string-suffix? "-minimal" name)
         (string-drop-right name (string-length "-minimal")))        
        (else name)))
    (2 (cond
        ((string-prefix? "xf86-video" name)
         (string-append "xdrv:"
                        (string-drop name (string-length "xf86-video-"))))
        ((string-prefix? "xf86-input" name)
         (string-append "xdrv:"
                        (string-drop name (string-length "xf86-input-"))))
        ((string-prefix? "minetest-" name)
         (string-append "minetest-mod-"
                        (string-drop name (string-length "minetest-"))))
        ((string-prefix? "lib" name)
         (string-drop name (string-length "lib")))
        ((string-prefix? "vim-" name)
         (string-append "vim:"
                        (string-drop name (string-length "vim-"))))
        (else name)))))  

\f
;;; JSON mappings.

(define-json-mapping <repology-package> make-repology-package
  repology-package?
  json->repology-package
  (repository repology-package-repository "repo")
  (src-name repology-package-src-name "srcname")
  (binary-name repology-package-binary-name "binname")
  (visible-name repology-package-visible-name "visiblename")
  (version repology-package-version)
  (original-version repology-package-original-version "origversion")
  (status repology-package-status)
  (summary repology-package-summary)
  (categories repology-package-categories)
  (licenses repology-package-licenses)
  (maintainers repology-package-maintainers))

\f
;;; Updater.

(define repology-fetch-info
  (memoize
   (lambda (package)
     "Fetch information about PACKAGE using the Repology API."
     (define (name->info name)
       (let ((url (string-append %repology-url "/" name)))
         (and=> (json-fetch url #:http-fetch http-fetch/cached)
                (lambda (url)
                  (vector-map (lambda (a b)
                                (json->repology-package b))
                              url)))))
     
     (let* ((name (or (assoc-ref (package-properties package)
                                 'repology-name)
                      (package-name->repology-name (package-name package))))
            (info (name->info name)))
       (if (and info (not (vector-empty? info)))
           info
           (let ((info (name->info (package-name->repology-name
                                    (package-name package)
                                    #:attempt 2))))
             (if (and info (not (vector-empty? info)))
                 info
                 (begin
                   (warning (G_ "package not found on Repology: ~a\n")
                            (package-name package))
                   #f))))))))

(define (update-version string old-version new-version)
  "Replace OLD-VERSION in STRING with NEW-VERSION.  This assumes that STRING
contains OLD-VERSION verbatim; if it doesn't, #f is returned."
  (match (factorize-uri string old-version)
    ((? string?) #f)
    ((factorized ...)
     (apply string-append
            (map (lambda (component)
                   (match component
                     ('version new-version)
                     ((? string?) component)))
                 factorized)))))

(define (package-source-urls package version)
  "Return a list of URLs for PACKAGE at VERSION.  If no URL was successfully constructed, return #f."
  (and-let* ((old-version (package-version package))
             (source (package-source package)))
    ;; XXX: (guix upstream) only supports tarballs and Git repos for now.
    (match (origin-uri source)
      ((? git-reference? reference)
       (and-let* ((old-commit (git-reference-commit reference))
                  (new-commit (if (string=? old-version old-commit)
                                      version
                                      (update-version old-commit
                                                      old-version
                                                      version))))
         (git-reference
          (inherit reference)
          (commit new-commit))))
      ((? string? url)
       (list (update-version url old-version version)))
      ((? list? urls)
       (map (cut update-version <> old-version version) urls))
      (_ #f))))

(define (latest-version? repology-package)
  "Return the latest released version of REPOLOGY-PACKAGE.  If none are found,
return #f."
  (and (or (equal? "newest" (repology-package-status repology-package))
           (equal? "unique" (repology-package-status repology-package)))
       (repology-package-version repology-package)))

;; XXX: We use 'pkg' because 'package' will clash with the 'package' field of
;; 'upstream-source'.
(define (repology-latest-release pkg)
  "Return the latest release of the PKG on Repology named NAME."
  (and-let* ((packages (repology-fetch-info pkg))
             (versions (filter-map latest-version?
                                   (vector->list packages)))
             (latest-version (and (pair? versions) (car versions))))
    ;; TODO: set 'signature-urls'.
    (upstream-source
     (package (package-name pkg))
     (version latest-version)
     (urls (package-source-urls pkg latest-version)))))

(define %repology-updater
  (upstream-updater
   (name 'repology)
   (description "Updater for packages on Repology")
   (pred (const #t))
   (latest repology-latest-release)))

;;; repology.scm ends here