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

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

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

(define* (check #:key composer-file inputs outputs tests? test-target #:allow-other-keys)
  "Install 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 (match (assoc-ref package-data "scripts")
                      (('@ script ...) script)
                      (#f '())))
           (test-script
             (assoc-ref scripts test-target))
           (dependencies (filter (lambda (dep) (string-contains dep "/"))
                                 (map car
                                      (match (assoc-ref package-data "require")
                                        (('@ dependency ...) dependency)
                                        (#f '())))))
           (dependencies-dev
             (filter (lambda (dep) (string-contains dep "/"))
                     (map car
                          (match (assoc-ref package-data "require-dev")
                            (('@ dependency ...) dependency)
                            (#f '())))))
           (name (assoc-ref package-data "name")))
      (for-each
        (lambda (input)
          (let ((bin (find-php-bin (cdr input))))
            (when bin
              (copy-recursively bin "vendor/bin"))))
        inputs)
      (match test-script
        ((? string? command)
         (unless (equal? (system command) 0)
           (throw 'failed-command command)))
        (('@ (? string? command) ...)
         (for-each
           (lambda (c)
             (unless (equal? (system c) 0)
               (throw 'failed-command c)))
           command))
        (#f (invoke "vendor/bin/phpunit")))))
  #t)

(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 (map cdr inputs)))
    (if (null? inputs)
        (throw 'unsatisfied-dependency "Unsatisfied dependency: required " dependency)
        (let ((autoload (string-append (car inputs) "/share/web/" dependency "/vendor/autoload_conf.php")))
          (if (file-exists? autoload)
              autoload
              (loop (cdr inputs)))))))

(define* (create-autoload vendor composer-file inputs #:key dev-dependencies?)
  (with-output-to-file (string-append vendor "/autoload.php")
    (lambda _
      (display "<?php
// autoload.php @generated by Guix
$map = $psr4map = $classmap = array();
")
      (format #t "require_once '~a/autoload_conf.php'~%" vendor)
      (format #t "require_once '~a/share/web/composer/ClassLoader.php'~%"
              (assoc-ref inputs "composer-classloader"))
      (display "$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();
")))
  (let* ((package-data (read-package-data #:filename composer-file))
         (autoload
           (match (assoc-ref package-data "autoload")
             (('@ autoload ...) autoload)
             (#f '())))
         (autoload-dev
           (match (assoc-ref package-data "autoload-dev")
             (('@ autoload-dev ...) autoload-dev)
             (#f '())))
         (dependencies (filter (lambda (dep) (string-contains dep "/"))
                               (map car
                                    (match (assoc-ref package-data "require")
                                      (('@ dependency ...) dependency)
                                      (#f '())))))
         (dependencies-dev
           (filter (lambda (dep) (string-contains dep "/"))
                   (map car
                        (match (assoc-ref package-data "require-dev")
                          (('@ dependency ...) dependency)
                          (#f '()))))))
    (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
            (match (assoc-ref autoload "psr-4")
              (('@ psr4 ...) psr4)
              (#f '()))
            (if dev-dependencies?
                (match (assoc-ref autoload-dev "psr-4")
                  (('@ psr4 ...) psr4)
                  (#f '()))
                '())))
        (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
            (or (assoc-ref autoload "classmap") '())
            (if dev-dependencies?
                (or (assoc-ref autoload-dev "classmap") '())
                '())))
        (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 (assoc-ref package-data "name"))
         (php-dir (string-append out "/share/web/" name))
         (bin-dir (string-append php-dir "/vendor/bin"))
         (bin (string-append out "/bin"))
         (binaries (assoc-ref package-data "bin")))
      (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))
  #t)

(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