;;; 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 build composer-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build utils)
  #:use-module (ice-9 match)
  #:use-module (json)
  #:use-module (srfi srfi-26)
  #:export (%standard-phases
            composer-build))

;; Commentary:
;;
;; Builder-side code of the standard composer build procedure.
;;
;; Code:

(define (json->require dict)
  (if dict
      (let loop ((result '()) (require dict))
        (match require
          (() result)
          ((((? (cut string-contains <> "/") name) . _)
             require ...)
           (loop (cons name result) require))
          ((_ require ...) (loop result require))))
      '()))

(define-json-mapping <composer-autoload> make-composer-autoload composer-autoload?
  json->composer-autoload
  (psr-4 composer-autoload-psr-4 "psr-4"
                (match-lambda
                  (#f '())
                  (psr-4 psr-4)))
  (classmap composer-autoload-classmap "classmap"
            (match-lambda
              (#f '())
              (#(lst ...) lst))))

(define-json-mapping <composer-package> make-composer-package composer-package?
  json->composer-package
  (name         composer-package-name)
  (autoload     composer-package-autoload "autoload" json->composer-autoload)
  (autoload-dev composer-package-autoload-dev "autoload-dev" json->composer-autoload)
  (require      composer-package-require "require" json->require)
  (dev-require  composer-package-dev-require "require-dev" json->require)
  (scripts      composer-package-scripts "scripts"
                (match-lambda
                  (#f '())
                  ((scripts ...) scripts)))
  (binaries     composer-package-binaries "bin"
                (match-lambda
                  (#f '())
                  (#(lst ...) lst))))

(define* (read-package-data #:key (filename "composer.json"))
  (call-with-input-file filename
    (lambda (port)
      (json->composer-package (json->scm port)))))

(define* (check #:key composer-file inputs outputs tests? test-target #:allow-other-keys)
  "Test the given package."
  (when tests?
    (mkdir-p "vendor")
    (create-autoload (string-append (getcwd) "/vendor") composer-file
                     (append inputs outputs) #:dev-dependencies? #t)
    (let* ((package-data (read-package-data #:filename composer-file))
           (scripts (composer-package-scripts package-data))
           (test-script (assoc-ref scripts test-target))
           (dependencies (composer-package-require package-data))
           (dependencies-dev (composer-package-dev-require package-data))
           (name (composer-package-name package-data)))
      (for-each
        (match-lambda
          ((_ . input)
           (let ((bin (find-php-bin input)))
             (when bin
               (copy-recursively bin "vendor/bin")))))
        inputs)
      (match test-script
        ((? string? command)
         (unless (zero? (system command))
           (throw 'failed-command command)))
        (('@ (? string? command) ...)
         (for-each
           (lambda (c)
             (unless (zero? (system c))
               (throw 'failed-command c)))
           command))
        (#f (invoke "vendor/bin/phpunit"))))))

(define (find-php-bin input)
  (let* ((web-dir (string-append input "/share/web"))
         (vendors (if (file-exists? web-dir)
                      (find-files web-dir "^vendor$" #:directories? #t)
                      #f)))
    (match vendors
      ((vendor)
       (let ((bin (string-append vendor "/bin")))
         (and (file-exists? bin) bin)))
      (_ #f))))

(define (find-php-dep inputs dependency)
  (let loop ((inputs inputs))
    (match inputs
      (() (throw 'unsatisfied-dependency "Unsatisfied dependency: required "
                 dependency))
      (((_ . input) inputs ...)
       (let ((autoload (string-append input "/share/web/" dependency
                                      "/vendor/autoload_conf.php")))
          (if (file-exists? autoload)
              autoload
              (loop inputs)))))))

(define* (create-autoload vendor composer-file inputs #:key dev-dependencies?)
  "creates an autoload.php file that sets up the class locations for this package,
so it can be autoloaded by PHP when the package classes are required."
  (with-output-to-file (string-append vendor "/autoload.php")
    (lambda _
      (display (string-append
                 "<?php
// autoload.php @generated by Guix
$map = $psr4map = $classmap = array();
require_once '" vendor "/autoload_conf.php'
require_once '" (assoc-ref inputs "composer-classloader") "/share/web/composer/ClassLoader.php'
$loader = new \\Composer\\Autoload\\ClassLoader();
foreach ($map as $namespace => $path) {
  $loader->set($namespace, $path);
}
foreach ($psr4map as $namespace => $path) {
  $loader->setPsr4($namespace, $path);
}
$loader->addClassMap($classmap);
$loader->register();
"))))
  ;; Now, create autoload_conf.php that contains the actual data, as a set
  ;; of arrays
  (let* ((package-data (read-package-data #:filename composer-file))
         (autoload (composer-package-autoload package-data))
         (autoload-dev (composer-package-autoload-dev package-data))
         (dependencies (composer-package-require package-data))
         (dependencies-dev (composer-package-dev-require package-data)))
    (with-output-to-file (string-append vendor "/autoload_conf.php")
      (lambda _
        (format #t "<?php~%")
        (format #t "// autoload_conf.php @generated by Guix~%")
        (force-output)
        (for-each
          (lambda (psr4)
            (match psr4
              ((key . value)
               (format #t "$psr4map['~a'] = '~a/../~a';~%"
                       (string-join (string-split key #\\) "\\\\")
                       vendor value))))
          (append
            (composer-autoload-psr-4 autoload)
            (if dev-dependencies?
                (composer-autoload-psr-4 autoload-dev)
                '())))
        (for-each
          (lambda (classmap)
            (for-each
              (lambda (file)
                (invoke "php" (assoc-ref inputs "findclass.php")
                        "-i" (string-append vendor "/..") "-f" file))
              (find-files classmap ".(php|hh|inc)$")))
          (append
            (composer-autoload-classmap autoload)
            (if dev-dependencies?
                (composer-autoload-classmap autoload-dev)
                '())))
        (for-each
          (lambda (dep)
            (format #t "require_once '~a';~%" (find-php-dep inputs dep)))
          (append
            dependencies
            (if dev-dependencies?
                dependencies-dev
                '())))))))

(define* (install #:key inputs outputs composer-file #:allow-other-keys)
  "Install the given package."
  (let* ((out (assoc-ref outputs "out"))
         (package-data (read-package-data #:filename composer-file))
         (name (composer-package-name package-data))
         (php-dir (string-append out "/share/web/" name))
         (bin-dir (string-append php-dir "/vendor/bin"))
         (bin (string-append out "/bin"))
         (binaries (composer-package-binaries package-data)))
      (mkdir-p php-dir)
      (copy-recursively "." php-dir)
      (mkdir-p (string-append php-dir "/vendor"))
      (when binaries
        (mkdir-p bin-dir)
        (mkdir-p bin)
        (for-each
          (lambda (file)
            (let ((installed-file (string-append bin-dir "/" (basename file)))
                  (bin-file (string-append bin "/" (basename file)))
                  (original-file (string-append php-dir "/" file)))
              (symlink original-file installed-file)
              (symlink original-file bin-file)))
          binaries))
      (create-autoload (string-append php-dir "/vendor")
                       composer-file inputs)))

(define %standard-phases
  ;; Everything is as with the GNU Build System except for the `configure'
  ;; , `build', `check' and `install' phases.
  (modify-phases gnu:%standard-phases
    (delete 'bootstrap)
    (delete 'configure)
    (delete 'build)
    (delete 'check)
    (replace 'install install)
    (add-after 'install 'check check)))

(define* (composer-build #:key inputs (phases %standard-phases)
                         #:allow-other-keys #:rest args)
  "Build the given package, applying all of PHASES in order."
  (apply gnu:gnu-build #:inputs inputs #:phases phases args))

;;; composer-build-system.scm ends here