ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 13:28:12 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

build: Add node-build-system.

Browse source 
* 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>
This commit is contained in:
Jelle Licht 2016-08-23 05:23:55 +02:00 committed by Julien Lepiller
parent 041e03847b
commit 09a1f92f61
No known key found for this signature in database
GPG key ID: 43111F4520086A0C
5 changed files with 702 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
Makefile.am
View file

@ -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 \

11
doc/guix.texi
View file

@ -6346,6 +6346,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,

135
guix/build-system/node.scm Normal file
View file

@ -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)))

387
guix/build/json.scm Normal file
View file

@ -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))
;;;
;;; 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))))

166
guix/build/node-build-system.scm Normal file
View file

@ -0,0 +1,166 @@
;;; 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. The module itself is
installed in a subdirectory of @file{node_modules} and its runtime dependencies
as defined by @file{package.json} are symlinked into a @file{node_modules}
subdirectory of the module's directory. Additionally, binaries are installed in
the @file{bin} directory."
(let* ((out (assoc-ref outputs "out"))
(target (string-append out "/lib"))
(binaries (string-append out "/bin"))
(data (read-package-data))
(modulename (assoc-ref data "name"))
(binary-configuration (match (assoc-ref data "bin")
(('@ configuration ...) configuration)
((? string? configuration) configuration)
(#f #f)))
(dependencies (match (assoc-ref data "dependencies")
(('@ deps ...) deps)
(#f #f))))
(mkdir-p target)
(copy-recursively "." (string-append target "/node_modules/" modulename))
;; Remove references to dependencies
(delete-file-recursively
(string-append target "/node_modules/" modulename "/node_modules"))
(cond
((string? binary-configuration)
(begin
(mkdir-p binaries)
(symlink (string-append target "/node_modules/" modulename "/"
binary-configuration)
(string-append binaries "/" modulename))))
((list? binary-configuration)
(for-each
(lambda (conf)
(match conf
((key . value)
(begin
(mkdir-p (dirname (string-append binaries "/" key)))
(symlink (string-append target "/node_modules/" modulename "/"
value)
(string-append binaries "/" key))))))
binary-configuration))
(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))