* [bug#36602] [PATCH] Add node-build-system.
@ 2019-07-11 16:46 Julien Lepiller
2019-07-11 18:25 ` Jelle Licht
` (2 more replies)
0 siblings, 3 replies; 10+ messages in thread
From: Julien Lepiller @ 2019-07-11 16:46 UTC (permalink / raw)
To: 36602
[-- Attachment #1: Type: text/plain, Size: 747 bytes --]
Hi Guix!
This patch adds a node-build-system. I wasn't sure if it was ready yet,
but I think, since I didn't change it in the last months, that it might
actually be :)
The patch was initially made by Jelle Licht, and I improved a bit on
it. Note that packages built with this build system will embed symlinks
to their dependencies, but not devDependencies (build-only
dependencies) according to the information in the metadata. Each
package is installed in lib/node_modules/package-name and symlinks are
added to lib/node_modules/package-name/node_modules. This allows us to
use only inputs instead of propagated inputs. Executables are installed
in bin according to metadata, and they should work even if called
directly from their store path.
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-build-Add-node-build-system.patch --]
[-- Type: text/x-patch, Size: 26501 bytes --]
From 38158940be0ef4780cdbb553cfa039d21fcdda9b Mon Sep 17 00:00:00 2001
From: Jelle Licht <jlicht@fsfe.org>
Date: Tue, 23 Aug 2016 05:23:55 +0200
Subject: [PATCH] build: Add node-build-system.
* guix/build/node-build-system.scm: New file.
* guix/build-system/node.scm: New file.
* guix/build/json.scm: New file.
* doc/guix.texi: Document it.
* Makefile.am: Added new files.
Co-Authored-By: Julien Lepiller <julien@lepiller.eu>
---
Makefile.am | 2 +
doc/guix.texi | 11 +
guix/build-system/node.scm | 139 +++++++++++
guix/build/json.scm | 387 +++++++++++++++++++++++++++++++
guix/build/node-build-system.scm | 159 +++++++++++++
5 files changed, 698 insertions(+)
create mode 100644 guix/build-system/node.scm
create mode 100644 guix/build/json.scm
create mode 100644 guix/build/node-build-system.scm
diff --git a/Makefile.am b/Makefile.am
index 82eda6042a..38f2d7e690 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -125,6 +125,7 @@ MODULES = \
guix/build-system/guile.scm \
guix/build-system/haskell.scm \
guix/build-system/linux-module.scm \
+ guix/build-system/node.scm \
guix/build-system/perl.scm \
guix/build-system/python.scm \
guix/build-system/ocaml.scm \
@@ -170,6 +171,7 @@ MODULES = \
guix/build/gnu-build-system.scm \
guix/build/gnu-dist.scm \
guix/build/guile-build-system.scm \
+ guix/build/node-build-system.scm \
guix/build/perl-build-system.scm \
guix/build/python-build-system.scm \
guix/build/ocaml-build-system.scm \
diff --git a/doc/guix.texi b/doc/guix.texi
index 3e0788ed3a..8ef2006d18 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -6333,6 +6333,17 @@ the module (in the "arguments" form of a package using the
linux-module-build-system, use the key #:linux to specify it).
@end defvr
+@defvr {Scheme Variable} node-build-system
+This variable is exported by @code{(guix build-system node)}. It
+implements the build procedure used by @uref{http://nodejs.org,
+Node.js}, which implements an approximation of the @code{npm install}
+command, followed by an @code{npm test} command.
+
+Which Node.js package is used to interpret the @code{npm} commands can
+be specified with the @code{#:node} parameter which defaults to
+@code{node}.
+@end defvr
+
Lastly, for packages that do not need anything as sophisticated, a
``trivial'' build system is provided. It is trivial in the sense that
it provides basically no support: it does not pull any implicit inputs,
diff --git a/guix/build-system/node.scm b/guix/build-system/node.scm
new file mode 100644
index 0000000000..b6d3629049
--- /dev/null
+++ b/guix/build-system/node.scm
@@ -0,0 +1,139 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 Jelle Licht <jlicht@fsfe.org>
+;;;
+;;; 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-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 (ice-9 match)
+ #:export (npm-meta-uri
+ %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
+
+(define (default-node)
+ "Return the default Node package."
+ ;; Lazily resolve the binding to avoid a circular dependency.
+ (let ((node (resolve-interface '(gnu packages node))))
+ (module-ref node 'node-lts)))
+
+(define* (lower name
+ #:key source inputs native-inputs outputs system target
+ (node (default-node))
+ #:allow-other-keys
+ #:rest arguments)
+ "Return a bag for NAME."
+ (define private-keywords
+ '(#:source #:target #:node #:inputs #:native-inputs))
+
+ (and (not target) ;XXX: no cross-compilation
+ (bag
+ (name name)
+ (system system)
+ (host-inputs `(,@(if source
+ `(("source" ,source))
+ '())
+ ,@inputs
+
+ ;; Keep the standard inputs of 'gnu-build-system'.
+ ,@(standard-packages)))
+ (build-inputs `(("node" ,node)
+ ,@native-inputs))
+ (outputs outputs)
+ (build node-build)
+ (arguments (strip-keyword-arguments private-keywords arguments)))))
+
+(define* (node-build store name inputs
+ #:key
+ (npm-flags ''())
+ (global? #f)
+ (test-target "test")
+ (tests? #f)
+ (phases '(@ (guix build node-build-system)
+ %standard-phases))
+ (outputs '("out"))
+ (search-paths '())
+ (system (%current-system))
+ (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
+ `(begin
+ (use-modules ,@modules)
+ (node-build #:name ,name
+ #:source ,(match (assoc-ref inputs "source")
+ (((? derivation? source))
+ (derivation->output-path source))
+ ((source)
+ source)
+ (source
+ source))
+ #:system ,system
+ #:npm-flags ,npm-flags
+ #:global? ,global?
+ #:test-target ,test-target
+ #:tests? ,tests?
+ #:phases ,phases
+ #:outputs %outputs
+ #:search-paths ',(map search-path-specification->sexp
+ search-paths)
+ #:inputs %build-inputs)))
+
+ (define guile-for-build
+ (match guile
+ ((? package?)
+ (package-derivation store guile system #:graft? #f))
+ (#f
+ (let* ((distro (resolve-interface '(gnu packages commencement)))
+ (guile (module-ref distro 'guile-final)))
+ (package-derivation store guile system #:graft? #f)))))
+
+ (build-expression->derivation store name builder
+ #:inputs inputs
+ #:system system
+ #:modules imported-modules
+ #:outputs outputs
+ #:guile-for-build guile-for-build))
+
+(define node-build-system
+ (build-system
+ (name 'node)
+ (description "The standard Node build system")
+ (lower lower)))
diff --git a/guix/build/json.scm b/guix/build/json.scm
new file mode 100644
index 0000000000..361ea76728
--- /dev/null
+++ b/guix/build/json.scm
@@ -0,0 +1,387 @@
+;;;; json.scm --- JSON reader/writer
+;;;; Copyright (C) 2015 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library 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
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+(define-module (guix build json) ;; originally (ice-9 json)
+ #:use-module (ice-9 match)
+ #:export (read-json write-json))
+
+;; Snarfed from
+;; https://github.com/cwebber/activitystuff/blob/master/activitystuff/contrib/json.scm
+;;
+
+;;;
+;;; Reader
+;;;
+
+(define (json-error port)
+ (throw 'json-error port))
+
+(define (assert-char port char)
+ "Read a character from PORT and throw an invalid JSON error if the
+character is not CHAR."
+ (unless (eqv? (read-char port) char)
+ (json-error port)))
+
+(define (whitespace? char)
+ "Return #t if CHAR is a whitespace character."
+ (char-set-contains? char-set:whitespace char))
+
+(define (consume-whitespace port)
+ "Discard characters from PORT until a non-whitespace character is
+encountered.."
+ (match (peek-char port)
+ ((? eof-object?) *unspecified*)
+ ((? whitespace?)
+ (read-char port)
+ (consume-whitespace port))
+ (_ *unspecified*)))
+
+(define (make-keyword-reader keyword value)
+ "Parse the keyword symbol KEYWORD as VALUE."
+ (let ((str (symbol->string keyword)))
+ (lambda (port)
+ (let loop ((i 0))
+ (cond
+ ((= i (string-length str)) value)
+ ((eqv? (string-ref str i) (read-char port))
+ (loop (1+ i)))
+ (else (json-error port)))))))
+
+(define read-true (make-keyword-reader 'true #t))
+(define read-false (make-keyword-reader 'false #f))
+(define read-null (make-keyword-reader 'null #nil))
+
+(define (read-hex-digit port)
+ "Read a hexadecimal digit from PORT."
+ (match (read-char port)
+ (#\0 0)
+ (#\1 1)
+ (#\2 2)
+ (#\3 3)
+ (#\4 4)
+ (#\5 5)
+ (#\6 6)
+ (#\7 7)
+ (#\8 8)
+ (#\9 9)
+ ((or #\A #\a) 10)
+ ((or #\B #\b) 11)
+ ((or #\C #\c) 12)
+ ((or #\D #\d) 13)
+ ((or #\E #\e) 14)
+ ((or #\F #\f) 15)
+ (_ (json-error port))))
+
+(define (read-utf16-character port)
+ "Read a hexadecimal encoded UTF-16 character from PORT."
+ (integer->char
+ (+ (* (read-hex-digit port) (expt 16 3))
+ (* (read-hex-digit port) (expt 16 2))
+ (* (read-hex-digit port) 16)
+ (read-hex-digit port))))
+
+(define (read-escape-character port)
+ "Read escape character from PORT."
+ (match (read-char port)
+ (#\" #\")
+ (#\\ #\\)
+ (#\/ #\/)
+ (#\b #\backspace)
+ (#\f #\page)
+ (#\n #\newline)
+ (#\r #\return)
+ (#\t #\tab)
+ (#\u (read-utf16-character port))
+ (_ (json-error port))))
+
+(define (read-string port)
+ "Read a JSON encoded string from PORT."
+ (assert-char port #\")
+ (let loop ((result '()))
+ (match (read-char port)
+ ((? eof-object?) (json-error port))
+ (#\" (list->string (reverse result)))
+ (#\\ (loop (cons (read-escape-character port) result)))
+ (char (loop (cons char result))))))
+
+(define char-set:json-digit
+ (char-set #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
+
+(define (digit? char)
+ (char-set-contains? char-set:json-digit char))
+
+(define (read-digit port)
+ "Read a digit 0-9 from PORT."
+ (match (read-char port)
+ (#\0 0)
+ (#\1 1)
+ (#\2 2)
+ (#\3 3)
+ (#\4 4)
+ (#\5 5)
+ (#\6 6)
+ (#\7 7)
+ (#\8 8)
+ (#\9 9)
+ (else (json-error port))))
+
+(define (read-digits port)
+ "Read a sequence of digits from PORT."
+ (let loop ((result '()))
+ (match (peek-char port)
+ ((? eof-object?)
+ (reverse result))
+ ((? digit?)
+ (loop (cons (read-digit port) result)))
+ (else (reverse result)))))
+
+(define (list->integer digits)
+ "Convert the list DIGITS to an integer."
+ (let loop ((i (1- (length digits)))
+ (result 0)
+ (digits digits))
+ (match digits
+ (() result)
+ ((n . tail)
+ (loop (1- i)
+ (+ result (* n (expt 10 i)))
+ tail)))))
+
+(define (read-positive-integer port)
+ "Read a positive integer with no leading zeroes from PORT."
+ (match (read-digits port)
+ ((0 . _)
+ (json-error port)) ; no leading zeroes allowed
+ ((digits ...)
+ (list->integer digits))))
+
+(define (read-exponent port)
+ "Read exponent from PORT."
+ (define (read-expt)
+ (list->integer (read-digits port)))
+
+ (unless (memv (read-char port) '(#\e #\E))
+ (json-error port))
+
+ (match (peek-char port)
+ ((? eof-object?)
+ (json-error port))
+ (#\-
+ (read-char port)
+ (- (read-expt)))
+ (#\+
+ (read-char port)
+ (read-expt))
+ ((? digit?)
+ (read-expt))
+ (_ (json-error port))))
+
+(define (read-fraction port)
+ "Read fractional number part from PORT as an inexact number."
+ (let* ((digits (read-digits port))
+ (numerator (list->integer digits))
+ (denomenator (expt 10 (length digits))))
+ (/ numerator denomenator)))
+
+(define (read-positive-number port)
+ "Read a positive number from PORT."
+ (let* ((integer (match (peek-char port)
+ ((? eof-object?)
+ (json-error port))
+ (#\0
+ (read-char port)
+ 0)
+ ((? digit?)
+ (read-positive-integer port))
+ (_ (json-error port))))
+ (fraction (match (peek-char port)
+ (#\.
+ (read-char port)
+ (read-fraction port))
+ (_ 0)))
+ (exponent (match (peek-char port)
+ ((or #\e #\E)
+ (read-exponent port))
+ (_ 0)))
+ (n (* (+ integer fraction) (expt 10 exponent))))
+
+ ;; Keep integers as exact numbers, but convert numbers encoded as
+ ;; floating point numbers to an inexact representation.
+ (if (zero? fraction)
+ n
+ (exact->inexact n))))
+
+(define (read-number port)
+ "Read a number from PORT"
+ (match (peek-char port)
+ ((? eof-object?)
+ (json-error port))
+ (#\-
+ (read-char port)
+ (- (read-positive-number port)))
+ ((? digit?)
+ (read-positive-number port))
+ (_ (json-error port))))
+
+(define (read-object port)
+ "Read key/value map from PORT."
+ (define (read-key+value-pair)
+ (let ((key (read-string port)))
+ (consume-whitespace port)
+ (assert-char port #\:)
+ (consume-whitespace port)
+ (let ((value (read-value port)))
+ (cons key value))))
+
+ (assert-char port #\{)
+ (consume-whitespace port)
+
+ (if (eqv? #\} (peek-char port))
+ (begin
+ (read-char port)
+ '(@)) ; empty object
+ (let loop ((result (list (read-key+value-pair))))
+ (consume-whitespace port)
+ (match (peek-char port)
+ (#\, ; read another value
+ (read-char port)
+ (consume-whitespace port)
+ (loop (cons (read-key+value-pair) result)))
+ (#\} ; end of object
+ (read-char port)
+ (cons '@ (reverse result)))
+ (_ (json-error port))))))
+
+(define (read-array port)
+ "Read array from PORT."
+ (assert-char port #\[)
+ (consume-whitespace port)
+
+ (if (eqv? #\] (peek-char port))
+ (begin
+ (read-char port)
+ '()) ; empty array
+ (let loop ((result (list (read-value port))))
+ (consume-whitespace port)
+ (match (peek-char port)
+ (#\, ; read another value
+ (read-char port)
+ (consume-whitespace port)
+ (loop (cons (read-value port) result)))
+ (#\] ; end of array
+ (read-char port)
+ (reverse result))
+ (_ (json-error port))))))
+
+(define (read-value port)
+ "Read a JSON value from PORT."
+ (consume-whitespace port)
+ (match (peek-char port)
+ ((? eof-object?) (json-error port))
+ (#\" (read-string port))
+ (#\{ (read-object port))
+ (#\[ (read-array port))
+ (#\t (read-true port))
+ (#\f (read-false port))
+ (#\n (read-null port))
+ ((or #\- (? digit?))
+ (read-number port))
+ (_ (json-error port))))
+
+(define (read-json port)
+ "Read JSON text from port and return an s-expression representation."
+ (let ((result (read-value port)))
+ (consume-whitespace port)
+ (unless (eof-object? (peek-char port))
+ (json-error port))
+ result))
+
+\f
+;;;
+;;; Writer
+;;;
+
+(define (write-string str port)
+ "Write STR to PORT in JSON string format."
+ (define (escape-char char)
+ (display (match char
+ (#\" "\\\"")
+ (#\\ "\\\\")
+ (#\/ "\\/")
+ (#\backspace "\\b")
+ (#\page "\\f")
+ (#\newline "\\n")
+ (#\return "\\r")
+ (#\tab "\\t")
+ (_ char))
+ port))
+
+ (display "\"" port)
+ (string-for-each escape-char str)
+ (display "\"" port))
+
+(define (write-object alist port)
+ "Write ALIST to PORT in JSON object format."
+ ;; Keys may be strings or symbols.
+ (define key->string
+ (match-lambda
+ ((? string? key) key)
+ ((? symbol? key) (symbol->string key))))
+
+ (define (write-pair pair)
+ (match pair
+ ((key . value)
+ (write-string (key->string key) port)
+ (display ":" port)
+ (write-json value port))))
+
+ (display "{" port)
+ (match alist
+ (() #f)
+ ((front ... end)
+ (for-each (lambda (pair)
+ (write-pair pair)
+ (display "," port))
+ front)
+ (write-pair end)))
+ (display "}" port))
+
+(define (write-array lst port)
+ "Write LST to PORT in JSON array format."
+ (display "[" port)
+ (match lst
+ (() #f)
+ ((front ... end)
+ (for-each (lambda (val)
+ (write-json val port)
+ (display "," port))
+ front)
+ (write-json end port)))
+ (display "]" port))
+
+(define (write-json exp port)
+ "Write EXP to PORT in JSON format."
+ (match exp
+ (#t (display "true" port))
+ (#f (display "false" port))
+ ;; Differentiate #nil from '().
+ ((and (? boolean? ) #nil) (display "null" port))
+ ((? string? s) (write-string s port))
+ ((? real? n) (display n port))
+ (('@ . alist) (write-object alist port))
+ ((vals ...) (write-array vals port))))
diff --git a/guix/build/node-build-system.scm b/guix/build/node-build-system.scm
new file mode 100644
index 0000000000..588f51fd25
--- /dev/null
+++ b/guix/build/node-build-system.scm
@@ -0,0 +1,159 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015 David Thompson <davet@gnu.org>
+;;; Copyright © 2016 Jelle Licht <jlicht@fsfe.org>
+;;;
+;;; 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 json)
+ #:use-module (guix build union)
+ #:use-module (guix build utils)
+ #: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.
+;;
+;; Code:
+
+(define* (read-package-data #:key (filename "package.json"))
+ (call-with-input-file filename
+ (lambda (port)
+ (read-json port))))
+
+(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")))
+ #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 link-npm-dependencies)
+
+(define* (check #:key tests? #:allow-other-keys)
+ "Run 'npm test' if TESTS?"
+ (if tests?
+ ;; Should only be enabled once we know that there are tests
+ (invoke "npm" "test"))
+ #t)
+
+(define (node-package? name)
+ "Check if NAME correspond to the name of an Node package."
+ (string-prefix? "node-" name))
+
+(define* (install #:key outputs inputs global? #:allow-other-keys)
+ "Install the node module to the output store item. MODULENAME defines
+under which name the module will be installed, GLOBAL? determines whether this
+is an npm global install."
+ (let* ((out (assoc-ref outputs "out"))
+ (src-dir (getcwd))
+ (tgt-dir (string-append out "/lib"))
+ (bin-dir (string-append out "/bin"))
+ (modulename (string-append (assoc-ref (read-package-data) "name")))
+ (data (read-package-data))
+ (bin-conf (assoc-ref data "bin"))
+ (dependencies (match (assoc-ref data "dependencies")
+ ((@ deps ...) deps)
+ (#f #f))))
+ (mkdir-p tgt-dir)
+ (copy-recursively "." (string-append tgt-dir "/node_modules/" modulename))
+ ;; Remove references to dependencies
+ (delete-file-recursively
+ (string-append tgt-dir "/node_modules/" modulename "/node_modules"))
+ (when global?
+ (cond
+ ((string? bin-conf)
+ (begin
+ (mkdir-p bin-dir)
+ (symlink (string-append tgt-dir "/node_modules/" modulename "/" bin-conf)
+ (string-append bin-dir "/" modulename))))
+ ((list? bin-conf)
+ (for-each
+ (lambda conf
+ (match conf
+ ((key . value)
+ (begin
+ (mkdir-p (dirname (string-append bin-dir "/" key)))
+ (symlink (string-append tgt-dir "/node_modules/" modulename "/" value)
+ (string-append bin-dir "/" key))))))
+ bin-conf))
+ (else
+ (symlink (string-append tgt-dir "/node_modules/" modulename "/bin") bin-dir))))
+ (when dependencies
+ (mkdir-p
+ (string-append tgt-dir "/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 tgt-dir "/node_modules/" modulename
+ "/node_modules/" dependency))))
+ dependencies))
+ #t))
+
+
+(define %standard-phases
+ (modify-phases gnu:%standard-phases
+ (replace 'configure configure)
+ (replace 'build build)
+ (replace 'install install)
+ (delete 'check)
+ (add-after 'install 'check check)
+ (delete 'strip)))
+
+(define* (node-build #:key inputs (phases %standard-phases)
+ #:allow-other-keys #:rest args)
+ (apply gnu:gnu-build #:inputs inputs #:phases phases args))
--
2.22.0
^ permalink raw reply related [flat|nested] 10+ messages in thread
* [bug#36602] [PATCH] Add node-build-system.
2019-07-11 16:46 [bug#36602] [PATCH] Add node-build-system Julien Lepiller
@ 2019-07-11 18:25 ` Jelle Licht
2019-07-13 12:42 ` Ludovic Courtès
2019-07-13 15:32 ` goodoldpaul
2019-07-14 11:09 ` [bug#36602] guix/build/json.scm Robert Vollmert
2 siblings, 1 reply; 10+ messages in thread
From: Jelle Licht @ 2019-07-11 18:25 UTC (permalink / raw)
To: Julien Lepiller, 36602
Hello Julien,
Julien Lepiller <julien@lepiller.eu> writes:
> Hi Guix!
>
> This patch adds a node-build-system. I wasn't sure if it was ready yet,
> but I think, since I didn't change it in the last months, that it might
> actually be :)
>
> The patch was initially made by Jelle Licht, and I improved a bit on
> it. Note that packages built with this build system will embed symlinks
> to their dependencies, but not devDependencies (build-only
> dependencies) according to the information in the metadata. Each
> package is installed in lib/node_modules/package-name and symlinks are
> added to lib/node_modules/package-name/node_modules. This allows us to
> use only inputs instead of propagated inputs. Executables are installed
> in bin according to metadata, and they should work even if called
> directly from their store path.
I am probably a bit of a hypocrite for the following nitpicks, as I am
quite sure I was the one that introduced pretty much all of them them,
so I offer my apologies in advance :-).
> From 38158940be0ef4780cdbb553cfa039d21fcdda9b Mon Sep 17 00:00:00 2001
> From: Jelle Licht <jlicht@fsfe.org>
> Date: Tue, 23 Aug 2016 05:23:55 +0200
> Subject: [PATCH] build: Add node-build-system.
>
> * guix/build/node-build-system.scm: New file.
> * guix/build-system/node.scm: New file.
> * guix/build/json.scm: New file.
> * doc/guix.texi: Document it.
> * Makefile.am: Added new files.
>
> Co-Authored-By: Julien Lepiller <julien@lepiller.eu>
> ---
> Makefile.am | 2 +
> doc/guix.texi | 11 +
> guix/build-system/node.scm | 139 +++++++++++
> guix/build/json.scm | 387 +++++++++++++++++++++++++++++++
> guix/build/node-build-system.scm | 159 +++++++++++++
> 5 files changed, 698 insertions(+)
> create mode 100644 guix/build-system/node.scm
> create mode 100644 guix/build/json.scm
> create mode 100644 guix/build/node-build-system.scm
>
> diff --git a/Makefile.am b/Makefile.am
> index 82eda6042a..38f2d7e690 100644
> --- a/Makefile.am
> +++ b/Makefile.am
> @@ -125,6 +125,7 @@ MODULES = \
> guix/build-system/guile.scm \
> guix/build-system/haskell.scm \
> guix/build-system/linux-module.scm \
> + guix/build-system/node.scm \
> guix/build-system/perl.scm \
> guix/build-system/python.scm \
> guix/build-system/ocaml.scm \
> @@ -170,6 +171,7 @@ MODULES = \
> guix/build/gnu-build-system.scm \
> guix/build/gnu-dist.scm \
> guix/build/guile-build-system.scm \
> + guix/build/node-build-system.scm \
We are missing the `json.scm' file in this listing.
> [snip]
> +(define* (node-build store name inputs
> + #:key
> + (npm-flags ''())
> + (global? #f)
I am not quite sure if this is needed. Put another way: would we not
want all package builds to have `global? #t' in Guix?
> + (test-target "test")
This one is no longer in use.
> + (tests? #f)
I know that for most modules we will not even be able to run tests, but
it seems silly to disable them by default, as that would hide the issue.
> [snip]
> +(define* (install #:key outputs inputs global? #:allow-other-keys)
> + "Install the node module to the output store item. MODULENAME defines
> +under which name the module will be installed, GLOBAL? determines whether this
> +is an npm global install."
> + (let* ((out (assoc-ref outputs "out"))
> + (src-dir (getcwd))
> + (tgt-dir (string-append out "/lib"))
> + (bin-dir (string-append out "/bin"))
> + (modulename (string-append (assoc-ref (read-package-data) "name")))
> + (data (read-package-data))
> + (bin-conf (assoc-ref data "bin"))
> + (dependencies (match (assoc-ref data "dependencies")
> + ((@ deps ...) deps)
> + (#f #f))))
It might be better to write out most of these
names. I think we could also move `modulename' one line lower, so it can
become `(modulename (assoc-ref data "name"))'.
If you want me to tidy up these things, let me know; I can do it first
thing after the weekend.
Thanks
Jelle
^ permalink raw reply [flat|nested] 10+ messages in thread
* [bug#36602] [PATCH] Add node-build-system.
2019-07-11 18:25 ` Jelle Licht
@ 2019-07-13 12:42 ` Ludovic Courtès
2019-07-13 20:20 ` Julien Lepiller
0 siblings, 1 reply; 10+ messages in thread
From: Ludovic Courtès @ 2019-07-13 12:42 UTC (permalink / raw)
To: Jelle Licht; +Cc: 36602
Hello!
Nice work! I wonder if this could be used for the ‘node-semver’ package
that arrived at about the same time: <https://issues.guix.gnu.org/issue/36599>.
Jelle Licht <jlicht@fsfe.org> skribis:
>> +(define* (install #:key outputs inputs global? #:allow-other-keys)
>> + "Install the node module to the output store item. MODULENAME defines
>> +under which name the module will be installed, GLOBAL? determines whether this
>> +is an npm global install."
>> + (let* ((out (assoc-ref outputs "out"))
>> + (src-dir (getcwd))
>> + (tgt-dir (string-append out "/lib"))
>> + (bin-dir (string-append out "/bin"))
>> + (modulename (string-append (assoc-ref (read-package-data) "name")))
>> + (data (read-package-data))
>> + (bin-conf (assoc-ref data "bin"))
>> + (dependencies (match (assoc-ref data "dependencies")
>> + ((@ deps ...) deps)
Note that ‘@’ here matches anything. Did you mean '@, which would match
the @ symbol?
>> + (#f #f))))
> It might be better to write out most of these
> names. I think we could also move `modulename' one line lower, so it can
> become `(modulename (assoc-ref data "name"))'.
I’m gratuitously nitpicking as well :-), but I think we should spell out
names in general, so I’d propose s/src-dir/source/, s/tgt-dir/target/,
etc.
https://www.gnu.org/software/guix/manual/en/html_node/Formatting-Code.html
Anyway, thanks for working on it!
Ludo’.
^ permalink raw reply [flat|nested] 10+ messages in thread
* [bug#36602] [PATCH] Add node-build-system.
2019-07-11 16:46 [bug#36602] [PATCH] Add node-build-system Julien Lepiller
2019-07-11 18:25 ` Jelle Licht
@ 2019-07-13 15:32 ` goodoldpaul
2019-07-14 11:09 ` [bug#36602] guix/build/json.scm Robert Vollmert
2 siblings, 0 replies; 10+ messages in thread
From: goodoldpaul @ 2019-07-13 15:32 UTC (permalink / raw)
To: 36602
Hello!
I'm the author of: https://issues.guix.gnu.org/issue/36599 . It should
be really easy to rewrite the package using this new build system.
I submitted the patch before asking in #guix if someone was already
working on node's ecosystem, but when I did Julien pointed me to his
development branch which contains a definition for node-semver using the
new node-build system:
https://framagit.org/tyreunom/guix/commit/5c4708bfae0955999bca1edfd459aeb39980ab0e
.
If this is merged I can refactor my patch (which contains node-semver
6.2.0), based on Julien's package definition (which contains version
5.6.0), in no time!
Very cool work by the way,
Giacomo
^ permalink raw reply [flat|nested] 10+ messages in thread
* [bug#36602] [PATCH] Add node-build-system.
2019-07-13 12:42 ` Ludovic Courtès
@ 2019-07-13 20:20 ` Julien Lepiller
2019-07-13 21:30 ` Jelle Licht
0 siblings, 1 reply; 10+ messages in thread
From: Julien Lepiller @ 2019-07-13 20:20 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 36602
[-- Attachment #1: Type: text/plain, Size: 2053 bytes --]
Le Sat, 13 Jul 2019 14:42:38 +0200,
Ludovic Courtès <ludo@gnu.org> a écrit :
> Hello!
>
> Nice work! I wonder if this could be used for the ‘node-semver’
> package that arrived at about the same time:
> <https://issues.guix.gnu.org/issue/36599>.
>
> Jelle Licht <jlicht@fsfe.org> skribis:
>
> >> +(define* (install #:key outputs inputs global? #:allow-other-keys)
> >> + "Install the node module to the output store item. MODULENAME
> >> defines +under which name the module will be installed, GLOBAL?
> >> determines whether this +is an npm global install."
> >> + (let* ((out (assoc-ref outputs "out"))
> >> + (src-dir (getcwd))
> >> + (tgt-dir (string-append out "/lib"))
> >> + (bin-dir (string-append out "/bin"))
> >> + (modulename (string-append (assoc-ref
> >> (read-package-data) "name")))
> >> + (data (read-package-data))
> >> + (bin-conf (assoc-ref data "bin"))
> >> + (dependencies (match (assoc-ref data "dependencies")
> >> + ((@ deps ...) deps)
>
> Note that ‘@’ here matches anything. Did you mean '@, which would
> match the @ symbol?
>
> >> + (#f #f))))
> > It might be better to write out most of these
> > names. I think we could also move `modulename' one line lower, so
> > it can become `(modulename (assoc-ref data "name"))'.
>
> I’m gratuitously nitpicking as well :-), but I think we should spell
> out names in general, so I’d propose s/src-dir/source/,
> s/tgt-dir/target/, etc.
>
> https://www.gnu.org/software/guix/manual/en/html_node/Formatting-Code.html
>
> Anyway, thanks for working on it!
>
> Ludo’.
Hopefully, the attached patch fixes your (and Jelle's) points. I also
fixed the default node package (it was node-lts, but that doesn't exist
anymore), made the configure phase return #t and fixed the
binary-configuration. I tested again on a few packages and they built
without issue.
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-build-Add-node-build-system.patch --]
[-- Type: text/x-patch, Size: 26728 bytes --]
From cb1f067cdf8dcfae23e01f86a12da032bc7d9fbb Mon Sep 17 00:00:00 2001
From: Jelle Licht <jlicht@fsfe.org>
Date: Tue, 23 Aug 2016 05:23:55 +0200
Subject: [PATCH] build: Add node-build-system.
* guix/build/node-build-system.scm: New file.
* guix/build-system/node.scm: New file.
* guix/build/json.scm: New file.
* doc/guix.texi: Document it.
* Makefile.am: Added new files.
Co-Authored-By: Julien Lepiller <julien@lepiller.eu>
---
Makefile.am | 3 +
doc/guix.texi | 11 +
guix/build-system/node.scm | 135 +++++++++++
guix/build/json.scm | 387 +++++++++++++++++++++++++++++++
guix/build/node-build-system.scm | 164 +++++++++++++
5 files changed, 700 insertions(+)
create mode 100644 guix/build-system/node.scm
create mode 100644 guix/build/json.scm
create mode 100644 guix/build/node-build-system.scm
diff --git a/Makefile.am b/Makefile.am
index 82eda6042a..9839bf27cc 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -125,6 +125,7 @@ MODULES = \
guix/build-system/guile.scm \
guix/build-system/haskell.scm \
guix/build-system/linux-module.scm \
+ guix/build-system/node.scm \
guix/build-system/perl.scm \
guix/build-system/python.scm \
guix/build-system/ocaml.scm \
@@ -170,6 +171,7 @@ MODULES = \
guix/build/gnu-build-system.scm \
guix/build/gnu-dist.scm \
guix/build/guile-build-system.scm \
+ guix/build/node-build-system.scm \
guix/build/perl-build-system.scm \
guix/build/python-build-system.scm \
guix/build/ocaml-build-system.scm \
@@ -182,6 +184,7 @@ MODULES = \
guix/build/haskell-build-system.scm \
guix/build/linux-module-build-system.scm \
guix/build/store-copy.scm \
+ guix/build/json.scm \
guix/build/utils.scm \
guix/build/union.scm \
guix/build/profiles.scm \
diff --git a/doc/guix.texi b/doc/guix.texi
index 5a8ad7ebda..4a9832d9e6 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -6333,6 +6333,17 @@ the module (in the "arguments" form of a package using the
linux-module-build-system, use the key #:linux to specify it).
@end defvr
+@defvr {Scheme Variable} node-build-system
+This variable is exported by @code{(guix build-system node)}. It
+implements the build procedure used by @uref{http://nodejs.org,
+Node.js}, which implements an approximation of the @code{npm install}
+command, followed by an @code{npm test} command.
+
+Which Node.js package is used to interpret the @code{npm} commands can
+be specified with the @code{#:node} parameter which defaults to
+@code{node}.
+@end defvr
+
Lastly, for packages that do not need anything as sophisticated, a
``trivial'' build system is provided. It is trivial in the sense that
it provides basically no support: it does not pull any implicit inputs,
diff --git a/guix/build-system/node.scm b/guix/build-system/node.scm
new file mode 100644
index 0000000000..05c24c47d5
--- /dev/null
+++ b/guix/build-system/node.scm
@@ -0,0 +1,135 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 Jelle Licht <jlicht@fsfe.org>
+;;;
+;;; 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-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 (ice-9 match)
+ #:export (npm-meta-uri
+ %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
+
+(define (default-node)
+ "Return the default Node package."
+ ;; Lazily resolve the binding to avoid a circular dependency.
+ (let ((node (resolve-interface '(gnu packages node))))
+ (module-ref node 'node)))
+
+(define* (lower name
+ #:key source inputs native-inputs outputs system target
+ (node (default-node))
+ #:allow-other-keys
+ #:rest arguments)
+ "Return a bag for NAME."
+ (define private-keywords
+ '(#:source #:target #:node #:inputs #:native-inputs))
+
+ (and (not target) ;XXX: no cross-compilation
+ (bag
+ (name name)
+ (system system)
+ (host-inputs `(,@(if source
+ `(("source" ,source))
+ '())
+ ,@inputs
+
+ ;; Keep the standard inputs of 'gnu-build-system'.
+ ,@(standard-packages)))
+ (build-inputs `(("node" ,node)
+ ,@native-inputs))
+ (outputs outputs)
+ (build node-build)
+ (arguments (strip-keyword-arguments private-keywords arguments)))))
+
+(define* (node-build store name inputs
+ #:key
+ (npm-flags ''())
+ (tests? #t)
+ (phases '(@ (guix build node-build-system)
+ %standard-phases))
+ (outputs '("out"))
+ (search-paths '())
+ (system (%current-system))
+ (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
+ `(begin
+ (use-modules ,@modules)
+ (node-build #:name ,name
+ #:source ,(match (assoc-ref inputs "source")
+ (((? derivation? source))
+ (derivation->output-path source))
+ ((source)
+ source)
+ (source
+ source))
+ #:system ,system
+ #:npm-flags ,npm-flags
+ #:tests? ,tests?
+ #:phases ,phases
+ #:outputs %outputs
+ #:search-paths ',(map search-path-specification->sexp
+ search-paths)
+ #:inputs %build-inputs)))
+
+ (define guile-for-build
+ (match guile
+ ((? package?)
+ (package-derivation store guile system #:graft? #f))
+ (#f
+ (let* ((distro (resolve-interface '(gnu packages commencement)))
+ (guile (module-ref distro 'guile-final)))
+ (package-derivation store guile system #:graft? #f)))))
+
+ (build-expression->derivation store name builder
+ #:inputs inputs
+ #:system system
+ #:modules imported-modules
+ #:outputs outputs
+ #:guile-for-build guile-for-build))
+
+(define node-build-system
+ (build-system
+ (name 'node)
+ (description "The standard Node build system")
+ (lower lower)))
diff --git a/guix/build/json.scm b/guix/build/json.scm
new file mode 100644
index 0000000000..361ea76728
--- /dev/null
+++ b/guix/build/json.scm
@@ -0,0 +1,387 @@
+;;;; json.scm --- JSON reader/writer
+;;;; Copyright (C) 2015 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library 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
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+(define-module (guix build json) ;; originally (ice-9 json)
+ #:use-module (ice-9 match)
+ #:export (read-json write-json))
+
+;; Snarfed from
+;; https://github.com/cwebber/activitystuff/blob/master/activitystuff/contrib/json.scm
+;;
+
+;;;
+;;; Reader
+;;;
+
+(define (json-error port)
+ (throw 'json-error port))
+
+(define (assert-char port char)
+ "Read a character from PORT and throw an invalid JSON error if the
+character is not CHAR."
+ (unless (eqv? (read-char port) char)
+ (json-error port)))
+
+(define (whitespace? char)
+ "Return #t if CHAR is a whitespace character."
+ (char-set-contains? char-set:whitespace char))
+
+(define (consume-whitespace port)
+ "Discard characters from PORT until a non-whitespace character is
+encountered.."
+ (match (peek-char port)
+ ((? eof-object?) *unspecified*)
+ ((? whitespace?)
+ (read-char port)
+ (consume-whitespace port))
+ (_ *unspecified*)))
+
+(define (make-keyword-reader keyword value)
+ "Parse the keyword symbol KEYWORD as VALUE."
+ (let ((str (symbol->string keyword)))
+ (lambda (port)
+ (let loop ((i 0))
+ (cond
+ ((= i (string-length str)) value)
+ ((eqv? (string-ref str i) (read-char port))
+ (loop (1+ i)))
+ (else (json-error port)))))))
+
+(define read-true (make-keyword-reader 'true #t))
+(define read-false (make-keyword-reader 'false #f))
+(define read-null (make-keyword-reader 'null #nil))
+
+(define (read-hex-digit port)
+ "Read a hexadecimal digit from PORT."
+ (match (read-char port)
+ (#\0 0)
+ (#\1 1)
+ (#\2 2)
+ (#\3 3)
+ (#\4 4)
+ (#\5 5)
+ (#\6 6)
+ (#\7 7)
+ (#\8 8)
+ (#\9 9)
+ ((or #\A #\a) 10)
+ ((or #\B #\b) 11)
+ ((or #\C #\c) 12)
+ ((or #\D #\d) 13)
+ ((or #\E #\e) 14)
+ ((or #\F #\f) 15)
+ (_ (json-error port))))
+
+(define (read-utf16-character port)
+ "Read a hexadecimal encoded UTF-16 character from PORT."
+ (integer->char
+ (+ (* (read-hex-digit port) (expt 16 3))
+ (* (read-hex-digit port) (expt 16 2))
+ (* (read-hex-digit port) 16)
+ (read-hex-digit port))))
+
+(define (read-escape-character port)
+ "Read escape character from PORT."
+ (match (read-char port)
+ (#\" #\")
+ (#\\ #\\)
+ (#\/ #\/)
+ (#\b #\backspace)
+ (#\f #\page)
+ (#\n #\newline)
+ (#\r #\return)
+ (#\t #\tab)
+ (#\u (read-utf16-character port))
+ (_ (json-error port))))
+
+(define (read-string port)
+ "Read a JSON encoded string from PORT."
+ (assert-char port #\")
+ (let loop ((result '()))
+ (match (read-char port)
+ ((? eof-object?) (json-error port))
+ (#\" (list->string (reverse result)))
+ (#\\ (loop (cons (read-escape-character port) result)))
+ (char (loop (cons char result))))))
+
+(define char-set:json-digit
+ (char-set #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
+
+(define (digit? char)
+ (char-set-contains? char-set:json-digit char))
+
+(define (read-digit port)
+ "Read a digit 0-9 from PORT."
+ (match (read-char port)
+ (#\0 0)
+ (#\1 1)
+ (#\2 2)
+ (#\3 3)
+ (#\4 4)
+ (#\5 5)
+ (#\6 6)
+ (#\7 7)
+ (#\8 8)
+ (#\9 9)
+ (else (json-error port))))
+
+(define (read-digits port)
+ "Read a sequence of digits from PORT."
+ (let loop ((result '()))
+ (match (peek-char port)
+ ((? eof-object?)
+ (reverse result))
+ ((? digit?)
+ (loop (cons (read-digit port) result)))
+ (else (reverse result)))))
+
+(define (list->integer digits)
+ "Convert the list DIGITS to an integer."
+ (let loop ((i (1- (length digits)))
+ (result 0)
+ (digits digits))
+ (match digits
+ (() result)
+ ((n . tail)
+ (loop (1- i)
+ (+ result (* n (expt 10 i)))
+ tail)))))
+
+(define (read-positive-integer port)
+ "Read a positive integer with no leading zeroes from PORT."
+ (match (read-digits port)
+ ((0 . _)
+ (json-error port)) ; no leading zeroes allowed
+ ((digits ...)
+ (list->integer digits))))
+
+(define (read-exponent port)
+ "Read exponent from PORT."
+ (define (read-expt)
+ (list->integer (read-digits port)))
+
+ (unless (memv (read-char port) '(#\e #\E))
+ (json-error port))
+
+ (match (peek-char port)
+ ((? eof-object?)
+ (json-error port))
+ (#\-
+ (read-char port)
+ (- (read-expt)))
+ (#\+
+ (read-char port)
+ (read-expt))
+ ((? digit?)
+ (read-expt))
+ (_ (json-error port))))
+
+(define (read-fraction port)
+ "Read fractional number part from PORT as an inexact number."
+ (let* ((digits (read-digits port))
+ (numerator (list->integer digits))
+ (denomenator (expt 10 (length digits))))
+ (/ numerator denomenator)))
+
+(define (read-positive-number port)
+ "Read a positive number from PORT."
+ (let* ((integer (match (peek-char port)
+ ((? eof-object?)
+ (json-error port))
+ (#\0
+ (read-char port)
+ 0)
+ ((? digit?)
+ (read-positive-integer port))
+ (_ (json-error port))))
+ (fraction (match (peek-char port)
+ (#\.
+ (read-char port)
+ (read-fraction port))
+ (_ 0)))
+ (exponent (match (peek-char port)
+ ((or #\e #\E)
+ (read-exponent port))
+ (_ 0)))
+ (n (* (+ integer fraction) (expt 10 exponent))))
+
+ ;; Keep integers as exact numbers, but convert numbers encoded as
+ ;; floating point numbers to an inexact representation.
+ (if (zero? fraction)
+ n
+ (exact->inexact n))))
+
+(define (read-number port)
+ "Read a number from PORT"
+ (match (peek-char port)
+ ((? eof-object?)
+ (json-error port))
+ (#\-
+ (read-char port)
+ (- (read-positive-number port)))
+ ((? digit?)
+ (read-positive-number port))
+ (_ (json-error port))))
+
+(define (read-object port)
+ "Read key/value map from PORT."
+ (define (read-key+value-pair)
+ (let ((key (read-string port)))
+ (consume-whitespace port)
+ (assert-char port #\:)
+ (consume-whitespace port)
+ (let ((value (read-value port)))
+ (cons key value))))
+
+ (assert-char port #\{)
+ (consume-whitespace port)
+
+ (if (eqv? #\} (peek-char port))
+ (begin
+ (read-char port)
+ '(@)) ; empty object
+ (let loop ((result (list (read-key+value-pair))))
+ (consume-whitespace port)
+ (match (peek-char port)
+ (#\, ; read another value
+ (read-char port)
+ (consume-whitespace port)
+ (loop (cons (read-key+value-pair) result)))
+ (#\} ; end of object
+ (read-char port)
+ (cons '@ (reverse result)))
+ (_ (json-error port))))))
+
+(define (read-array port)
+ "Read array from PORT."
+ (assert-char port #\[)
+ (consume-whitespace port)
+
+ (if (eqv? #\] (peek-char port))
+ (begin
+ (read-char port)
+ '()) ; empty array
+ (let loop ((result (list (read-value port))))
+ (consume-whitespace port)
+ (match (peek-char port)
+ (#\, ; read another value
+ (read-char port)
+ (consume-whitespace port)
+ (loop (cons (read-value port) result)))
+ (#\] ; end of array
+ (read-char port)
+ (reverse result))
+ (_ (json-error port))))))
+
+(define (read-value port)
+ "Read a JSON value from PORT."
+ (consume-whitespace port)
+ (match (peek-char port)
+ ((? eof-object?) (json-error port))
+ (#\" (read-string port))
+ (#\{ (read-object port))
+ (#\[ (read-array port))
+ (#\t (read-true port))
+ (#\f (read-false port))
+ (#\n (read-null port))
+ ((or #\- (? digit?))
+ (read-number port))
+ (_ (json-error port))))
+
+(define (read-json port)
+ "Read JSON text from port and return an s-expression representation."
+ (let ((result (read-value port)))
+ (consume-whitespace port)
+ (unless (eof-object? (peek-char port))
+ (json-error port))
+ result))
+
+\f
+;;;
+;;; Writer
+;;;
+
+(define (write-string str port)
+ "Write STR to PORT in JSON string format."
+ (define (escape-char char)
+ (display (match char
+ (#\" "\\\"")
+ (#\\ "\\\\")
+ (#\/ "\\/")
+ (#\backspace "\\b")
+ (#\page "\\f")
+ (#\newline "\\n")
+ (#\return "\\r")
+ (#\tab "\\t")
+ (_ char))
+ port))
+
+ (display "\"" port)
+ (string-for-each escape-char str)
+ (display "\"" port))
+
+(define (write-object alist port)
+ "Write ALIST to PORT in JSON object format."
+ ;; Keys may be strings or symbols.
+ (define key->string
+ (match-lambda
+ ((? string? key) key)
+ ((? symbol? key) (symbol->string key))))
+
+ (define (write-pair pair)
+ (match pair
+ ((key . value)
+ (write-string (key->string key) port)
+ (display ":" port)
+ (write-json value port))))
+
+ (display "{" port)
+ (match alist
+ (() #f)
+ ((front ... end)
+ (for-each (lambda (pair)
+ (write-pair pair)
+ (display "," port))
+ front)
+ (write-pair end)))
+ (display "}" port))
+
+(define (write-array lst port)
+ "Write LST to PORT in JSON array format."
+ (display "[" port)
+ (match lst
+ (() #f)
+ ((front ... end)
+ (for-each (lambda (val)
+ (write-json val port)
+ (display "," port))
+ front)
+ (write-json end port)))
+ (display "]" port))
+
+(define (write-json exp port)
+ "Write EXP to PORT in JSON format."
+ (match exp
+ (#t (display "true" port))
+ (#f (display "false" port))
+ ;; Differentiate #nil from '().
+ ((and (? boolean? ) #nil) (display "null" port))
+ ((? string? s) (write-string s port))
+ ((? real? n) (display n port))
+ (('@ . alist) (write-object alist port))
+ ((vals ...) (write-array vals port))))
diff --git a/guix/build/node-build-system.scm b/guix/build/node-build-system.scm
new file mode 100644
index 0000000000..201664c5c1
--- /dev/null
+++ b/guix/build/node-build-system.scm
@@ -0,0 +1,164 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015 David Thompson <davet@gnu.org>
+;;; Copyright © 2016 Jelle Licht <jlicht@fsfe.org>
+;;;
+;;; 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 json)
+ #:use-module (guix build union)
+ #:use-module (guix build utils)
+ #: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.
+;;
+;; Code:
+
+(define* (read-package-data #:key (filename "package.json"))
+ (call-with-input-file filename
+ (lambda (port)
+ (read-json port))))
+
+(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")))
+ #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))
+ #t))
+
+(define configure link-npm-dependencies)
+
+(define* (check #:key tests? #:allow-other-keys)
+ "Run 'npm test' if TESTS?"
+ (if tests?
+ ;; Should only be enabled once we know that there are tests
+ (invoke "npm" "test"))
+ #t)
+
+(define (node-package? name)
+ "Check if NAME correspond to the name of an Node package."
+ (string-prefix? "node-" name))
+
+(define* (install #:key outputs inputs #:allow-other-keys)
+ "Install the node module to the output store item. MODULENAME defines
+under which name the module will be installed, GLOBAL? determines whether this
+is an npm global install."
+ (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))
+ (else
+ (symlink (string-append target "/node_modules/" modulename "/bin")
+ binaries)))
+ (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))
+ #t))
+
+
+(define %standard-phases
+ (modify-phases gnu:%standard-phases
+ (replace 'configure configure)
+ (replace 'build build)
+ (replace 'install install)
+ (delete 'check)
+ (add-after 'install 'check check)
+ (delete 'strip)))
+
+(define* (node-build #:key inputs (phases %standard-phases)
+ #:allow-other-keys #:rest args)
+ (apply gnu:gnu-build #:inputs inputs #:phases phases args))
--
2.22.0
^ permalink raw reply related [flat|nested] 10+ messages in thread
* [bug#36602] [PATCH] Add node-build-system.
2019-07-13 20:20 ` Julien Lepiller
@ 2019-07-13 21:30 ` Jelle Licht
2019-07-14 10:34 ` bug#36602: " Julien Lepiller
0 siblings, 1 reply; 10+ messages in thread
From: Jelle Licht @ 2019-07-13 21:30 UTC (permalink / raw)
To: Julien Lepiller, Ludovic Courtès; +Cc: 36602
Julien Lepiller <julien@lepiller.eu> writes:
> [...]
> +(define* (install #:key outputs inputs #:allow-other-keys)
> + "Install the node module to the output store item. MODULENAME defines
> +under which name the module will be installed, GLOBAL? determines whether this
> +is an npm global install."
`global?' is no longer , so it could probably be removed from the
docstring as well. LGTM otherwise :-).
^ permalink raw reply [flat|nested] 10+ messages in thread
* bug#36602: [PATCH] Add node-build-system.
2019-07-13 21:30 ` Jelle Licht
@ 2019-07-14 10:34 ` Julien Lepiller
2019-07-14 12:46 ` [bug#36602] " swedebugia
0 siblings, 1 reply; 10+ messages in thread
From: Julien Lepiller @ 2019-07-14 10:34 UTC (permalink / raw)
To: Jelle Licht; +Cc: 36602-done
Le Sat, 13 Jul 2019 23:30:12 +0200,
Jelle Licht <jlicht@fsfe.org> a écrit :
> Julien Lepiller <julien@lepiller.eu> writes:
>
> > [...]
> > +(define* (install #:key outputs inputs #:allow-other-keys)
> > + "Install the node module to the output store item. MODULENAME
> > defines +under which name the module will be installed, GLOBAL?
> > determines whether this +is an npm global install."
>
> `global?' is no longer , so it could probably be removed from the
> docstring as well. LGTM otherwise :-).
I've reworked that docstring and pushed as
09a1f92f61d1ab11d2cf9f7a0983f4fc9f436f57, thank you!
^ permalink raw reply [flat|nested] 10+ messages in thread
* [bug#36602] guix/build/json.scm
2019-07-11 16:46 [bug#36602] [PATCH] Add node-build-system Julien Lepiller
2019-07-11 18:25 ` Jelle Licht
2019-07-13 15:32 ` goodoldpaul
@ 2019-07-14 11:09 ` Robert Vollmert
2019-07-14 12:59 ` Julien Lepiller
2 siblings, 1 reply; 10+ messages in thread
From: Robert Vollmert @ 2019-07-14 11:09 UTC (permalink / raw)
To: 36602
Hi,
just had a look at 09a1f92f61d1ab11d2cf9f7a0983f4fc9f436f57, some questions:
- the link to https://github.com/cwebber/activitystuff/blob/master/activitystuff/contrib/json.scm
is a 404, and I can’t find (ice-9 json) elsewhere (also, shouldn’t cwebber be listed in the
copyright line?)
- how does this embedded json parsing module differ from (json parser) as used by the cargo
build system? wouldn’t it be better to have both use the same json modules?
Cheers
Robert
^ permalink raw reply [flat|nested] 10+ messages in thread
* [bug#36602] [PATCH] Add node-build-system.
2019-07-14 10:34 ` bug#36602: " Julien Lepiller
@ 2019-07-14 12:46 ` swedebugia
0 siblings, 0 replies; 10+ messages in thread
From: swedebugia @ 2019-07-14 12:46 UTC (permalink / raw)
To: 36602
On 2019-07-14 12:34, Julien Lepiller wrote:
> I've reworked that docstring and pushed as
> 09a1f92f61d1ab11d2cf9f7a0983f4fc9f436f57, thank you!
Wohoo! First small step to working node applications.
--
Cheers
Swedebugia
^ permalink raw reply [flat|nested] 10+ messages in thread
* [bug#36602] guix/build/json.scm
2019-07-14 11:09 ` [bug#36602] guix/build/json.scm Robert Vollmert
@ 2019-07-14 12:59 ` Julien Lepiller
0 siblings, 0 replies; 10+ messages in thread
From: Julien Lepiller @ 2019-07-14 12:59 UTC (permalink / raw)
To: Robert Vollmert; +Cc: 36602
Le Sun, 14 Jul 2019 13:09:18 +0200,
Robert Vollmert <rob@vllmrt.net> a écrit :
> Hi,
>
> just had a look at 09a1f92f61d1ab11d2cf9f7a0983f4fc9f436f57, some
> questions:
>
> - the link to
> https://github.com/cwebber/activitystuff/blob/master/activitystuff/contrib/json.scm
> is a 404, and I can’t find (ice-9 json) elsewhere (also, shouldn’t
> cwebber be listed in the copyright line?)
> - how does this embedded json parsing module differ from (json
> parser) as used by the cargo build system? wouldn’t it be better to
> have both use the same json modules?
>
> Cheers
> Robert
>
You're right, I thought we didn't use guile-json, but since we already
use it in the cargo build system, I removed (guix build json) and fixed
the node-build-system to use (json parser) instead. I tested a few
packages, so it should be working. I pushed the changes in
8eb0ba532ebbebef23180e666e0607ea735f9c1a.
^ permalink raw reply [flat|nested] 10+ messages in thread
end of thread, other threads:[~2019-07-14 13:00 UTC | newest]
Thread overview: 10+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2019-07-11 16:46 [bug#36602] [PATCH] Add node-build-system Julien Lepiller
2019-07-11 18:25 ` Jelle Licht
2019-07-13 12:42 ` Ludovic Courtès
2019-07-13 20:20 ` Julien Lepiller
2019-07-13 21:30 ` Jelle Licht
2019-07-14 10:34 ` bug#36602: " Julien Lepiller
2019-07-14 12:46 ` [bug#36602] " swedebugia
2019-07-13 15:32 ` goodoldpaul
2019-07-14 11:09 ` [bug#36602] guix/build/json.scm Robert Vollmert
2019-07-14 12:59 ` Julien Lepiller
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).