;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2016, 2020 Jelle Licht <jlicht@fsfe.org>
;;; Copyright © 2019, 2021 Timothy Sample <samplet@ngyro.com>
;;;
;;; 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 node-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build utils)
  #:use-module (guix build json)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:export (%standard-phases
            node-build))

;; Commentary:
;;
;; Builder-side code of the standard Node/NPM package install procedure.
;;
;; Code:

(define (set-home . _)
  (with-directory-excursion ".."
    (let loop ((i 0))
      (let ((dir (string-append "npm-home-" (number->string i))))
        (if (directory-exists? dir)
            (loop (1+ i))
            (begin
              (mkdir dir)
              (setenv "HOME" (string-append (getcwd) "/" dir))
              (format #t "set HOME to ~s~%" (getenv "HOME")))))))
  #t)

(define (module-name module)
  (let* ((package.json (string-append module "/package.json"))
         (package-meta (call-with-input-file package.json read-json)))
    (assoc-ref package-meta "name")))

(define (index-modules input-paths)
  (define (list-modules directory)
    (append-map (lambda (x)
                  (if (string-prefix? "@" x)
                      (list-modules (string-append directory "/" x))
                      (list (string-append directory "/" x))))
                (filter (lambda (x)
                          (not (member x '("." ".."))))
                        (or (scandir directory) '()))))
  (let ((index (make-hash-table (* 2 (length input-paths)))))
    (for-each (lambda (dir)
                (let ((nm (string-append dir "/lib/node_modules")))
                  (for-each (lambda (module)
                              (hash-set! index (module-name module) module))
                            (list-modules nm))))
              input-paths)
    index))

(define* (patch-dependencies #:key inputs absent-dependencies
                             #:allow-other-keys)

  (define index (index-modules (map cdr inputs)))

  (define (resolve-dependencies meta-alist meta-key)
    ;; Given:
    ;;  - The alist from "package.json", with the '@ unwrapped
    ;;  - A string key, like "dependencies"
    ;; Returns: an alist (without a wrapping '@) like the entry in
    ;; meta-alist for meta-key, but with dependencies supplied
    ;; by Guix packages mapped to the absolute store paths to use.
    (match (assoc-ref meta-alist meta-key)
      (#f
       '())
      (('@ . orig-deps)
       (fold (match-lambda*
               (((key . value) acc)
                (if (member key absent-dependencies)
                    acc
                    (acons key (hash-ref index key value) acc))))
             '()
             orig-deps))))

  (with-atomic-file-replacement "package.json"
    (lambda (in out)
      ;; It is unsafe to rely on 'assoc-set!' to update an
      ;; existing assosciation list variable:
      ;; see 'info "(guile)Adding or Setting Alist Entries"'.
      (let* ((package-meta (read-json in))
             (alist (match package-meta
                      ((@ . alist) alist)))
             (alist
              (assoc-set!
               alist "dependencies"
               (append
                '(@)
                (resolve-dependencies alist "dependencies")
                (resolve-dependencies alist "peerDependencies"))))
             (alist
              (assoc-set!
               alist "devDependencies"
               (append
                '(@)
                (resolve-dependencies alist "devDependencies"))))
             (package-meta (cons '@ alist)))
        (write-json package-meta out))))
  #t)

(define* (delete-lockfiles #:key inputs #:allow-other-keys)
  "Delete 'package-lock.json', 'yarn.lock', and 'npm-shrinkwrap.json', if they
exist."
  (for-each (lambda (pth)
              (when (file-exists? pth)
                (delete-file pth)))
            '("package-lock.json"
              "yarn.lock"
              "npm-shrinkwrap.json"))
  #t)

(define* (configure #:key outputs inputs #:allow-other-keys)
  (let ((npm (string-append (assoc-ref inputs "node") "/bin/npm")))
    (invoke npm "--offline" "--ignore-scripts" "install")
    #t))

(define* (build #:key inputs #:allow-other-keys)
  (let ((package-meta (call-with-input-file "package.json" read-json)))
    (if (and=> (assoc-ref package-meta "scripts")
               (lambda (scripts)
                 (assoc-ref scripts "build")))
        (let ((npm (string-append (assoc-ref inputs "node") "/bin/npm")))
          (invoke npm "run" "build"))
        (format #t "there is no build script to run~%"))
    #t))

(define* (check #:key tests? inputs #:allow-other-keys)
  "Run 'npm test' if TESTS?"
  (if tests?
      (let ((npm (string-append (assoc-ref inputs "node") "/bin/npm")))
        (invoke npm "test"))
      (format #t "test suite not run~%"))
  #t)

(define* (repack #:key inputs #:allow-other-keys)
  (invoke "tar"
          ;; Add options suggested by https://reproducible-builds.org/docs/archives/
          "--sort=name"
          (string-append "--mtime=@" (getenv "SOURCE_DATE_EPOCH"))
          "--owner=0"
          "--group=0"
          "--numeric-owner"
          "-czf" "../package.tgz" ".")
  #t)

(define* (install #:key outputs inputs #:allow-other-keys)
  "Install the node module to the output store item."
  (let ((out (assoc-ref outputs "out"))
        (npm (string-append (assoc-ref inputs "node") "/bin/npm")))
    (invoke npm "--prefix" out
            "--global"
            "--offline"
            "--loglevel" "info"
            "--production"
            "install" "../package.tgz")
    #t))

(define* (avoid-node-gyp-rebuild #:key outputs #:allow-other-keys)
  "Adjust the installed 'package.json' to remove an 'install' script that
would try to run 'node-gyp rebuild'."
  ;; We want to take advantage of `npm install`'s automatic support for
  ;; building native addons with node-gyp: in particular, it helps us avoid
  ;; hard-coding the specifics of how npm's internal copy of node-gyp is
  ;; currently packaged. However, the mechanism by which the automatic support
  ;; is implemented causes problems for us.
  ;;
  ;; If a package contains a 'binding.gyp' file and does not define an
  ;; 'install' or 'preinstall' script, 'npm install' runs a default install
  ;; script consisting of 'node-gyp rebuild'. In our 'install' phase, this
  ;; implicit 'install' script, if it is applicable, is explicitly added to
  ;; the "package.json" file. However, if another Guix package were to use a
  ;; Node.js package with such an 'install' script, the dependent package's
  ;; build process would fail, because 'node-gyp rebuild' would try to write
  ;; to the store.
  ;;
  ;; Here, if the installed "package.json" defines scripts.install as
  ;; "node-gyp rebuild", we replace it with a no-op. Importantly, deleting the
  ;; install script definition would not be enough, because the default
  ;; install script would cause the same problem.
  ;;
  ;; For further details, see:
  ;;  - https://docs.npmjs.com/cli/v8/configuring-npm/package-json#default-values
  ;;  - https://docs.npmjs.com/cli/v8/using-npm/scripts#best-practices
  (let* ((package.json (string-append
                        (assoc-ref outputs "out")
                        "/lib/node_modules/"
                        (match (call-with-input-file "package.json" read-json)
                          (('@ . alist)
                           (assoc-ref alist "name")))
                        "/package.json"))
         (meta-alist (match (call-with-input-file package.json read-json)
                       (('@ . alist)
                        alist)))
         (scripts-alist (match (assoc-ref meta-alist "scripts")
                          (('@ . alist)
                           alist)
                          (#f
                           #f))))
    (when (and scripts-alist
               (equal? "node-gyp rebuild" (assoc-ref scripts-alist "install")))
      (call-with-output-file package.json
        (lambda (out)
          (write-json
           (cons '@ (assoc-set!
                     meta-alist
                     "scripts"
                     (cons '@ (assoc-set!
                               scripts-alist
                               "install"
                               "echo Guix: avoiding node-gyp rebuild"))))
           out))))
    #t))

(define %standard-phases
  (modify-phases gnu:%standard-phases
    (add-after 'unpack 'set-home set-home)
    (add-before 'configure 'patch-dependencies patch-dependencies)
    (add-after 'patch-dependencies 'delete-lockfiles delete-lockfiles)
    (replace 'configure configure)
    (replace 'build build)
    (replace 'check check)
    (add-before 'install 'repack repack)
    (replace 'install install)
    (add-after 'install 'avoid-node-gyp-rebuild avoid-node-gyp-rebuild)))

(define* (node-build #:key inputs (phases %standard-phases)
                     #:allow-other-keys #:rest args)
  (apply gnu:gnu-build #:inputs inputs #:phases phases args))