diff options
Diffstat (limited to 'guix/build')
| -rw-r--r-- | guix/build/cargo-build-system.scm | 12 | ||||
| -rw-r--r-- | guix/build/compile.scm | 32 | ||||
| -rw-r--r-- | guix/build/json.scm | 387 | ||||
| -rw-r--r-- | guix/build/node-build-system.scm | 166 | ||||
| -rw-r--r-- | guix/build/syscalls.scm | 19 |
5 files changed, 588 insertions, 28 deletions
diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index 1f36304b15..f38de16cf7 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -20,6 +20,7 @@ (define-module (guix build cargo-build-system) #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #:use-module (guix build json) #:use-module (guix build utils) #:use-module (guix build cargo-utils) #:use-module (ice-9 popen) @@ -27,7 +28,6 @@ #:use-module (ice-9 ftw) #:use-module (ice-9 format) #:use-module (ice-9 match) - #:use-module (json parser) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (%standard-phases @@ -42,15 +42,15 @@ (define (manifest-targets) "Extract all targets from the Cargo.toml manifest" (let* ((port (open-input-pipe "cargo read-manifest")) - (data (json->scm port)) - (targets (hash-ref data "targets" '()))) + (data (read-json port)) + (targets (or (assoc-ref data "targets") '()))) (close-port port) targets)) (define (has-executable-target?) "Check if the current cargo project declares any binary targets." (let* ((bin? (lambda (kind) (string=? kind "bin"))) - (get-kinds (lambda (dep) (hash-ref dep "kind"))) + (get-kinds (lambda (dep) (assoc-ref dep "kind"))) (bin-dep? (lambda (dep) (find bin? (get-kinds dep))))) (find bin-dep? (manifest-targets)))) @@ -99,6 +99,7 @@ Cargo.toml file present at its root." inputs) ;; Configure cargo to actually use this new directory. + (setenv "CARGO_HOME" (string-append (getcwd) "/.cargo")) (mkdir-p ".cargo") (let ((port (open-file ".cargo/config" "w" #:encoding "utf-8"))) (display " @@ -148,9 +149,6 @@ directory = '" port) ;; Make cargo reuse all the artifacts we just built instead ;; of defaulting to making a new temp directory (setenv "CARGO_TARGET_DIR" "./target") - ;; Force cargo to honor our .cargo/config definitions - ;; https://github.com/rust-lang/cargo/issues/6397 - (setenv "CARGO_HOME" ".") ;; Only install crates which include binary targets, ;; otherwise cargo will raise an error. diff --git a/guix/build/compile.scm b/guix/build/compile.scm index c8fe273f7e..c127456fd0 100644 --- a/guix/build/compile.scm +++ b/guix/build/compile.scm @@ -18,6 +18,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix build compile) + #:use-module (srfi srfi-1) #:use-module (ice-9 match) #:use-module (ice-9 format) #:use-module (ice-9 threads) @@ -58,13 +59,23 @@ ((kw _ rest ...) (loop rest `(#f ,kw ,@result)))))) +(define (supported-warning-type? type) + "Return true if TYPE, a symbol, denotes a supported warning type." + (find (lambda (warning-type) + (eq? type (warning-type-name warning-type))) + %warning-types)) + (define %warnings ;; FIXME: 'format' is missing because it reports "non-literal format ;; strings" due to the fact that we use 'G_' instead of '_'. We'll need ;; help from Guile to solve this. - '(unsupported-warning unbound-variable arity-mismatch - macro-use-before-definition ;new in 2.2 - shadowed-toplevel)) ;new in 2.2.5 + (let ((optional (lambda (type) + (if (supported-warning-type? type) + (list type) + '())))) + `(unbound-variable arity-mismatch + macro-use-before-definition ;new in 2.2 + ,@(optional 'shadowed-toplevel)))) ;new in 2.2.5 (define (optimization-options file) "Return the default set of optimizations options for FILE." @@ -118,8 +129,9 @@ front." (lambda () (set! path initial-value))))) -(define (call/exit-on-exception thunk) - "Evaluate THUNK and exit right away if an exception is thrown." +(define (call/exit-on-exception file thunk) + "Evaluate THUNK and exit right away if an exception is thrown. Report FILE +as the file that was being compiled when the exception was thrown." (catch #t thunk (const #f) @@ -130,15 +142,18 @@ front." (stack (make-stack #t)) (depth (stack-length stack)) (frame (and (> depth 1) (stack-ref stack 1)))) + (newline port) + (format port "error: failed to compile '~a':~%~%" file) (false-if-exception (display-backtrace stack port)) (print-exception port frame key args))) ;; Don't go any further. (primitive-exit 1)))) -(define-syntax-rule (exit-on-exception exp ...) - "Evaluate EXP and exit if an exception is thrown." - (call/exit-on-exception (lambda () exp ...))) +(define-syntax-rule (exit-on-exception file exp ...) + "Evaluate EXP and exit if an exception is thrown. Report FILE as the faulty +file when an exception is thrown." + (call/exit-on-exception file (lambda () exp ...))) (define* (compile-files source-directory build-directory files #:key @@ -162,6 +177,7 @@ files are for HOST, a GNU triplet such as \"x86_64-linux-gnu\"." ;; Exit as soon as something goes wrong. (exit-on-exception + file (with-target host (lambda () (let ((relative (relative-file source-directory file))) 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 new file mode 100644 index 0000000000..3c0ac2a12b --- /dev/null +++ b/guix/build/node-build-system.scm @@ -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)) diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index eb045cbd1c..3c84d3893f 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -48,13 +48,6 @@ MNT_EXPIRE UMOUNT_NOFOLLOW - AT_FDCWD - AT_SYMLINK_NOFOLLOW - AT_REMOVEDIR - AT_SYMLINK_FOLLOW - AT_NO_AUTOMOUNT - AT_EMPTY_PATH - restart-on-EINTR mount-points swapon @@ -686,12 +679,12 @@ mounted at FILE." ;; Flags for the *at command, notably the 'utime' procedure of libguile. ;; From <fcntl.h>. -(define AT_FDCWD -100) -(define AT_SYMLINK_NOFOLLOW #x100) -(define AT_REMOVEDIR #x200) -(define AT_SYMLINK_FOLLOW #x400) -(define AT_NO_AUTOMOUNT #x800) -(define AT_EMPTY_PATH #x1000) +(define-as-needed AT_FDCWD -100) +(define-as-needed AT_SYMLINK_NOFOLLOW #x100) +(define-as-needed AT_REMOVEDIR #x200) +(define-as-needed AT_SYMLINK_FOLLOW #x400) +(define-as-needed AT_NO_AUTOMOUNT #x800) +(define-as-needed AT_EMPTY_PATH #x1000) (define-syntax BLKRRPART ;<sys/mount.h> (identifier-syntax #x125F)) |