[bug#41219] [PATCH 2/2] guix: Enforce package.json "files" directive.

[paul <goodoldpaul@autistici.org>]

[-- Attachment #1: Type: text/plain, Size: 196 bytes --]

Hi Jelle,

I messed up again :( this new patch actually checks the right path for 
the existence of the "main" file. I hope I didn't mess up anything else.

Thank you for your patience,

Giacomo


[-- Attachment #2: 0002-guix-Enforce-package.json-files-directive.patch --]
[-- Type: text/x-patch, Size: 6474 bytes --]

From 7dc7764da6a3463fdfed5667b02458d541518cbc Mon Sep 17 00:00:00 2001
From: Giacomo Leidi <goodoldpaul@autistici.org>
Date: Mon, 21 Sep 2020 22:18:19 +0200
Subject: [PATCH 2/2] guix: Enforce package.json "files" directive.

This fixes https://issues.guix.gnu.org/40710 by implementing support for the
"files" directive from https://docs.npmjs.com/files/package.json#files .

* guix/build/node-build-system.scm (install): Enforce package.json
"files" directive.
* guix/build-system/node.scm (%node-build-system-modules)
(node-build)[modules]: Add (guix glob).
---
 guix/build-system/node.scm       |  4 +-
 guix/build/node-build-system.scm | 68 ++++++++++++++++++++++++++------
 2 files changed, 58 insertions(+), 14 deletions(-)

diff --git a/guix/build-system/node.scm b/guix/build-system/node.scm
index 05c24c47d5..05bc9f2087 100644
--- a/guix/build-system/node.scm
+++ b/guix/build-system/node.scm
@@ -42,6 +42,7 @@ registry."
   `((guix build node-build-system)
     (guix build json)
     (guix build union)
+    (guix glob)
     ,@%gnu-build-system-modules)) ;; TODO: Might be not needed
 
 (define (default-node)
@@ -90,7 +91,8 @@ registry."
                      (modules '((guix build node-build-system)
 				(guix build json)
 				(guix build union)
-                                (guix build utils))))
+                                (guix build utils)
+                                (guix glob))))
   "Build SOURCE using NODE and INPUTS."
   (define builder
     `(begin
diff --git a/guix/build/node-build-system.scm b/guix/build/node-build-system.scm
index 7799f03595..831a8b7328 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 © 2020 Giacomo Leidi <goodoldpaul@autistici.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -22,6 +23,7 @@
   #:use-module (guix build json)
   #:use-module (guix build union)
   #:use-module (guix build utils)
+  #:use-module (guix glob)
   #:use-module (ice-9 match)
   #:use-module (ice-9 popen)
   #:use-module (ice-9 regex)
@@ -110,18 +112,60 @@ the @file{bin} directory."
 				 (#f #f)))
          (dependencies (match (assoc-ref data "dependencies")
                          (('@ deps ...) deps)
-                         (#f #f))))
+                         (#f #f)))
+         (file-list (match (assoc-ref data "files")
+                      (() #f)
+                      ((? list? pattern-list) pattern-list)
+                      (#f #f)))
+         (patterns
+          (when file-list
+            (map (lambda (pattern)
+                   (string->compiled-sglob pattern))
+                 (append file-list
+                         '("package.json"
+                           ;; These files get installed no
+                           ;; matter the case or extension.
+                           "[rR][eE][aA][dD][mM][eE]*"
+                           "[cC][hH][aA][nN][gG][eE][sS]*"
+                           "[cC][hH][aA][nN][gG][eE][lL][oO][gG]*"
+                           "[hH][iI][sS][tT][oO][rR][yY]*"
+                           "[nN][oO][tT][iI][cC][eE]*")))))
+         (main (match (assoc-ref data "main")
+                 ("" #f)
+                 ((? string? main-module) main-module)
+                 (#f #f)))
+         (install-dir (string-append target "/node_modules/" modulename))
+         (install-files (lambda (files)
+                          (for-each (lambda (file)
+                                      (install-file
+                                       file
+                                       (string-append install-dir "/"
+                                                      (dirname file))))
+                                    files))))
     (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"))
+    (if file-list
+        (install-files
+         (find-files "." (lambda (file stat)
+                           (any (lambda (pattern)
+                                  (glob-match? pattern
+                                               (string-drop file 2)))
+                                patterns))))
+        (begin
+          (copy-recursively "." install-dir)
+          ;; Remove references to dependencies
+          (delete-file-recursively
+           (string-append install-dir "/node_modules"))))
+    (when main
+      (let ((main.js (if (string-contains (basename main) ".js")
+                         main
+                         (string-append main ".js"))))
+        (unless (file-exists? (string-append install-dir "/" main.js))
+          (install-files (list main.js)))))
     (cond
       ((string? binary-configuration)
        (begin
          (mkdir-p binaries)
-         (symlink (string-append target "/node_modules/" modulename "/"
-				 binary-configuration)
+         (symlink (string-append install-dir "/" binary-configuration)
                   (string-append binaries "/" modulename))))
       ((list? binary-configuration)
        (for-each
@@ -130,21 +174,19 @@ the @file{bin} directory."
              ((key . value)
               (begin
                 (mkdir-p (dirname (string-append binaries "/" key)))
-                (symlink (string-append target "/node_modules/" modulename "/"
-					value)
+                (symlink (string-append install-dir "/" value)
                          (string-append binaries "/" key))))))
-         binary-configuration)))
+        binary-configuration)))
     (when dependencies
       (mkdir-p
-        (string-append target "/node_modules/" modulename "/node_modules"))
+        (string-append install-dir "/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))))
+              (string-append install-dir "/node_modules/" dependency))))
         dependencies))
     #t))
 
-- 
2.28.0