diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | guix/build-system/node.scm | 10 | ||||
| -rw-r--r-- | guix/build/json.scm | 387 | ||||
| -rw-r--r-- | guix/build/node-build-system.scm | 28 |
4 files changed, 406 insertions, 20 deletions
diff --git a/Makefile.am b/Makefile.am index 38f2d7e690..9839bf27cc 100644 --- a/Makefile.am +++ b/Makefile.am @@ -184,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/guix/build-system/node.scm b/guix/build-system/node.scm index dad492dc95..05c24c47d5 100644 --- a/guix/build-system/node.scm +++ b/guix/build-system/node.scm @@ -18,6 +18,7 @@ (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) @@ -26,7 +27,6 @@ #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (ice-9 match) - #:use-module (json parser) #:export (npm-meta-uri %node-build-system-modules node-build @@ -40,8 +40,8 @@ registry." (define %node-build-system-modules ;; Build-side modules imported by default. `((guix build node-build-system) + (guix build json) (guix build union) - (json parser) ,@%gnu-build-system-modules)) ;; TODO: Might be not needed (define (default-node) @@ -88,9 +88,9 @@ registry." (guile #f) (imported-modules %node-build-system-modules) (modules '((guix build node-build-system) - (guix build union) - (guix build utils) - (json parser)))) + (guix build json) + (guix build union) + (guix build utils)))) "Build SOURCE using NODE and INPUTS." (define builder `(begin 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)) + + +;;; +;;; 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 index 231e60488a..3c0ac2a12b 100644 --- a/guix/build/node-build-system.scm +++ b/guix/build/node-build-system.scm @@ -19,12 +19,12 @@ (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 (json parser) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (%standard-phases @@ -39,12 +39,12 @@ (define* (read-package-data #:key (filename "package.json")) (call-with-input-file filename (lambda (port) - (json->scm 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 (hash-ref package-data "scripts"))) + (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 @@ -103,15 +103,13 @@ the @file{bin} directory." (target (string-append out "/lib")) (binaries (string-append out "/bin")) (data (read-package-data)) - (modulename (hash-ref data "name")) - (binary-configuration (match (hash-ref data "bin") - ((? hash-table? hash-table) - (hash-map->list cons hash-table)) - ((? string? configuration) configuration) - (#f #f))) - (dependencies (match (hash-ref data "dependencies") - ((? hash-table? hash-table) - (hash-map->list cons hash-table)) + (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)) @@ -123,7 +121,7 @@ the @file{bin} directory." (begin (mkdir-p binaries) (symlink (string-append target "/node_modules/" modulename "/" - binary-configuration) + binary-configuration) (string-append binaries "/" modulename)))) ((list? binary-configuration) (for-each @@ -133,12 +131,12 @@ the @file{bin} directory." (begin (mkdir-p (dirname (string-append binaries "/" key))) (symlink (string-append target "/node_modules/" modulename "/" - value) + value) (string-append binaries "/" key)))))) binary-configuration)) (else (symlink (string-append target "/node_modules/" modulename "/bin") - binaries))) + binaries))) (when dependencies (mkdir-p (string-append target "/node_modules/" modulename "/node_modules")) |