diff options
author | Marius Bakke <mbakke@fastmail.com> | 2019-05-01 23:11:41 +0200 |
---|---|---|
committer | Marius Bakke <mbakke@fastmail.com> | 2019-05-01 23:11:41 +0200 |
commit | 3b458d5462e6bbd852c2dc5c6670d5655abf53f5 (patch) | |
tree | 4f3ccec0de1c355134369333c17e948e3258d546 /guix/build | |
parent | 2ca3fdc2db1aef96fbf702a2f26f5e18ce832038 (diff) | |
parent | 14da3daafc8dd92fdabd3367694c930440fd72cb (diff) |
Merge branch 'master' into core-updates
Diffstat (limited to 'guix/build')
-rw-r--r-- | guix/build/cargo-build-system.scm | 155 | ||||
-rw-r--r-- | guix/build/clojure-utils.scm | 2 | ||||
-rw-r--r-- | guix/build/dune-build-system.scm | 17 | ||||
-rw-r--r-- | guix/build/go-build-system.scm | 4 | ||||
-rw-r--r-- | guix/build/guile-build-system.scm | 98 | ||||
-rw-r--r-- | guix/build/linux-module-build-system.scm | 91 | ||||
-rw-r--r-- | guix/build/po.scm | 69 | ||||
-rw-r--r-- | guix/build/ruby-build-system.scm | 2 | ||||
-rw-r--r-- | guix/build/syscalls.scm | 4 |
9 files changed, 345 insertions, 97 deletions
diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index 20087fa6c4..b68a1f90d2 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 David Craven <david@craven.ch> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> +;;; Copyright © 2019 Ivan Petkov <ivanppetkov@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,6 +27,7 @@ #: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 @@ -37,81 +39,86 @@ ;; ;; Code: -;; FIXME: Needs to be parsed from url not package name. -(define (package-name->crate-name name) - "Return the crate name of NAME." - (match (string-split name #\-) - (("rust" rest ...) - (string-join rest "-")) - (_ #f))) - -(define* (configure #:key inputs #:allow-other-keys) - "Replace Cargo.toml [dependencies] section with guix inputs." - ;; Make sure Cargo.toml is writeable when the crate uses git-fetch. - (chmod "Cargo.toml" #o644) +(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" '()))) + (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"))) + (bin-dep? (lambda (dep) (find bin? (get-kinds dep))))) + (find bin-dep? (manifest-targets)))) + +(define* (configure #:key inputs + (vendor-dir "guix-vendor") + #:allow-other-keys) + "Vendor Cargo.toml dependencies as guix inputs." (chmod "." #o755) - (if (not (file-exists? "vendor")) - (if (not (file-exists? "Cargo.lock")) - (begin - (substitute* "Cargo.toml" - ((".*32-sys.*") " -") - ((".*winapi.*") " -") - ((".*core-foundation.*") " -")) - ;; Prepare one new directory with all the required dependencies. - ;; It's necessary to do this (instead of just using /gnu/store as the - ;; directory) because we want to hide the libraries in subdirectories - ;; share/rust-source/... instead of polluting the user's profile root. - (mkdir "vendor") - (for-each - (match-lambda - ((name . path) - (let ((crate (package-name->crate-name name))) - (when (and crate path) - (match (string-split (basename path) #\-) - ((_ ... version) - (symlink (string-append path "/share/rust-source") - (string-append "vendor/" (basename path))))))))) - inputs) - ;; Configure cargo to actually use this new directory. - (mkdir-p ".cargo") - (let ((port (open-file ".cargo/config" "w" #:encoding "utf-8"))) - (display " + ;; Prepare one new directory with all the required dependencies. + ;; It's necessary to do this (instead of just using /gnu/store as the + ;; directory) because we want to hide the libraries in subdirectories + ;; share/rust-source/... instead of polluting the user's profile root. + (mkdir-p vendor-dir) + (for-each + (match-lambda + ((name . path) + (let* ((rust-share (string-append path "/share/rust-source")) + (basepath (basename path)) + (link-dir (string-append vendor-dir "/" basepath))) + (and (file-exists? rust-share) + ;; Gracefully handle duplicate inputs + (not (file-exists? link-dir)) + (symlink rust-share link-dir))))) + inputs) + ;; Configure cargo to actually use this new directory. + (mkdir-p ".cargo") + (let ((port (open-file ".cargo/config" "w" #:encoding "utf-8"))) + (display " [source.crates-io] -registry = 'https://github.com/rust-lang/crates.io-index' replace-with = 'vendored-sources' [source.vendored-sources] directory = '" port) - (display (getcwd) port) - (display "/vendor" port) - (display "' + (display (string-append (getcwd) "/" vendor-dir) port) + (display "' " port) - (close-port port))))) - (setenv "CC" (string-append (assoc-ref inputs "gcc") "/bin/gcc")) + (close-port port)) - ;(setenv "CARGO_HOME" "/gnu/store") - ; (setenv "CMAKE_C_COMPILER" cc) + ;; Lift restriction on any lints: a crate author may have decided to opt + ;; into stricter lints (e.g. #![deny(warnings)]) during their own builds + ;; but we don't want any build failures that could be caused later by + ;; upgrading the compiler for example. + (setenv "RUSTFLAGS" "--cap-lints allow") + (setenv "CC" (string-append (assoc-ref inputs "gcc") "/bin/gcc")) #t) -(define* (build #:key (cargo-build-flags '("--release")) +(define* (build #:key + skip-build? + (cargo-build-flags '("--release")) #:allow-other-keys) "Build a given Cargo package." - (zero? (apply system* `("cargo" "build" ,@cargo-build-flags)))) + (or skip-build? + (zero? (apply system* `("cargo" "build" ,@cargo-build-flags))))) -(define* (check #:key tests? #:allow-other-keys) +(define* (check #:key + tests? + (cargo-test-flags '("--release")) + #:allow-other-keys) "Run tests for a given Cargo package." - (if (and tests? (file-exists? "Cargo.lock")) - (zero? (system* "cargo" "test")) + (if tests? + (zero? (apply system* `("cargo" "test" ,@cargo-test-flags))) #t)) (define (touch file-name) (call-with-output-file file-name (const #t))) -(define* (install #:key inputs outputs #:allow-other-keys) - "Install a given Cargo package." +(define* (install-source #:key inputs outputs #:allow-other-keys) + "Install the source for a given Cargo package." (let* ((out (assoc-ref outputs "out")) (src (assoc-ref inputs "source")) (rsrc (string-append (assoc-ref outputs "src") @@ -120,24 +127,36 @@ directory = '" port) ;; Rust doesn't have a stable ABI yet. Because of this ;; Cargo doesn't have a search path for binaries yet. ;; Until this changes we are working around this by - ;; distributing crates as source and replacing - ;; references in Cargo.toml with store paths. - (copy-recursively "src" (string-append rsrc "/src")) + ;; vendoring the crates' sources by symlinking them + ;; to store paths. + (copy-recursively "." rsrc) (touch (string-append rsrc "/.cargo-ok")) - (generate-checksums rsrc src) + (generate-checksums rsrc "/dev/null") (install-file "Cargo.toml" rsrc) - ;; When the package includes executables we install - ;; it using cargo install. This fails when the crate - ;; doesn't contain an executable. - (if (file-exists? "Cargo.lock") - (zero? (system* "cargo" "install" "--root" out)) - (begin - (mkdir out) - #t)))) + #t)) + +(define* (install #:key inputs outputs skip-build? #:allow-other-keys) + "Install a given Cargo package." + (let* ((out (assoc-ref outputs "out"))) + (mkdir-p out) + + ;; 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. + (or skip-build? + (not (has-executable-target?)) + (zero? (system* "cargo" "install" "--path" "." "--root" out))))) (define %standard-phases (modify-phases gnu:%standard-phases (delete 'bootstrap) + (add-before 'configure 'install-source install-source) (replace 'configure configure) (replace 'build build) (replace 'check check) diff --git a/guix/build/clojure-utils.scm b/guix/build/clojure-utils.scm index 027777b4d1..9f7334bc8d 100644 --- a/guix/build/clojure-utils.scm +++ b/guix/build/clojure-utils.scm @@ -215,7 +215,7 @@ results from compiling LIB." (define* (include-list\exclude-list include-list exclude-list #:key all-list) - "Given INCLUDE-LIST and EXCLUDE-LIST, replace all occurences of #:all by + "Given INCLUDE-LIST and EXCLUDE-LIST, replace all occurrences of #:all by slicing ALL-LIST into them and compute their list difference." (define (replace-#:all ls all-ls) (append-map (match-lambda diff --git a/guix/build/dune-build-system.scm b/guix/build/dune-build-system.scm index 00b0c7c406..7e2ec1e3e1 100644 --- a/guix/build/dune-build-system.scm +++ b/guix/build/dune-build-system.scm @@ -31,27 +31,30 @@ ;; Code: (define* (build #:key (build-flags '()) (jbuild? #f) - (use-make? #f) #:allow-other-keys) + (use-make? #f) (package #f) #:allow-other-keys) "Build the given package." (let ((program (if jbuild? "jbuilder" "dune"))) - (apply invoke program "build" "@install" build-flags)) + (apply invoke program "build" "@install" + (append (if package (list "-p" package) '()) build-flags))) #t) (define* (check #:key (test-flags '()) (test-target "test") tests? - (jbuild? #f) #:allow-other-keys) + (jbuild? #f) (package #f) #:allow-other-keys) "Test the given package." (when tests? (let ((program (if jbuild? "jbuilder" "dune"))) - (apply invoke program "runtest" test-target test-flags))) + (apply invoke program "runtest" test-target + (append (if package (list "-p" package) '()) test-flags)))) #t) (define* (install #:key outputs (install-target "install") (jbuild? #f) - #:allow-other-keys) + (package #f) #:allow-other-keys) "Install the given package." (let ((out (assoc-ref outputs "out")) (program (if jbuild? "jbuilder" "dune"))) - (invoke program install-target "--prefix" out "--libdir" - (string-append out "/lib/ocaml/site-lib"))) + (apply invoke program install-target "--prefix" out "--libdir" + (string-append out "/lib/ocaml/site-lib") + (if package (list package) '()))) #t) (define %standard-phases diff --git a/guix/build/go-build-system.scm b/guix/build/go-build-system.scm index 1a716cea77..282df19f24 100644 --- a/guix/build/go-build-system.scm +++ b/guix/build/go-build-system.scm @@ -42,7 +42,7 @@ ;; structure called a 'workspace' [1]. This workspace can be found by Go via ;; the GOPATH environment variable. Typically, all Go source code and compiled ;; objects are kept in a single workspace, but GOPATH may be a list of -;; directories [2]. In this go-build-system we create a filesystem union of +;; directories [2]. In this go-build-system we create a file system union of ;; the Go-language dependencies. Previously, we made GOPATH a list of store ;; directories, but stopped because Go programs started keeping references to ;; these directories in Go 1.11: @@ -127,7 +127,7 @@ ;; Code: (define* (setup-go-environment #:key inputs outputs #:allow-other-keys) - "Prepare a Go build environment for INPUTS and OUTPUTS. Build a filesystem + "Prepare a Go build environment for INPUTS and OUTPUTS. Build a file system union of INPUTS. Export GOPATH, which helps the compiler find the source code of the package being built and its dependencies, and GOBIN, which determines where executables (\"commands\") are installed to. This phase is sometimes used diff --git a/guix/build/guile-build-system.scm b/guix/build/guile-build-system.scm index 0bed049436..31f0d3d6f4 100644 --- a/guix/build/guile-build-system.scm +++ b/guix/build/guile-build-system.scm @@ -65,6 +65,62 @@ Return #false if it cannot be determined." (setenv "GUIX_LOCPATH" (string-append locales "/lib/locale")) #t))) +(define* (invoke-each commands + #:key (max-processes (current-processor-count)) + report-progress) + "Run each command in COMMANDS in a separate process, using up to +MAX-PROCESSES processes in parallel. Call REPORT-PROGRESS at each step. +Raise an error if one of the processes exit with non-zero." + (define total + (length commands)) + + (define (wait-for-one-process) + (match (waitpid WAIT_ANY) + ((_ . status) + (unless (zero? (status:exit-val status)) + (error "process failed" status))))) + + (define (fork-and-run-command command) + (match (primitive-fork) + (0 + (dynamic-wind + (const #t) + (lambda () + (apply execlp command)) + (lambda () + (primitive-exit 127)))) + (pid + #t))) + + (let loop ((commands commands) + (running 0) + (completed 0)) + (match commands + (() + (or (zero? running) + (let ((running (- running 1)) + (completed (+ completed 1))) + (wait-for-one-process) + (report-progress total completed) + (loop commands running completed)))) + ((command . rest) + (if (< running max-processes) + (let ((running (+ 1 running))) + (fork-and-run-command command) + (loop rest running completed)) + (let ((running (- running 1)) + (completed (+ completed 1))) + (wait-for-one-process) + (report-progress total completed) + (loop commands running completed))))))) + +(define* (report-build-progress total completed + #:optional (log-port (current-error-port))) + "Report that COMPLETED out of TOTAL files have been completed." + (format log-port "compiling...\t~5,1f% of ~d files~%" ;FIXME: i18n + (* 100. (/ completed total)) total) + (force-output log-port)) + (define* (build #:key outputs inputs native-inputs (source-directory ".") (compile-flags '()) @@ -101,24 +157,30 @@ Return #false if it cannot be determined." (match (getenv "GUILE_LOAD_COMPILED_PATH") (#f "") (path (string-append ":" path))))) - (for-each (lambda (file) - (let* ((go (string-append go-dir - (file-sans-extension file) - ".go"))) - ;; Install source module. - (install-file (string-append source-directory "/" file) - (string-append module-dir - "/" (dirname file))) - - ;; Install and compile module. - (apply invoke guild "compile" "-L" source-directory - "-o" go - (string-append source-directory "/" file) - flags))) - - ;; Arrange to strip SOURCE-DIRECTORY from file names. - (with-directory-excursion source-directory - (find-files "." scheme-file-regexp))) + + (let ((source-files + (with-directory-excursion source-directory + (find-files "." scheme-file-regexp)))) + (invoke-each + (map (lambda (file) + (cons* guild + "guild" "compile" + "-L" source-directory + "-o" (string-append go-dir + (file-sans-extension file) + ".go") + (string-append source-directory "/" file) + flags)) + source-files) + #:max-processes (parallel-job-count) + #:report-progress report-build-progress) + + (for-each + (lambda (file) + (install-file (string-append source-directory "/" file) + (string-append module-dir + "/" (dirname file)))) + source-files)) #t)) (define* (install-documentation #:key outputs diff --git a/guix/build/linux-module-build-system.scm b/guix/build/linux-module-build-system.scm new file mode 100644 index 0000000000..cd76df2de7 --- /dev/null +++ b/guix/build/linux-module-build-system.scm @@ -0,0 +1,91 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.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 linux-module-build-system) + #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #:use-module (guix build utils) + #:use-module (ice-9 ftw) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (%standard-phases + linux-module-build)) + +;; Commentary: +;; +;; Builder-side code of linux-module build. +;; +;; Code: + +;; Copied from make-linux-libre's "configure" phase. +(define* (configure #:key inputs target #:allow-other-keys) + (setenv "KCONFIG_NOTIMESTAMP" "1") + (setenv "KBUILD_BUILD_TIMESTAMP" (getenv "SOURCE_DATE_EPOCH")) + ;(let ((arch ,(system->linux-architecture + ; (or (%current-target-system) + ; (%current-system))))) + ; (setenv "ARCH" arch) + ; (format #t "`ARCH' set to `~a'~%" (getenv "ARCH"))) + (when target + (setenv "CROSS_COMPILE" (string-append target "-")) + (format #t "`CROSS_COMPILE' set to `~a'~%" + (getenv "CROSS_COMPILE"))) + ; TODO: (setenv "EXTRA_VERSION" ,extra-version) + ; TODO: kernel ".config". + #t) + +(define* (build #:key inputs make-flags #:allow-other-keys) + (apply invoke "make" "-C" + (string-append (assoc-ref inputs "linux-module-builder") + "/lib/modules/build") + (string-append "M=" (getcwd)) + (or make-flags '()))) + +;; This block was copied from make-linux-libre--only took the "modules_install" +;; part. +(define* (install #:key inputs native-inputs outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (moddir (string-append out "/lib/modules")) + (kmod (assoc-ref (or native-inputs inputs) "kmod"))) + ;; Install kernel modules + (mkdir-p moddir) + (invoke "make" "-C" + (string-append (assoc-ref inputs "linux-module-builder") + "/lib/modules/build") + (string-append "M=" (getcwd)) + (string-append "DEPMOD=" kmod "/bin/depmod") + (string-append "MODULE_DIR=" moddir) + (string-append "INSTALL_PATH=" out) + (string-append "INSTALL_MOD_PATH=" out) + "INSTALL_MOD_STRIP=1" + "modules_install"))) + +(define %standard-phases + (modify-phases gnu:%standard-phases + (replace 'configure configure) + (replace 'build build) + (replace 'install install))) + +(define* (linux-module-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + "Build the given package, applying all of PHASES in order, with a Linux kernel in attendance." + (apply gnu:gnu-build + #:inputs inputs #:phases phases + args)) + +;;; linux-module-build-system.scm ends here diff --git a/guix/build/po.scm b/guix/build/po.scm new file mode 100644 index 0000000000..47ff67541c --- /dev/null +++ b/guix/build/po.scm @@ -0,0 +1,69 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu> +;;; +;;; 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 po) + #:use-module (ice-9 match) + #:use-module (ice-9 peg) + #:use-module (ice-9 regex) + #:use-module (ice-9 textual-ports) + #:export (read-po-file)) + +;; A small parser for po files +(define-peg-pattern po-file body (* (or comment entry whitespace))) +(define-peg-pattern whitespace body (or " " "\t" "\n")) +(define-peg-pattern comment-chr body (range #\space #\頋)) +(define-peg-pattern comment none (and "#" (* comment-chr) "\n")) +(define-peg-pattern entry all + (and (ignore (* whitespace)) (ignore "msgid ") msgid + (ignore (* whitespace)) (ignore "msgstr ") msgstr)) +(define-peg-pattern escape body (or "\\\\" "\\\"" "\\n")) +(define-peg-pattern str-chr body (or " " "!" (and (ignore "\\") "\"") + "\\n" (and (ignore "\\") "\\") + (range #\# #\頋))) +(define-peg-pattern msgid all content) +(define-peg-pattern msgstr all content) +(define-peg-pattern content body + (and (ignore "\"") (* str-chr) (ignore "\"") + (? (and (ignore (* whitespace)) content)))) + +(define (parse-tree->assoc parse-tree) + "Converts a po PARSE-TREE to an association list." + (define regex (make-regexp "\\\\n")) + (match parse-tree + ('() '()) + ((entry parse-tree ...) + (match entry + ((? string? entry) + (parse-tree->assoc parse-tree)) + ;; empty msgid + (('entry ('msgid ('msgstr msgstr))) + (parse-tree->assoc parse-tree)) + ;; empty msgstr + (('entry ('msgid msgid) 'msgstr) + (parse-tree->assoc parse-tree)) + (('entry ('msgid msgid) ('msgstr msgstr)) + (acons (regexp-substitute/global #f regex msgid 'pre "\n" 'post) + (regexp-substitute/global #f regex msgstr 'pre "\n" 'post) + (parse-tree->assoc parse-tree))))))) + +(define (read-po-file port) + "Read a .po file from PORT and return an alist of msgid and msgstr." + (let ((tree (peg:tree (match-pattern + po-file + (get-string-all port))))) + (parse-tree->assoc tree))) diff --git a/guix/build/ruby-build-system.scm b/guix/build/ruby-build-system.scm index ba0de1259e..63c94765f7 100644 --- a/guix/build/ruby-build-system.scm +++ b/guix/build/ruby-build-system.scm @@ -144,6 +144,8 @@ GEM-FLAGS are passed to the 'gem' invokation, if present." (setenv "GEM_VENDOR" vendor-dir) (or (zero? + ;; 'zero? system*' allows the custom error handling to function as + ;; expected, while 'invoke' raises its own exception. (apply system* "gem" "install" gem-file "--verbose" "--local" "--ignore-dependencies" "--vendor" diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 66d63a2931..749616ceb1 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -39,6 +39,7 @@ MS_NODEV MS_NOEXEC MS_REMOUNT + MS_NOATIME MS_BIND MS_MOVE MS_STRICTATIME @@ -451,6 +452,7 @@ the returned procedure is called." (define MS_NODEV 4) (define MS_NOEXEC 8) (define MS_REMOUNT 32) +(define MS_NOATIME 1024) (define MS_BIND 4096) (define MS_MOVE 8192) (define MS_STRICTATIME 16777216) @@ -690,7 +692,7 @@ mounted at FILE." (define* (device-in-use? device) "Return #t if the block DEVICE is in use, #f otherwise. This is inspired -from fdisk_device_is_used function of util-linux. This is particulary useful +from fdisk_device_is_used function of util-linux. This is particularly useful for devices that do not appear in /proc/self/mounts like overlayfs lowerdir backend device." (let*-values (((fd) (open-fdes device O_RDONLY)) |