;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu>
;;;
;;; 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 (gcrypt hash)
  #:use-module (guix base32)
  #:use-module (guix build git)
  #:use-module (guix build utils)
  #:use-module (guix build-system)
  #:use-module (guix import json)
  #:use-module (guix import utils)
  #:use-module ((guix licenses) #:prefix license:)
  #:use-module (guix packages)
  #:use-module (guix serialization)
  #:use-module (guix upstream)
  #:use-module (guix utils)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:export (composer->guix-package
            %composer-updater
            composer-recursive-import))

;; XXX adapted from (guix scripts hash)
(define (file-hash file select? recursive?)
  ;; Compute the hash of FILE.
  (if recursive?
      (let-values (((port get-hash) (open-sha256-port)))
        (write-file file port #:select? select?)
        (force-output port)
        (get-hash))
      (call-with-input-file file port-sha256)))

;; XXX taken from (guix scripts hash)
(define (vcs-file? file stat)
  (case (stat:type stat)
    ((directory)
     (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
    ((regular)
     ;; Git sub-modules have a '.git' file that is a regular text file.
     (string=? (basename file) ".git"))
    (else
     #f)))

(define (latest-version versions)
  (fold (lambda (a b) (if (version>? a b) a b)) (car versions) versions))

(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* (composer-fetch name #:optional version)
  "Return an alist representation of the Composer metadata for the package NAME,
or #f on failure."
  (let ((package (json-fetch
                   (string-append "https://repo.packagist.org/p/" name ".json"))))
    (if package
        (let* ((packages (assoc-ref package "packages"))
               (package (assoc-ref packages name))
               (versions (filter
                           (lambda (version)
                             (and (not (string-contains version "dev"))
                                  (not (string-contains version "beta"))))
                           (map car package)))
               (versions (map
                           (lambda (version)
                             (cons (fix-version version) version))
                           versions))
               (version (or (if (null? version) #f version)
                            (latest-version (map car versions)))))
          (assoc-ref package (assoc-ref versions version)))
        #f)))

(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 name version home-page description dependencies
                       dev-dependencies licenses source)
  "Return the `package' s-expression for a PHP package with the given NAME,
VERSION, HOME-PAGE, DESCRIPTION, DEPENDENCIES, LICENSES and SOURCE."
  (let ((git? (equal? (assoc-ref source "type") "git")))
    ((if git? call-with-temporary-directory call-with-temporary-output-file)
     (lambda* (temp #:optional port)
       (and (if git?
                (begin
                  (mkdir-p temp)
                  (git-fetch (assoc-ref source "url")
                             (assoc-ref source "reference")
                             temp))
                (url-fetch (assoc-ref source "url") temp))
            `(package
               (name ,(php-package-name name))
               (version ,version)
               (source (origin
                         ,@(if git?
                               `((method git-fetch)
                                 (uri (git-reference
                                        (url ,(assoc-ref source "url"))
                                        (commit ,(assoc-ref source "reference"))))
                                 (file-name (git-file-name name version))
                                 (sha256
                                   (base32
                                     ,(bytevector->nix-base32-string
                                       (file-hash temp (negate vcs-file?) #t)))))
                               `((method url-fetch)
                                 (uri ,(assoc-ref source "url"))
                                 (sha256 (base32 ,(guix-hash-url temp)))))))
               (build-system composer-build-system)
               ,@(if (null? dependencies)
                     '()
                     `((inputs
                        (,'list
                         ,@(map (lambda (name)
                                 `,(string->symbol name))
                               dependencies)))))
               ,@(if (null? dev-dependencies)
                     '()
                     `((native-inputs
                        (,'list
                         ,@(map (lambda (name)
                                 `,(string->symbol name))
                               dev-dependencies)))))
               (synopsis "")
               (description ,description)
               (home-page ,home-page)
               (license ,(match licenses
                           (() #f)
                           ((license) (license->symbol license))
                           (_ `(list ,@(map license->symbol licenses)))))))))))

(define* (composer->guix-package package-name #:optional version)
  "Fetch the metadata for PACKAGE-NAME from packagist.org, and return the
`package' s-expression corresponding to that package, or #f on failure."
  (let ((package (composer-fetch package-name version)))
    (and package
         (let* ((name         (assoc-ref package "name"))
                (version      (fix-version (assoc-ref package "version")))
                (description  (beautify-description
                               (assoc-ref package "description")))
                (home-page    (assoc-ref package "homepage"))
                (dependencies-names (filter
                                      (lambda (dep)
                                        (string-contains dep "/"))
                                      (map car (assoc-ref package "require"))))
                (dependencies (map php-package-name dependencies-names))
                (require-dev (assoc-ref package "require-dev"))
                (dev-dependencies-names
                  (if require-dev
                      (filter
                        (lambda (dep)
                          (string-contains dep "/"))
                        (map car require-dev))
                      '()))
                (dev-dependencies (map php-package-name dev-dependencies-names))
                (licenses     (map string->license
                                   (vector->list
                                    (assoc-ref package "license")))))
           (values (make-php-sexp name version home-page description dependencies
                                  dev-dependencies licenses (assoc-ref package "source"))
                   (append dependencies-names dev-dependencies-names))))))

(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."
  (let ((upstream-name (assoc-ref
                         (package-properties package)
                         'upstream-name))
        (name (package-name package)))
    (if upstream-name
      upstream-name
      (guix-name->composer-name name))))

(define (string->license str)
  "Convert the string STR into a license object."
  (match str
    ("GNU LGPL" license:lgpl2.0)
    ("GPL" license:gpl3)
    ((or "BSD" "BSD License" "BSD-3-Clause") 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)
    (_ #f)))

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

(define (latest-release package)
  "Return an <upstream-source> for the latest release of PACKAGE."
  (let* ((php-name (guix-package->composer-name package))
         (metadata (composer-fetch php-name))
         (version (fix-version (assoc-ref metadata "version")))
         (url (assoc-ref (assoc-ref metadata "source") "url")))
    (upstream-source
     (package (package-name package))
     (version version)
     (urls (list url)))))

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

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