[bug#47282] [PATCH 01/13] build-system: Rewrite node build system.

[Jelle Licht <jlicht@fsfe.org>]

* guix/build/node-build-system.scm: Rewrite it.
* guix/build-system/node.scm: Adjust accordingly.
* gnu/packages/node-xyz.scm (node-color-name, node-env-variable, node-far,
node-long-stack-traces, node-mersenne, node-oop, node-stack-trace,
node-statsd-parser, node-utils-deprecate, node-semver): Likewise.

Co-authored-by: Timothy Sample <samplet@ngyro.com>
---
 gnu/packages/node-xyz.scm        |  74 +++++++----
 guix/build-system/node.scm       |  37 ++----
 guix/build/node-build-system.scm | 203 ++++++++++++++-----------------
 3 files changed, 158 insertions(+), 156 deletions(-)

diff --git a/gnu/packages/node-xyz.scm b/gnu/packages/node-xyz.scm
index b1d6d4ce59..7d7f0251d1 100644
--- a/gnu/packages/node-xyz.scm
+++ b/gnu/packages/node-xyz.scm
@@ -38,6 +38,11 @@
          (base32
           "09rbmj16nfwcwkhrybqxyy66bkrs50vpw6hkdqqb14l3gsyxpr74"))))
     (build-system node-build-system)
+    (arguments
+     `(#:phases
+       (modify-phases
+           %standard-phases
+         (delete 'build))))
     (home-page "https://github.com/colorjs/color-name")
     (synopsis "JSON with CSS color names")
     (description
@@ -59,7 +64,11 @@
          (base32
           "0nnpxjxfhy4na7fixb7p3ww6ard5xgggfm83b78i333867r4gmsq"))))
     (build-system node-build-system)
-    (arguments '(#:tests? #f)) ; No tests.
+    (arguments '(#:tests? #f ; No tests.
+                 #:phases
+                 (modify-phases
+                     %standard-phases
+                   (delete 'build))))
     (home-page "https://github.com/bigpipe/env-variable")
     (synopsis "Environment variables for Node with fallbacks")
     (description "This package provides environment variables with
@@ -85,6 +94,7 @@
     (arguments
      '(#:phases
        (modify-phases %standard-phases
+         (delete 'build)
          (replace 'check
            (lambda _
              ;; We skip the two tests which are supposed to fail.
@@ -113,7 +123,10 @@ codes.")
          (base32
           "0famwsyc6xawi30v25zi65d8fhbvlvh976bqydf1dqn5gz200cl3"))))
     (build-system node-build-system)
-    (arguments '(#:tests? #f)) ; No tests.
+    (arguments '(#:tests? #f ; No tests.
+                 #:phases
+                 (modify-phases %standard-phases
+                   (delete 'build))))
     (home-page "https://github.com/tlrobinson/long-stack-traces")
     (synopsis "Long stacktraces implemented in user-land JavaScript")
     (description "This package provides long stacktraces for V8 implemented in
@@ -136,7 +149,10 @@ user-land JavaScript.")
          (base32
           "034iaiq2pdqn342p2404cpz364g282d2hkp9375hysnh9i968wbb"))))
     (build-system node-build-system)
-    (arguments '(#:tests? #f)) ; No tests.
+    (arguments '(#:tests? #f ; No tests.
+                 #:phases
+                 (modify-phases %standard-phases
+                   (delete 'build))))
     (home-page "http://www.enchantedage.com/node-mersenne")
     (synopsis "Node.js module for generating Mersenne Twister random numbers")
     (description "Thix package provides a node.js port of the Mersenne Twister
@@ -161,7 +177,11 @@ random number generator.")
            (base32
             "0mqrcf0xi2jbwffwkk00cljpqfsri1jk8s6kz8jny45apn7zjds1"))))
       (build-system node-build-system)
-      (arguments '(#:tests? #f)) ; Tests run during build phase.
+      (arguments '(#:tests? #f ; Tests run during build phase.
+                   #:phases
+                   (modify-phases
+                       %standard-phases
+                     (delete 'build))))
       (home-page "https://github.com/felixge/node-oop")
       (synopsis "Simple, light-weight oop module for Node")
       (description "This library tries to bring basic oop features to JavaScript
@@ -189,11 +209,12 @@ while being as light-weight and simple as possible.")
       (arguments
        '(#:phases
          (modify-phases %standard-phases
-         (add-before 'check 'skip-intentionally-failing-test
-           (lambda _
-             (substitute* "test/run.js"
-               (("far.include") "far.exclude(/test-parse.js/)\nfar.include"))
-             #t)))))
+           (delete 'build)
+           (add-before 'check 'skip-intentionally-failing-test
+             (lambda _
+               (substitute* "test/run.js"
+                 (("far.include") "far.exclude(/test-parse.js/)\nfar.include"))
+               #t)))))
       (native-inputs
        `(("node-far" ,node-far)
          ("node-long-stack-traces" ,node-long-stack-traces)))
@@ -207,17 +228,20 @@ while being as light-weight and simple as possible.")
     (name "node-statsd-parser")
     (version "0.0.4")
     (source
-      (origin
-        (method git-fetch)
-        (uri (git-reference
-               (url "https://github.com/dscape/statsd-parser")
-               (commit version)))
-        (file-name (git-file-name name version))
-        (sha256
-         (base32
-          "049rnczsd6pv6bk282q4w72bhqc5cs562djgr7yncy7lk0wzq5j3"))))
+     (origin
+       (method git-fetch)
+       (uri (git-reference
+             (url "https://github.com/dscape/statsd-parser")
+             (commit version)))
+       (file-name (git-file-name name version))
+       (sha256
+        (base32
+         "049rnczsd6pv6bk282q4w72bhqc5cs562djgr7yncy7lk0wzq5j3"))))
     (build-system node-build-system)
-    (arguments '(#:tests? #f)) ; No tests.
+    (arguments '(#:tests? #f            ; No tests.
+                 #:phases
+                 (modify-phases %standard-phases
+                   (delete 'build))))
     (home-page "https://github.com/dscape/statsd-parser")
     (synopsis "Streaming parser for the statsd protocol")
     (description "This package provides a streaming parser for the statsd
@@ -239,7 +263,10 @@ protocol used in @code{node-lynx}.")
          (base32
           "1rk94nl3qc7znsk8400bnga30v0m7j2mmvz9ldwjinxv1d3n11xc"))))
     (build-system node-build-system)
-    (arguments '(#:tests? #f)) ; No test suite.
+    (arguments '(#:tests? #f            ; No tests.
+                 #:phases
+                 (modify-phases %standard-phases
+                   (delete 'build))))
     (home-page "https://github.com/TooTallNate/util-deprecate")
     (synopsis "Node.js `util.deprecate()` function with browser support")
     (description "This package provides the Node.js @code{util.deprecate()}
@@ -261,7 +288,12 @@ function with browser support.")
                 "06biknqb05r9xsmcflm3ygh50pjvdk84x6r79w43kmck4fn3qn5p"))))
     (build-system node-build-system)
     (arguments
-     `(#:tests? #f)) ;; FIXME: Tests depend on node-tap
+     '(#:tests? #f
+       #:phases
+       (modify-phases
+           %standard-phases
+         (delete 'configure)
+         (delete 'build)))) ;; FIXME: Tests depend on node-tap
     (home-page "https://github.com/npm/node-semver")
     (synopsis "Parses semantic versions strings")
     (description
diff --git a/guix/build-system/node.scm b/guix/build-system/node.scm
index 05c24c47d5..560f0ee4da 100644
--- a/guix/build-system/node.scm
+++ b/guix/build-system/node.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016 Jelle Licht <jlicht@fsfe.org>
+;;; Copyright © 2019 Timothy Sample <samplet@ngyro.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -17,32 +18,22 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix build-system node)
-  #:use-module (guix store)
-  #:use-module (guix build json)
-  #:use-module (guix build union)
-  #:use-module (guix utils)
-  #:use-module (guix packages)
-  #:use-module (guix derivations)
-  #:use-module (guix search-paths)
   #:use-module (guix build-system)
   #:use-module (guix build-system gnu)
+  #:use-module (guix derivations)
+  #:use-module (guix packages)
+  #:use-module (guix search-paths)
+  #:use-module (guix utils)
   #:use-module (ice-9 match)
-  #:export (npm-meta-uri
-            %node-build-system-modules
+  #:export (%node-build-system-modules
             node-build
             node-build-system))
 
-(define (npm-meta-uri name)
-  "Return a URI string for the metadata of node module NAME found in the npm
-registry."
-  (string-append "https://registry.npmjs.org/" name))
-
 (define %node-build-system-modules
   ;; Build-side modules imported by default.
   `((guix build node-build-system)
     (guix build json)
-    (guix build union)
-    ,@%gnu-build-system-modules)) ;; TODO: Might be not needed
+    ,@%gnu-build-system-modules))
 
 (define (default-node)
   "Return the default Node package."
@@ -78,7 +69,7 @@ registry."
 
 (define* (node-build store name inputs
                      #:key
-                     (npm-flags ''())
+                     (test-target "test")
                      (tests? #t)
                      (phases '(@ (guix build node-build-system)
                                  %standard-phases))
@@ -88,8 +79,6 @@ registry."
                      (guile #f)
                      (imported-modules %node-build-system-modules)
                      (modules '((guix build node-build-system)
-				(guix build json)
-				(guix build union)
                                 (guix build utils))))
   "Build SOURCE using NODE and INPUTS."
   (define builder
@@ -99,12 +88,10 @@ registry."
                    #:source ,(match (assoc-ref inputs "source")
                                (((? derivation? source))
                                 (derivation->output-path source))
-                               ((source)
-                                source)
-                               (source
-                                source))
+                               ((source) source)
+                               (source source))
                    #:system ,system
-                   #:npm-flags ,npm-flags
+                   #:test-target ,test-target
                    #:tests? ,tests?
                    #:phases ,phases
                    #:outputs %outputs
@@ -131,5 +118,5 @@ registry."
 (define node-build-system
   (build-system
     (name 'node)
-    (description "The standard Node build system")
+    (description "The Node build system")
     (lower lower)))
diff --git a/guix/build/node-build-system.scm b/guix/build/node-build-system.scm
index 7799f03595..ecba27166b 100644
--- a/guix/build/node-build-system.scm
+++ b/guix/build/node-build-system.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
-;;; Copyright © 2016 Jelle Licht <jlicht@fsfe.org>
+;;; Copyright © 2016, 2020 Jelle Licht <jlicht@fsfe.org>
+;;; Copyright © 2019 Timothy Sample <samplet@ngyro.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -19,144 +20,126 @@
 
 (define-module (guix build node-build-system)
   #:use-module ((guix build gnu-build-system) #:prefix gnu:)
-  #:use-module (guix build json)
-  #:use-module (guix build union)
   #:use-module (guix build utils)
+  #:use-module (guix build json)
+  #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
-  #:use-module (ice-9 popen)
-  #:use-module (ice-9 regex)
   #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-26)
   #:export (%standard-phases
             node-build))
 
 ;; Commentary:
 ;;
-;; Builder-side code of the standard Node/npm package build procedure.
+;; Builder-side code of the standard Node/NPM package install procedure.
 ;;
 ;; Code:
 
-(define* (read-package-data #:key (filename "package.json"))
-  (call-with-input-file filename
-    (lambda (port)
-      (read-json port))))
+(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* (build #:key inputs #:allow-other-keys)
-  (define (build-from-package-json? package-file)
-    (let* ((package-data (read-package-data #:filename package-file))
-           (scripts (assoc-ref package-data "scripts")))
-      (assoc-ref scripts "build")))
-  "Build a new node module using the appropriate build system."
-  ;; XXX: Develop a more robust heuristic, allow override
-  (cond ((file-exists? "gulpfile.js")
-         (invoke "gulp"))
-        ((file-exists? "gruntfile.js")
-         (invoke "grunt"))
-        ((file-exists? "Makefile")
-         (invoke "make"))
-        ((and (file-exists? "package.json")
-              (build-from-package-json? "package.json"))
-         (invoke "npm" "run" "build")))
+(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 #:allow-other-keys)
+
+  (define index (index-modules (map cdr inputs)))
+
+  (define (resolve-dependencies package-meta meta-key)
+    (fold (lambda (key+value acc)
+            (match key+value
+              ('@ acc)
+              ((key . value) (acons key (hash-ref index key value) acc))))
+          '()
+          (or (assoc-ref package-meta meta-key) '())))
+
+  (with-atomic-file-replacement "package.json"
+    (lambda (in out)
+      (let ((package-meta (read-json in)))
+        (assoc-set! package-meta "dependencies"
+                    (append
+                     '(@)
+                     (resolve-dependencies package-meta "dependencies")
+                     (resolve-dependencies package-meta "peerDependencies")))
+        (assoc-set! package-meta "devDependencies"
+                    (append
+                     '(@)
+                     (resolve-dependencies package-meta "devDependencies")))
+        (write-json package-meta out))))
   #t)
 
-(define* (link-npm-dependencies #:key inputs #:allow-other-keys)
-  (define (inputs->node-inputs inputs)
-    "Filter the directory part from INPUTS."
-    (filter (lambda (input)
-              (match input
-                ((name . _) (node-package? name))))
-            inputs))
-  (define (inputs->directories inputs)
-    "Extract the directory part from INPUTS."
-    (match inputs
-      (((names . directories) ...)
-       directories)))
-  (define (make-node-path root)
-    (string-append root "/lib/node_modules/"))
-
-  (let ((input-node-directories (inputs->directories
-                                 (inputs->node-inputs inputs))))
-    (union-build "node_modules"
-                 (map make-node-path input-node-directories))
+(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 configure link-npm-dependencies)
+(define* (build #:key inputs #:allow-other-keys)
+  (let ((npm (string-append (assoc-ref inputs "node") "/bin/npm")))
+    (invoke npm "run" "build")
+    #t))
 
-(define* (check #:key tests? #:allow-other-keys)
+
+(define* (check #:key tests? inputs #:allow-other-keys)
   "Run 'npm test' if TESTS?"
   (if tests?
-      ;; Should only be enabled once we know that there are tests
-      (invoke "npm" "test"))
+      (let ((npm (string-append (assoc-ref inputs "node") "/bin/npm")))
+        (invoke npm "test"))
+      (format #t "test suite not run~%"))
   #t)
 
-(define (node-package? name)
-  "Check if NAME correspond to the name of an Node package."
-  (string-prefix? "node-" name))
+(define* (repack #:key inputs #:allow-other-keys)
+  (invoke "tar" "-czf" "../package.tgz" ".")
+  #t)
 
 (define* (install #:key outputs inputs #:allow-other-keys)
-  "Install the node module to the output store item. The module itself is
-installed in a subdirectory of @file{node_modules} and its runtime dependencies
-as defined by @file{package.json} are symlinked into a @file{node_modules}
-subdirectory of the module's directory. Additionally, binaries are installed in
-the @file{bin} directory."
-  (let* ((out                  (assoc-ref outputs "out"))
-         (target               (string-append out "/lib"))
-         (binaries             (string-append out "/bin"))
-         (data                 (read-package-data))
-         (modulename           (assoc-ref data "name"))
-         (binary-configuration (match (assoc-ref data "bin")
-				 (('@ configuration ...) configuration)
-				 ((? string? configuration) configuration)
-				 (#f #f)))
-         (dependencies (match (assoc-ref data "dependencies")
-                         (('@ deps ...) deps)
-                         (#f #f))))
-    (mkdir-p target)
-    (copy-recursively "." (string-append target "/node_modules/" modulename))
-    ;; Remove references to dependencies
-    (delete-file-recursively
-      (string-append target "/node_modules/" modulename "/node_modules"))
-    (cond
-      ((string? binary-configuration)
-       (begin
-         (mkdir-p binaries)
-         (symlink (string-append target "/node_modules/" modulename "/"
-				 binary-configuration)
-                  (string-append binaries "/" modulename))))
-      ((list? binary-configuration)
-       (for-each
-         (lambda (conf)
-           (match conf
-             ((key . value)
-              (begin
-                (mkdir-p (dirname (string-append binaries "/" key)))
-                (symlink (string-append target "/node_modules/" modulename "/"
-					value)
-                         (string-append binaries "/" key))))))
-         binary-configuration)))
-    (when dependencies
-      (mkdir-p
-        (string-append target "/node_modules/" modulename "/node_modules"))
-      (for-each
-        (lambda (dependency)
-          (let ((dependency (car dependency)))
-            (symlink
-              (string-append (assoc-ref inputs (string-append "node-" dependency))
-                             "/lib/node_modules/" dependency)
-              (string-append target "/node_modules/" modulename
-                             "/node_modules/" dependency))))
-        dependencies))
+  "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" "silly"
+            "--production"
+            "install" "../package.tgz")
     #t))
 
-
 (define %standard-phases
   (modify-phases gnu:%standard-phases
+    (add-after 'unpack 'set-home set-home)
+    (add-before 'configure 'patch-dependencies patch-dependencies)
     (replace 'configure configure)
     (replace 'build build)
-    (replace 'install install)
-    (delete 'check)
-    (add-after 'install 'check check)
-    (delete 'strip)))
+    (replace 'check check)
+    (add-before 'install 'repack repack)
+    (replace 'install install)))
 
 (define* (node-build #:key inputs (phases %standard-phases)
                      #:allow-other-keys #:rest args)
-- 
2.31.0