build-system: Rewrite node build system.

* guix/build/node-build-system.scm: Rewrite it.
* guix/build-system/node.scm: Adjust accordingly.
* gnu/packages/node-xyz.scm (node-semver): Likewise.

Co-authored-by: Timothy Sample <samplet@ngyro.com>

3 files changed, 110 insertions, 130 deletions

diff --git a/gnu/packages/node-xyz.scm b/gnu/packages/node-xyz.scm
index b1d6d4ce59..60cc005ea4 100644
--- a/gnu/packages/node-xyz.scm
+++ b/gnu/packages/node-xyz.scm
@@ -261,7 +261,11 @@ function with browser support.")
                 "06biknqb05r9xsmcflm3ygh50pjvdk84x6r79w43kmck4fn3qn5p"))))
     (build-system node-build-system)
     (arguments
-     `(#:tests? #f)) ;; FIXME: Tests depend on node-tap
+     '(#:tests? #f ; FIXME: Tests depend on node-tap
+       #:phases
+       (modify-phases %standard-phases
+         ;; The only dependency to check for is tap, which we don't have.
+         (delete 'configure))))
     (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 a8c5eed09b..4991ed53a5 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,7 +18,6 @@
 ;;; 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 utils)
   #:use-module (guix packages)
   #:use-module (guix derivations)
@@ -25,22 +25,15 @@
   #:use-module (guix build-system)
   #:use-module (guix build-system gnu)
   #: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."
@@ -76,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))
@@ -86,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
@@ -97,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
@@ -129,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..a55cab237c 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, 2021 Timothy Sample <samplet@ngyro.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -19,144 +20,130 @@
 
 (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 ((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? #: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" "info"
+            "--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)