;;; 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
            with-atomic-json-file-replacement
            node-build))

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

;;;
;;; JSON utilities.
;;;
;;; The following procedures facilitate transforming JSON values using the
;;; representation from (guix build json), particularly purely functional
;;; update of JSON objects.  If we decide to make more of them public, we
;;; might instead put them in their own file or, eventually, add them to
;;; (guix build json).
;;;
;;; JSON objects with duplicate keys are not interoperable: see RFC 8259 § 4.
;;; These procedures assume, but generally do not check, that JSON objects
;;; given to them as arguments do not have duplicate keys.  As long as that
;;; precondition is satisfied, they will produce JSON objects without
;;; duplicate keys.  Procedures that operate on unwrapped assosciation lists
;;; may do likewise, which should be considered before exporting them for
;;; general use.
;;;

(define (with-atomic-json-file-replacement file proc)
  "Like 'with-atomic-file-replacement', but PROC is called with a single
argument---the result of parsing FILE's contents as json---and should a value
to be written as json to the replacement FILE."
  (with-atomic-file-replacement file
    (lambda (in out)
      (write-json (proc (read-json in)) out))))

(define (jsobject-ref js key failure-result)
  "Return the value assosciated with KEY in the json object JS.  If KEY is not
found and FAILURE-RESULT is a procedure, it is called in tail position with
zero arguments.  Otherwise, FAILURE-RESULT is returned."
  ;; TODO: `failure-result` should be optional, but should the default
  ;; `failure-result` be #f (like `assoc-ref`), a thunk raising an exception,
  ;; '(@), or something else?  Keep it mandatory until we discuss and decide.
  (match js
    (('@ . alist)
     (match (assoc key alist)
       (#f
        (if (procedure? failure-result)
            (failure-result)
            failure-result))
       ((_ . value)
        value)))))

(define (alist-pop alist key)
  "Return two values: the first pair in ALIST with the given KEY in its
'car' (or #f, if no such pair exists) and an assosciation list like (and
potentially sharing storage with) ALIST, but with no entry for KEY."
  (match (assoc key alist)
    ;; If key isn't present, we don't need to do any allocation
    (#f
     (values #f alist))
    (found
     (values found
             ;; Because we have `found`, we can find it more
             ;; efficiently this time with `eq?`. We avoid using
             ;; `delq` because it would copy pairs in a shared
             ;; tail. We assume a sufficiently smart compiler to
             ;; handle "tail recursion modulo cons" (vid. e.g. Indiana
             ;; University Technical Report No. 19, Friedman & Wise
             ;; 1975) at least as efficiently as a hand-written
             ;; tail-recursive implementation with an accumulator.
             (let loop ((alist alist))
               (match alist
                 ;; We know that `found` is present,
                 ;; so no need to check for '()
                 ((this . alist)
                  (if (eq? this found)
                      alist
                      (cons this (loop alist))))))))))

;; Sadly, Guile's implementation of (@ (srfi srfi-1) alist-delete)
;; performs unnecessary allocation, e.g. this currently evaluates to #f:
;;
;;     (let ((alist `(("a" . 1)("b" . 2)("c" . 3))))
;;       (eq? alist (alist-delete "x" alist)))
;;
;; These functions generally choose to allocate a new outer pair (with the '@
;; tag), even though in unusual cases the resulting object might not have
;; changed, for the sake of simplicity and to avoid retaining a reference to
;; the original alist longer than necessary. But that is O(1) allocation that
;; could only rarely be avoided: `alist-delete` would allocate O(n) pairs,
;; which would only be necessary in the worst case.
(define (alist-delete* alist key)
  "Return an assosciation list like (and potentially sharing storage with)
ALIST, but with no entry for KEY."
  (define-values (_popped remaining)
    (alist-pop alist key))
  remaining)

(define (jsobject-delete js key)
  "Return a json object like JS, but with no entry for KEY."
  (cons '@ (match js
             (('@ . alist)
              (alist-delete* alist key)))))

(define (alist-set alist key value)
  "Return an assosciation list like ALIST, but with KEY mapped to VALUE,
replacing any existing mapping for KEY."
  (acons key value (alist-delete* alist key)))

(define (jsobject-set js key value)
  "Return a json object like JS, but with KEY mapped to VALUE, replacing any
existing mapping for KEY."
  (cons '@ (match js
             (('@ . alist)
              (alist-set alist key value)))))

(define jsobject-set*
  (case-lambda
    "Return a json object like JS, but functionally extended by mapping each
KEY to each VALUE, replacing any existing mapping for each KEY.  The update
takes place from left to right, so later mappings overwrite earlier mappings
for the same KEY."
    ((js)
     js)
    ((js key value)
     (jsobject-set js key value))
    ((js . args)
     (cons '@ (match js
                (('@ . alist)
                 (let loop ((alist alist)
                            (args args))
                   (match args
                     (()
                     alist)
                     ((key value . args)
                      (loop (alist-set alist key value)
                            args))))))))))

(define (alist-update alist key failure-result updater)
  "Return an assosciation list like ALIST, but with KEY mapped to the result
of applying UPDATER to the value to which KEY is mapped in ALIST.  When ALIST
does not have an existing mapping for KEY, FAILURE-RESULT is used as with
'jsobject-ref' to obtain the argument for UPDATER."
  ;; Often, `updater` will be a lambda expression, so making it the last
  ;; argument may help to makes the code legible, and the most likely
  ;; `failure-result` arguments are all shorter than the keyword
  ;; `#:failure-result`.  Plus, making `failure-result` mandatory helps make
  ;; `alist-update` consistent with `alist-update*`.
  (define-values (popped tail-alist)
    (alist-pop alist key))
  (acons key
         (updater (match popped
                    (#f
                     (if (procedure? failure-result)
                         (failure-result)
                         failure-result))
                    ((_ . value)
                     value)))
         tail-alist))

(define (jsobject-update js key failure-result updater)
  "Return a json object like JS, but with KEY mapped to the result of applying
UPDATER to the value to which KEY is mapped in JS.  When JS does not have an
existing mapping for KEY, FAILURE-RESULT is used as with 'jsobject-ref' to
obtain the argument for UPDATER."
  (cons '@ (match js
             (('@ . alist)
              (alist-update alist key failure-result updater)))))

(define jsobject-update*
  (case-lambda
    "Return a json object like JS, but functionally extended by replacing the
mapping for each KEY with the result of applying the corresponding UPDATER to
the value to which that KEY is mapped in JS---or, if no such mapping exists,
to a value based on the corresponding FAILURE-RESULT as with 'jsobject-ref'.
The update takes place from left to right, so later UPDATERs will receive the
values returned by earlier UPDATERs for the same KEY."
    ((js)
     js)
    ((js key failure-result updater)
     (jsobject-update js key failure-result updater))
    ((js . args)
     (cons '@ (match js
                (('@ . alist)
                 (let loop ((alist alist)
                            (args args))
                   (match args
                     (()
                     alist)
                     ((key failure-result updater . args)
                      (loop (alist-update alist key failure-result updater)
                            args))))))))))

(define* (jsobject-union #:key
                         (combine (lambda (a b) b))
                         (combine/key (lambda (k a b) (combine a b)))
                         #:rest json-objects)
  "Combine the given JSON-OBJECTS into a single json object.  The JSON-OBJECTS
are merged from left to right by adding each key/value pair of each object to
the aggregate object in turn.  When one of the JSON-OBJECTS contains a mapping
from some key KEY to a value VAL such that the aggregate object already
contains a mapping from KEY to a value VAL0, the aggregate object is
functionally updated to instead map KEY to the value of (COMBINE/KEY KEY VAL0
VAL).  The default COMBINE/KEY tail-calls (COMBINE VAL0 VAL), and the default
COMBINE simply returns its second argument, so, by default, mappings in later
JSON-OBJECTS supersede those in earlier ones."
  (match (filter (lambda (v)
                   (not (or (keyword? v)
                            (procedure? v))))
                 json-objects)
    (()
     '(@))
    (((and js0 ('@ . _)))
     js0)
    ((('@ . alist0) ('@ . alist*) ...)
     (cons '@ (fold (lambda (alist1 alist0)
                      (if (null? alist0)
                          alist1
                          (fold (lambda (k+v alist0)
                                  (match k+v
                                    ((k . v)
                                     (define-values (popped tail-alist)
                                       (alist-pop alist0 k))
                                     (match popped
                                       (#f
                                        (cons k+v tail-alist))
                                       ((_ . v0)
                                        (acons k
                                               (combine/key k v0 v)
                                               tail-alist))))))
                                alist0
                                alist1)))
                    alist0
                    alist*)))))


;;;
;;; Phases.
;;;

(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)))
    (jsobject-ref package-meta "name" #f)))

(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 #:allow-other-keys)

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

  (define resolve-dependencies
    (match-lambda
      (('@ . alist)
       (cons '@ (map (match-lambda
                       ((key . value)
                        (cons key (hash-ref index key value))))
                     alist)))))

  (with-atomic-json-file-replacement "package.json"
    (lambda (pkg-meta)
      (jsobject-update*
       pkg-meta
       "devDependencies" '(@) resolve-dependencies
       "dependencies" '(@) (lambda (deps)
                             (resolve-dependencies
                              (jsobject-union
                               (jsobject-ref pkg-meta "peerDependencies" '(@))
                               deps))))))
  #t)

(define* (delete-dependencies #:key absent-dependencies #:allow-other-keys)
  "Modify 'package.json' to allow building without the ABSENT-DEPENDENCIES."
  (define delete-fom-jsobject
    (match-lambda
      (('@ . alist)
       (cons '@ (filter (match-lambda
                          ((k . v)
                           (not (member k absent-dependencies))))
                        alist)))))
  (with-atomic-json-file-replacement "package.json"
    (lambda (pkg-meta)
      (jsobject-update*
       pkg-meta
       "devDependencies" '(@) delete-fom-jsobject
       "dependencies" '(@) delete-fom-jsobject))))

(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 (jsobject-ref (jsobject-ref package-meta "scripts" '(@)) "build" #f)
        (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
  (define installed-package.json
    (search-input-file outputs (string-append "/lib/node_modules/"
                                              (module-name ".")
                                              "/package.json")))
  ;; not with-atomic-json-file-replacement, because we usually don't
  ;; want or need to overwrite it
  (define pkg-meta
    (call-with-input-file installed-package.json read-json))
  (define scripts
    (jsobject-ref pkg-meta "scripts" '(@)))
  (when (equal? "node-gyp rebuild" (jsobject-ref scripts "install" #f))
    (call-with-output-file installed-package.json
      (lambda (out)
        (write-json
         (jsobject-set pkg-meta
                       "scripts"
                       (jsobject-set scripts
                                     "install"
                                     "echo Guix: avoiding node-gyp rebuild"))
         out)))))

(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-dependencies delete-dependencies)
    (add-after 'delete-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))