;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu>
;;; Copyright © 2023, 2024 Nicolas Graves <ngraves@ngraves.fr>
;;;
;;; 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 composer)
  #:use-module (ice-9 match)
  #:use-module (json)
  #:use-module (guix build-system composer)
  #:use-module ((guix diagnostics) #:select (warning))
  #:use-module ((guix import git) #:select (latest-git-tag-version))
  #:use-module ((guix git-download) #:select (git-reference))
  #:use-module ((guix download) #:select (download-to-store))
  #:use-module (guix hash)
  #:use-module (guix i18n)
  #:use-module (guix import json)
  #:use-module (guix import utils)
  #:use-module ((guix licenses) #:prefix license:)
  #:use-module (guix memoization)
  #:use-module (guix packages)
  #:use-module (guix store)
  #:use-module (guix upstream)
  #:use-module (guix utils)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-71)
  #:export (composer->guix-package
            %composer-updater
            composer-recursive-import

            %packagist-base-url))

(define %packagist-base-url
  (make-parameter "https://repo.packagist.org"))

(define (fix-version version)
  "Return a fixed version from a version string.  For instance, v10.1 -> 10.1"
  (cond
    ((string-prefix? "version" version)
     (if (char-set-contains? char-set:digit (string-ref version 7))
         (substring version 7)
         (substring version 8)))
    ((string-prefix? "v" version)
     (substring version 1))
    (else version)))

(define (requirements->prefixes str)
  (let* ((processed-str (string-replace-substring str " || " "|"))
         (prefix-strs (string-split processed-str #\|)))
    (filter-map (match-lambda
                  ;; SemVer: ^ indicates major+minor match, not a whole match.
                  ((? (cut string-prefix? "^" <>) prefix)
                   (let ((pfx (string-drop prefix 1)))
                     (if (eq? 2 (string-count prefix #\.))
                         (string-take pfx (string-rindex pfx #\.))
                         pfx)))
                  ((? (cut string-suffix? ".*" <>) prefix)
                   (string-drop-right prefix 2))
                  (_ #f))
         prefix-strs)))

(define (json->require dict)
  (if (and dict (not (unspecified? dict)))
      (filter-map
       (match-lambda
         (((? (cut string-contains <> "/") name) . requirements)
          (list name (requirements->prefixes requirements)))
         (_
          #f))
       dict)
      '()))

(define-json-mapping <composer-source> make-composer-source composer-source?
  json->composer-source
  (type      composer-source-type)
  (url       composer-source-url "url"
             (lambda (uri)
               (if (string-suffix? ".git" uri)
                   (string-drop-right uri 4)
                   uri)))
  (reference composer-source-reference))

(define-json-mapping <composer-package> make-composer-package composer-package?
  json->composer-package
  (description composer-package-description)
  (homepage    composer-package-homepage)
  (source      composer-package-source "source" json->composer-source)
  (name        composer-package-name "name" php-package-name)
  (version     composer-package-version "version" fix-version)
  (require     composer-package-require "require" json->require)
  (dev-require composer-package-dev-require "require-dev" json->require)
  (license     composer-package-license "license"
               (lambda (vector)
                 (let ((l (map string->license (vector->list vector))))
                   (if (eq? (length l) 1)
                       (car l)
                       `(list ,@l))))))

(define (valid-version? v)
  (let ((d (string-downcase v)))
    (and (not (string-contains d "dev"))
         (not (string-contains d "beta"))
         (not (string-contains d "rc")))))

(define* (select-version packages #:key (min-version #f))
  "Select the most recent available version in the PACKAGES list
that is above or equal to MIN-VERSION. MIN-VERSION can be incomplete
(e.g. version-major only)."
  (let* ((points (and min-version (string-count min-version #\.)))
         (min-prefix (and min-version
                          (match points
                            ((or 0 1) (fix-version min-version))
                            (_ #f)))))
    (cdr
     (fold
      (lambda (new cur-max)
        (match new
          (((? valid-version? version) . tail)
           (let ((valid-version (fix-version version)))
             (if (and (version>? valid-version (fix-version (car cur-max)))
                      (or (not min-prefix)
                          (version-prefix? min-prefix valid-version)))
                 (cons* version tail)
                 cur-max)))
          (_ cur-max)))
      (cons* "0.0.0" #f)
      packages))))

(define* (composer-fetch name #:key (version #f))
  "Return a composer-package representation of the Composer metadata for the
package NAME with optional VERSION, or #f on failure."
  (let* ((url (string-append (%packagist-base-url) "/p/" name ".json"))
         (packages (and=> (json-fetch url)
                          (lambda (pkg)
                            (let ((pkgs (assoc-ref pkg "packages")))
                              (or (assoc-ref pkgs name) pkg))))))
    (and packages
        (let ((v (assoc-ref packages version)))
          (and=>
           (or (and v (not (unspecified? v)) v)
               (select-version packages #:min-version version))
         json->composer-package)))))

(define (php-package-name name)
  "Given the NAME of a package on Packagist, return a Guix-compliant name for
the package."
  (let ((name (string-join (string-split name #\/) "-")))
    (if (string-prefix? "php-" name)
        (snake-case name)
        (string-append "php-" (snake-case name)))))

(define (make-php-sexp composer-package)
  "Return the `package' s-expression for a PHP package for the given
COMPOSER-PACKAGE."
  (let* ((source (composer-package-source composer-package))
         (dependencies (map (compose php-package-name car)
                            (composer-package-require composer-package)))
         (dev-dependencies (map (compose php-package-name car)
                                (composer-package-dev-require composer-package))))
    `(package
       (name ,(composer-package-name composer-package))
       (version ,(composer-package-version composer-package))
       (source
        ,(if (string= (composer-source-type source) "git")
             (git->origin (composer-source-url source)
                          `(tag-or-commit . ,(composer-source-reference source)))
             (let* ((source (composer-source-url source))
                    (tarball (with-store store (download-to-store store source))))
               `(origin
                  (method url-fetch)
                  (uri ,source)
                  (sha256 (base32 ,(guix-hash-url tarball)))))))
       (build-system composer-build-system)
       ,@(if (null? dependencies)
             '()
             `((inputs
                (list ,@(map string->symbol dependencies)))))
       ,@(if (null? dev-dependencies)
             '()
             `((native-inputs
                (list ,@(map string->symbol dev-dependencies)))))
       (synopsis "")
       (description ,(composer-package-description composer-package))
       (home-page ,(composer-package-homepage composer-package))
       (license ,(or (composer-package-license composer-package)
                     'unknown-license!)))))

(define composer->guix-package
  (memoize
   (lambda* (package-name #:key (version #f) #:allow-other-keys)
     "Fetch the metadata for PACKAGE-NAME from packagist.org, and return the
`package' s-expression corresponding to that package and its list of
dependencies, or #f and the empty list on failure."
     (let ((package (composer-fetch package-name #:version version)))
       (if package
           (values (make-php-sexp package)
                   (append-map
                    (match-lambda
                      ((head . tail)
                       (cons head (car tail)))
                      (_ #f))
                    (list (composer-package-require package)
                          (composer-package-dev-require package))))
           (values #f '()))))))

(define (guix-name->composer-name name)
  "Given a guix package name, return the name of the package in Packagist."
  (if (string-prefix? "php-" name)
      (let ((components (string-split (substring name 4) #\-)))
        (match components
          ((namespace name ...)
           (string-append namespace "/" (string-join name "-")))))
      name))

(define (guix-package->composer-name package)
  "Given a Composer PACKAGE built from Packagist, return the name of the
package in Packagist."
  (or (assoc-ref (package-properties package) 'upstream-name)
      (guix-name->composer-name (package-name package))))

(define (string->license str)
  "Convert the string STR into a license object."
  (or (spdx-string->license str)
      (match str
        ("GNU LGPL" 'license:lgpl2.0)
        ("GPL" 'license:gpl3)
        ((or "BSD" "BSD License") 'license:bsd-3)
        ((or "MIT" "MIT license" "Expat license") 'license:expat)
        ("Public domain" 'license:public-domain)
        ((or "Apache License, Version 2.0" "Apache 2.0") 'license:asl2.0)
        (_ 'unknown-license!))))

(define (php-package? package)
  "Return true if PACKAGE is a PHP package from Packagist."
  (and
   (eq? (package-build-system package) composer-build-system)
   (or (string-prefix? "php-" (package-name package))
       (string=? "phpunit" (package-name package)))))

(define (dependency->input dependency type)
  (let* ((version (fix-version (caadr dependency)))
         (points (and version (string-count version #\.)))
         (max "99"))
    (upstream-input
     (name (car dependency))
     (downstream-name (php-package-name (car dependency)))
     (type type)
     (min-version (match points
                    (0 (string-append version ".0.0"))
                    (1 (string-append version ".0"))
                    (2 version)
                    (_ 'any)))
     (max-version (match points
                    (0 (string-append version "." max "." max))
                    (1 (string-append version "." max))
                    (2 version)
                    (_ 'any))))))

(define* (import-release package #:key (version #f))
  "Return an <upstream-source> for VERSION or the latest release of PACKAGE."
  (let* ((php-name (guix-package->composer-name package))
         (composer-package (composer-fetch php-name #:version version))
         (new-version new-version-tag
                      (latest-git-tag-version package #:version version)))
    (if composer-package
        (upstream-source
         (package (composer-package-name composer-package))
         (version (composer-package-version composer-package))
         (urls
          (let ((source (composer-package-source composer-package)))
            (if (string=? (composer-source-type source) "git")
                (git-reference
                 (url (composer-source-url source))
                 (commit (or new-version-tag
                             (composer-source-reference source))))
                (list (composer-source-url source)))))
         (inputs (append
                  (map (cut dependency->input <> 'regular)
                       (composer-package-require composer-package))
                  (map (cut dependency->input <> 'native)
                       (composer-package-dev-require composer-package)))))
        (begin
          (warning (G_ "failed to parse ~a~%") php-name)
          #f))))

(define %composer-updater
  (upstream-updater
   (name 'composer)
   (description "Updater for Composer packages")
   (pred php-package?)
   (import import-release)))

(define* (composer-recursive-import package-name #:optional version)
  (recursive-import package-name
                    #:version version
                    #:repo->guix-package composer->guix-package
                    #:guix-name php-package-name))