[bug#41219] Enforce "files" directive in node build system

[bug#41219] Enforce "files" directive in node build system

[goodoldpaul]

Hi,

I'm sending a couple of patches to fix 
https://issues.guix.gnu.org/40710, I tried to base my implementation on 
[0].

The first patch adds "globstar" support to (guix glob), namely the 
ability of recursively matching subdirectories in a glob pattern (i.e. 
"foo/**/bar.scm" matches both "foo/bar.scm" and "foo/baz/bar.scm").

The second patch adds (guix glob) to the imported modules of 
node-build-system and uses that to parse glob patterns in the "files" 
array of a package.json and then install all the matching files.

I tested the patches by verifying that

./pre-inst-env guix build -K node-semver node-util-deprecate 
node-statsd-parser node-stack-trace node-oop node-mersenne 
node-long-stack-traces node-far node-env-variable node-color-name

runs without error and   and by running make check 
TESTS="tests/glob.scm" .

[bug#41219] Enforce "files" directive in node build system

[goodoldpaul]

On 2020-05-12 21:26, goodoldpaul@autistici.org wrote:
> Hi,
> 
> I'm sending a couple of patches to fix
> https://issues.guix.gnu.org/40710, I tried to base my implementation
> on [0].
> 
> The first patch adds "globstar" support to (guix glob), namely the
> ability of recursively matching subdirectories in a glob pattern (i.e.
> "foo/**/bar.scm" matches both "foo/bar.scm" and "foo/baz/bar.scm").
> 
> The second patch adds (guix glob) to the imported modules of
> node-build-system and uses that to parse glob patterns in the "files"
> array of a package.json and then install all the matching files.
> 
> I tested the patches by verifying that
> 
> ./pre-inst-env guix build -K node-semver node-util-deprecate
> node-statsd-parser node-stack-trace node-oop node-mersenne
> node-long-stack-traces node-far node-env-variable node-color-name
> 
> runs without error and   and by running make check 
> TESTS="tests/glob.scm" .

I apologize I sent by error without finishing.

Anyway I verified that the installed files match the "files" directive 
when present, otherwise we fall back to the original behavior of 
installing everything. I'm not really sure i added enough test cases in 
"tests/glob.scm", please do tell me if you believe I should add more.

Thank for your patience in reviewing this.

Giacomo

[bug#41219] [PATCH 1/2] guix: Add globstar support.

[Giacomo Leidi]

* guix/glob.scm (string->sglob)
(glob-match?): Add globstar support.
* tests/glob.scm: Update accordingly.
---
 guix/glob.scm  | 15 +++++++++++++++
 tests/glob.scm |  8 ++++++--
 2 files changed, 21 insertions(+), 2 deletions(-)

diff --git a/guix/glob.scm b/guix/glob.scm
index a9fc744802..d73783cd30 100644
--- a/guix/glob.scm
+++ b/guix/glob.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020 Giacomo Leidi <goodoldpaul@autistici.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -61,6 +62,11 @@ STR, a glob pattern such as \"foo*\" or \"foo??bar\"."
        (flatten (reverse (if (null? pending)
                              result
                              (cons-string pending result)))))
+      ((#\* #\* #\/ . rest)
+       (if (zero? brackets)
+           (loop rest '() 0
+                 (cons* '**/ (cons-string pending result)))
+           (loop rest (cons '**/ pending) brackets result)))
       (((and chr (or #\? #\*)) . rest)
        (let ((wildcard (match chr
                          (#\? '?)
@@ -121,6 +127,15 @@ STR, a glob pattern such as \"foo*\" or \"foo??bar\"."
       (string-null? str))
      (('*)
       #t)
+     (('**/)
+      #t)
+     (('**/ suffix . rest)
+      (let ((rest (if (eq? '* suffix) (cdr rest) rest))
+            (suffix (if (eq? '* suffix) (car rest) suffix)))
+        (match (string-contains str suffix)
+          (#f    #f)
+          (index (loop rest (string-drop str
+                                         (+ index (string-length suffix))))))))
      (('* suffix . rest)
       (match (string-contains str suffix)
         (#f    #f)
diff --git a/tests/glob.scm b/tests/glob.scm
index 3134069789..2a5a40c3c6 100644
--- a/tests/glob.scm
+++ b/tests/glob.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020 Giacomo Leidi <goodoldpaul@autistici.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -53,7 +54,8 @@
  "foo[abc]bar" => '("foo" (set #\a #\b #\c) "bar")
  "foo[a[b]c]bar" => '("foo" (set #\a #\[ #\b #\] #\c) "bar")
  "[123]x" => '((set #\1 #\2 #\3) "x")
- "[a-z]" => '((range #\a #\z)))
+ "[a-z]" => '((range #\a #\z))
+ "**/*.scm" => '(**/ * ".scm"))
 
 (test-glob-match
  ("foo" matches "foo" (and not "foobar" "barfoo"))
@@ -64,6 +66,8 @@
  ("ab[0-9]c" matches "ab0c" "ab7c" "ab9c"
   (and not "ab-c" "ab00c" "ab3"))
  ("ab[cdefg]" matches "abc" "abd" "abg"
-  (and not "abh" "abcd" "ab[")))
+  (and not "abh" "abcd" "ab["))
+ ("foo/**/*.scm" matches "foo/bar/baz.scm" "foo/bar.scm" "foo/bar/baz/zab.scm"
+  (and not "foo/bar/baz.java" "foo/bar.smc")))
 
 (test-end "glob")
-- 
2.26.2

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

[Giacomo Leidi]

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..befcbbeb75 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)))
+         (patterns (match (assoc-ref data "files")
+                     (() #f)
+                     ((? list? patrn-list) patrn-list)
+                     (#f #f)))
+         (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 directory)
+                          (for-each (lambda (file)
+                                      (install-file
+                                       file
+                                       (string-append directory "/"
+                                                      (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 patterns
+        (install-files
+         (filter (lambda (file)
+                   (any (lambda (pattern)
+                          (glob-match?
+                           (string->compiled-sglob pattern)
+                           file))
+                        (append
+                         patterns
+                         '("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]*"))))
+                 (map (lambda (path)
+                        (string-drop path 2))
+                      (find-files ".")))
+         install-dir)
+        (begin
+          (copy-recursively "." install-dir)
+          ;; Remove references to dependencies
+          (delete-file-recursively
+           (string-append install-dir "/node_modules"))))
+    (if (and main
+             (not (file-exists?
+                   (string-append
+                    install-dir "/" (dirname main)))))
+        (install-files (list main) install-dir))
     (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.26.2

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

[goodoldpaul]

Hi Guixers!
Did someone managed to have a look at these patches? No rush, just to 
have feedback :) .

Thanks,

Giacomo

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

[paul]

Hello Guix,

have you managed to go through these patches?

Thank you,

Giacomo

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

[Jelle Licht]

Hey Giacomo, 

Apologies for the delay! Better late than never, a review just for you.
The other patch seems fine to me, but I'm not a 'guix glob' expert.

Giacomo Leidi <goodoldpaul@autistici.org> writes:

> [snip]
> --- 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)))
> +         (patterns (match (assoc-ref data "files")
> +                     (() #f)
> +                     ((? list? patrn-list) patrn-list)
                                  ^
Perhaps 'pattern-list'? I keep reading this as patron-list. We could
also build the patterns here. Mapping over the pattern-list + 'default
patterns' here might also be a wee bit faster.

> +                     (#f #f)))
> +         (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 directory)
                                          ^
You only use install-dir here: you could hard-code it in the lambda.

> +                          (for-each (lambda (file)
> +                                      (install-file
> +                                       file
> +                                       (string-append directory "/"
> +                                                      (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 patterns
> +        (install-files
> +         (filter (lambda (file)
> +                   (any (lambda (pattern)
> +                          (glob-match?
> +                           (string->compiled-sglob pattern)
> +                           file))
> +                        (append
> +                         patterns
> +                         '("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]*"))))
> +                 (map (lambda (path)
> +                        (string-drop path 2))
                           ^
                         If this is meant to drop the "./" prefix, you
                         should be able to leave it out.

> +                      (find-files ".")))
`find-files' accepts an optional second argument called PRED, so you can
do that instead of the earlier 'filter'.

> +         install-dir)
> +        (begin
> +          (copy-recursively "." install-dir)
> +          ;; Remove references to dependencies
> +          (delete-file-recursively
> +           (string-append install-dir "/node_modules"))))
> +    (if (and main
> +             (not (file-exists?
> +                   (string-append
> +                    install-dir "/" (dirname main)))))
> +        (install-files (list main) install-dir))
           ^

This should not be needed if we use the 'old' (=non-files) approach of
installing. Do you think it makes sense to pull it into the previous
block that only runs on using the 'files' directive?

Thanks for you patience, and thanks again for working on this.

HTH,

 - Jelle

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

[paul]

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

Hi Jelle,

On 9/20/20 9:51 PM, Jelle Licht wrote:
> Hey Giacomo,
>
> Apologies for the delay! Better late than never, a review just for you.
No problem really, I spent some time AFK this summer and didn't ping 
soon enough.
> Perhaps 'pattern-list'? I keep reading this as patron-list. We could
> also build the patterns here. Mapping over the pattern-list + 'default
> patterns' here might also be a wee bit faster.
Yeah I actually don't know why I avoided to type two more letters in the 
first place. I didn't build the patterns here because that would have 
required storing the match result in a separate variable binding and 
requiring to check twice if the binding was false (which is the way I 
went in the new patch. The only slight downside in the new patch is that 
if the match result is #f then patterns is #<unspecified> but is also 
provably never accessed. If you can think of a better way to solve this, 
please do tell me), but mapping first is still more efficient, so I 
changed it.
>
>> +                     (#f #f)))
>> +         (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 directory)
>                                            ^
> You only use install-dir here: you could hard-code it in the lambda.
Definitely, I just fixed that.
>
>> +                          (for-each (lambda (file)
>> +                                      (install-file
>> +                                       file
>> +                                       (string-append directory "/"
>> +                                                      (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 patterns
>> +        (install-files
>> +         (filter (lambda (file)
>> +                   (any (lambda (pattern)
>> +                          (glob-match?
>> +                           (string->compiled-sglob pattern)
>> +                           file))
>> +                        (append
>> +                         patterns
>> +                         '("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]*"))))
>> +                 (map (lambda (path)
>> +                        (string-drop path 2))
>                             ^
>                           If this is meant to drop the "./" prefix, you
>                           should be able to leave it out.
>
>> +                      (find-files ".")))
> `find-files' accepts an optional second argument called PRED, so you can
> do that instead of the earlier 'filter'.
Thanks, I didn't know. Fixed :).
>
>> +         install-dir)
>> +        (begin
>> +          (copy-recursively "." install-dir)
>> +          ;; Remove references to dependencies
>> +          (delete-file-recursively
>> +           (string-append install-dir "/node_modules"))))
>> +    (if (and main
>> +             (not (file-exists?
>> +                   (string-append
>> +                    install-dir "/" (dirname main)))))
>> +        (install-files (list main) install-dir))
>             ^
>
> This should not be needed if we use the 'old' (=non-files) approach of
> installing. Do you think it makes sense to pull it into the previous
> block that only runs on using the 'files' directive?
I put this because also the "main" field from package.json is also 
guaranteed to be installed by NPM, according to 
https://docs.npmjs.com/files/package.json#main . Thus if a developer 
populates the "files" field without including the main file in that 
list, but they do insert it in the "main" field the file should be 
installed. Does it make sense?
> Thanks for you patience, and thanks again for working on this.
>
> HTH,
>
>   - Jelle

Thank you for your patience in reviewing this patch. I'm attaching an 
updated version of the second patch.

Cheers,

Giacomo


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

From 329ad1227ee537a630b3823e8d37db4862e023d5 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 | 67 +++++++++++++++++++++++++-------
 2 files changed, 57 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..6e11d1c142 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,59 @@ 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"))))
+    (if (and main
+             (not (file-exists?
+                   (string-append
+                    install-dir "/" (dirname main)))))
+        (install-files (list main)))
     (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 +173,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

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

[paul]

Hi Jelle,

just a quick follow up that I forgot yesterday.


>>> +                 (map (lambda (path)
>>> +                        (string-drop path 2))
>>                             ^
>>                           If this is meant to drop the "./" prefix, you
>>                           should be able to leave it out.
>>
This seems to be necessary because given the way glob-match? is 
implemented a string matches a pattern iif either they start with the 
same character or the pattern starts with a wildcard. So for example:


scheme@(guix-user)> ,use (guix glob)

scheme@(guix-user)> (string->compiled-sglob "*.json")

$1 = (* ".json")

scheme@(guix-user)> (string->compiled-sglob "package.json")

$2 = "package.json"

scheme@(guix-user)> (glob-match? $1 "./package.json")

$3 = #t

scheme@(guix-user)> (glob-match? $2 "./package.json")

$4 = #f


Thank you again for your help,

Cheers

Giacomo

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

[Jelle Licht]

Hey Giacomo,

paul <goodoldpaul@autistici.org> writes:
>>> +         install-dir)
>>> +        (begin
>>> +          (copy-recursively "." install-dir)
>>> +          ;; Remove references to dependencies
>>> +          (delete-file-recursively
>>> +           (string-append install-dir "/node_modules"))))
>>> +    (if (and main
>>> +             (not (file-exists?
>>> +                   (string-append
>>> +                    install-dir "/" (dirname main)))))
                                          ^

{New,Forgotten} nitpick; this only checks for the `dirname': why not
just `(string-append install-dir "/" main)'? Because if
e.g. "lib/utils.js" is in "files", and main is "lib/main.js", it seems
that main would not be installed with this snippet. Does that make
sense?

Thanks in advance,

- Jelle

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

[paul]

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

Dear Jelle,

On 9/22/20 8:09 PM, Jelle Licht wrote:
> Hey Giacomo,
>
> paul <goodoldpaul@autistici.org> writes:
>>>> +         install-dir)
>>>> +        (begin
>>>> +          (copy-recursively "." install-dir)
>>>> +          ;; Remove references to dependencies
>>>> +          (delete-file-recursively
>>>> +           (string-append install-dir "/node_modules"))))
>>>> +    (if (and main
>>>> +             (not (file-exists?
>>>> +                   (string-append
>>>> +                    install-dir "/" (dirname main)))))
>                                            ^
>
> {New,Forgotten} nitpick; this only checks for the `dirname': why not
> just `(string-append install-dir "/" main)'? Because if
> e.g. "lib/utils.js" is in "files", and main is "lib/main.js", it seems
> that main would not be installed with this snippet. Does that make
> sense?

Yes it definitely does. I believe I fixed this in the attached patch.

Thank you for your review,

Giacomo


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

From 3cc2a309f611ea1cd7cf1e0274ef81668819e058 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..3c15e7931b 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? 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

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

[paul]

[-- 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

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

[Jelle Licht]

Hey Giacomo,

paul <goodoldpaul@autistici.org> writes:

> 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.

I've been working on an alternative implementation to achieve what this
patch is trying to do; See [1] for what I tried. Do you think that
addresses your use-case as well? If so, perhaps we can still have a look
at the glob code you contributed, as it seems useful outside of an npm
context. 

Thanks!
 - Jelle

[1]: https://lists.gnu.org/archive/html/guix-devel/2020-10/msg00403.html

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

[paul]

Hi Jelle,

> I've been working on an alternative implementation to achieve what this
> patch is trying to do; See [1] for what I tried. Do you think that
> addresses your use-case as well? If so, perhaps we can still have a look
> at the glob code you contributed, as it seems useful outside of an npm
> context.

I think it definitely does, thank you for your work :D I agree that my 
patch to the node-build-system is not useful anymore, so if deem the 
other patch worth of being merged I'd go that way.

Thank you for your review,

Giacomo

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

[paul]

Dear Jelle,

do you believe that you can merge the globstar patch? Otherwise I would 
just close this issue if you agree with it.

Thank you for your time,

Giacomo

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

[Jelle Licht]

Dear Giacomo,

paul <goodoldpaul@autistici.org> writes:
> Dear Jelle,
>
> do you believe that you can merge the globstar patch? Otherwise I would 
> just close this issue if you agree with it.

I finally pushed your globstar patch to master in 371ba7b4b.

> Thank you for your time,

Thank you for your patience!
 - Jelle