diff options
author | Marius Bakke <mbakke@fastmail.com> | 2018-07-24 19:56:35 +0200 |
---|---|---|
committer | Marius Bakke <mbakke@fastmail.com> | 2018-07-24 19:56:35 +0200 |
commit | 706ae8e15c8d36b0aee7c19c54c143d3e17f5784 (patch) | |
tree | e9fe8ebfb1417d30979b5413165599f066a1c504 /guix/build | |
parent | 3e95125e9bd0676d4a9add9105217ad3eaef3ff0 (diff) | |
parent | 8440db459a10daa24282038f35bc0b6771bd51ab (diff) |
Merge branch 'master' into core-updates
Diffstat (limited to 'guix/build')
-rw-r--r-- | guix/build/ant-build-system.scm | 98 | ||||
-rw-r--r-- | guix/build/go-build-system.scm | 38 | ||||
-rw-r--r-- | guix/build/guile-build-system.scm | 153 | ||||
-rw-r--r-- | guix/build/haskell-build-system.scm | 5 | ||||
-rw-r--r-- | guix/build/java-utils.scm | 2 | ||||
-rw-r--r-- | guix/build/meson-build-system.scm | 14 | ||||
-rw-r--r-- | guix/build/profiles.scm | 2 | ||||
-rw-r--r-- | guix/build/ruby-build-system.scm | 108 | ||||
-rw-r--r-- | guix/build/syscalls.scm | 17 |
9 files changed, 303 insertions, 134 deletions
diff --git a/guix/build/ant-build-system.scm b/guix/build/ant-build-system.scm index d081a2b313..d79b4d503b 100644 --- a/guix/build/ant-build-system.scm +++ b/guix/build/ant-build-system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2016, 2018 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -68,14 +68,11 @@ (target (@ (name "manifest")) (mkdir (@ (dir "${manifest.dir}"))) - (echo (@ (file "${manifest.file}") - (message ,(string-append - (if main-class - (string-append - "Main-Class: " main-class - "${line.separator}") - "") - ""))))) + (manifest (@ (file "${manifest.file}")) + ,(if main-class + `(attribute (@ (name "Main-Class") + (value ,main-class))) + ""))) (target (@ (name "compile")) (mkdir (@ (dir "${classes.dir}"))) @@ -150,7 +147,8 @@ to the default GNU unpack strategy." (begin (mkdir "src") (with-directory-excursion "src" - (zero? (system* "jar" "-xf" source)))) + (invoke "jar" "-xf" source)) + #t) ;; Use GNU unpack strategy for things that aren't jar archives. ((assq-ref gnu:%standard-phases 'unpack) #:source source))) @@ -171,7 +169,7 @@ to the default GNU unpack strategy." (define* (build #:key (make-flags '()) (build-target "jar") #:allow-other-keys) - (zero? (apply system* `("ant" ,build-target ,@make-flags)))) + (apply invoke `("ant" ,build-target ,@make-flags))) (define* (generate-jar-indices #:key outputs #:allow-other-keys) "Generate file \"META-INF/INDEX.LIST\". This file does not use word wraps @@ -181,10 +179,11 @@ grafting works - and so that the garbage collector doesn't collect dependencies of this jar file." (define (generate-index jar) (invoke "jar" "-i" jar)) - (every (match-lambda - ((output . directory) - (every generate-index (find-files directory "\\.jar$")))) - outputs)) + (for-each (match-lambda + ((output . directory) + (for-each generate-index (find-files directory "\\.jar$")))) + outputs) + #t) (define* (strip-jar-timestamps #:key outputs #:allow-other-keys) @@ -194,50 +193,49 @@ repack them. This is necessary to ensure that archives are reproducible." (format #t "repacking ~a\n" jar) (let* ((dir (mkdtemp! "jar-contents.XXXXXX")) (manifest (string-append dir "/META-INF/MANIFEST.MF"))) - (and (with-directory-excursion dir - (zero? (system* "jar" "xf" jar))) - (delete-file jar) - ;; XXX: copied from (gnu build install) - (for-each (lambda (file) - (let ((s (lstat file))) - (unless (eq? (stat:type s) 'symlink) - (utime file 0 0 0 0)))) - (find-files dir #:directories? #t)) + (with-directory-excursion dir + (invoke "jar" "xf" jar)) + (delete-file jar) + ;; XXX: copied from (gnu build install) + (for-each (lambda (file) + (let ((s (lstat file))) + (unless (eq? (stat:type s) 'symlink) + (utime file 0 0 0 0)))) + (find-files dir #:directories? #t)) - ;; The jar tool will always set the timestamp on the manifest file - ;; and the containing directory to the current time, even when we - ;; reuse an existing manifest file. To avoid this we use "zip" - ;; instead of "jar". It is important that the manifest appears - ;; first. - (with-directory-excursion dir - (let* ((files (find-files "." ".*" #:directories? #t)) - ;; To ensure that the reference scanner can detect all - ;; store references in the jars we disable compression - ;; with the "-0" option. - (command (if (file-exists? manifest) - `("zip" "-0" "-X" ,jar ,manifest ,@files) - `("zip" "-0" "-X" ,jar ,@files)))) - (unless (zero? (apply system* command)) - (error "'zip' failed")))) - (utime jar 0 0) - #t))) + ;; The jar tool will always set the timestamp on the manifest file + ;; and the containing directory to the current time, even when we + ;; reuse an existing manifest file. To avoid this we use "zip" + ;; instead of "jar". It is important that the manifest appears + ;; first. + (with-directory-excursion dir + (let* ((files (find-files "." ".*" #:directories? #t)) + ;; To ensure that the reference scanner can detect all + ;; store references in the jars we disable compression + ;; with the "-0" option. + (command (if (file-exists? manifest) + `("zip" "-0" "-X" ,jar ,manifest ,@files) + `("zip" "-0" "-X" ,jar ,@files)))) + (apply invoke command))) + (utime jar 0 0) + #t)) - (every (match-lambda - ((output . directory) - (every repack-archive (find-files directory "\\.jar$")))) - outputs)) + (for-each (match-lambda + ((output . directory) + (for-each repack-archive (find-files directory "\\.jar$")))) + outputs) + #t) (define* (check #:key target (make-flags '()) (tests? (not target)) (test-target "check") #:allow-other-keys) (if tests? - (zero? (apply system* `("ant" ,test-target ,@make-flags))) - (begin - (format #t "test suite not run~%") - #t))) + (apply invoke `("ant" ,test-target ,@make-flags)) + (format #t "test suite not run~%")) + #t) (define* (install #:key (make-flags '()) #:allow-other-keys) - (zero? (apply system* `("ant" "install" ,@make-flags)))) + (apply invoke `("ant" "install" ,@make-flags))) (define %standard-phases (modify-phases gnu:%standard-phases diff --git a/guix/build/go-build-system.scm b/guix/build/go-build-system.scm index 7c833a616f..6be0167063 100644 --- a/guix/build/go-build-system.scm +++ b/guix/build/go-build-system.scm @@ -125,17 +125,17 @@ unset. When SOURCE is a directory, copy it instead of unpacking." (copy-recursively source dest #:keep-mtime? #t) #t) (if (string-suffix? ".zip" source) - (zero? (system* "unzip" "-d" dest source)) - (zero? (system* "tar" "-C" dest "-xvf" source)))))) + (invoke "unzip" "-d" dest source) + (invoke "tar" "-C" dest "-xvf" source))))) (define* (install-source #:key install-source? outputs #:allow-other-keys) "Install the source code to the output directory." (let* ((out (assoc-ref outputs "out")) (source "src") (dest (string-append out "/" source))) - (if install-source? - (copy-recursively source dest #:keep-mtime? #t) - #t))) + (when install-source? + (copy-recursively source dest #:keep-mtime? #t)) + #t)) (define (go-package? name) (string-prefix? "go-" name)) @@ -178,24 +178,26 @@ respectively." (define* (build #:key import-path #:allow-other-keys) "Build the package named by IMPORT-PATH." - (or - (zero? (system* "go" "install" - "-v" ; print the name of packages as they are compiled - "-x" ; print each command as it is invoked - ;; Respectively, strip the symbol table and debug - ;; information, and the DWARF symbol table. - "-ldflags=-s -w" - import-path)) - (begin + (with-throw-handler + #t + (lambda _ + (invoke "go" "install" + "-v" ; print the name of packages as they are compiled + "-x" ; print each command as it is invoked + ;; Respectively, strip the symbol table and debug + ;; information, and the DWARF symbol table. + "-ldflags=-s -w" + import-path)) + (lambda (key . args) (display (string-append "Building '" import-path "' failed.\n" "Here are the results of `go env`:\n")) - (system* "go" "env") - #f))) + (invoke "go" "env")))) (define* (check #:key tests? import-path #:allow-other-keys) "Run the tests for the package named by IMPORT-PATH." - (if tests? - (zero? (system* "go" "test" import-path)))) + (when tests? + (invoke "go" "test" import-path)) + #t) (define* (install #:key outputs #:allow-other-keys) "Install the compiled libraries. `go install` installs these files to diff --git a/guix/build/guile-build-system.scm b/guix/build/guile-build-system.scm new file mode 100644 index 0000000000..0bed049436 --- /dev/null +++ b/guix/build/guile-build-system.scm @@ -0,0 +1,153 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.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 guile-build-system) + #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #:use-module (guix build utils) + #:use-module (srfi srfi-26) + #:use-module (ice-9 match) + #:use-module (ice-9 popen) + #:use-module (ice-9 rdelim) + #:use-module (guix build utils) + #:export (target-guile-effective-version + %standard-phases + guile-build)) + +(define* (target-guile-effective-version #:optional guile) + "Return the effective version of GUILE or whichever 'guile' is in $PATH. +Return #false if it cannot be determined." + (let* ((pipe (open-pipe* OPEN_READ + (if guile + (string-append guile "/bin/guile") + "guile") + "-c" "(display (effective-version))")) + (line (read-line pipe))) + (and (zero? (close-pipe pipe)) + (string? line) + line))) + +(define (file-sans-extension file) ;TODO: factorize + "Return the substring of FILE without its extension, if any." + (let ((dot (string-rindex file #\.))) + (if dot + (substring file 0 dot) + file))) + +(define %scheme-file-regexp + ;; Regexp to match Scheme files. + "\\.(scm|sls)$") + +(define %documentation-file-regexp + ;; Regexp to match README files and the likes. + "^(README.*|.*\\.html|.*\\.org|.*\\.md)$") + +(define* (set-locale-path #:key inputs native-inputs + #:allow-other-keys) + "Set 'GUIX_LOCPATH'." + (match (assoc-ref (or native-inputs inputs) "locales") + (#f #t) + (locales + (setenv "GUIX_LOCPATH" (string-append locales "/lib/locale")) + #t))) + +(define* (build #:key outputs inputs native-inputs + (source-directory ".") + (compile-flags '()) + (scheme-file-regexp %scheme-file-regexp) + target + #:allow-other-keys) + "Build files in SOURCE-DIRECTORY that match SCHEME-FILE-REGEXP." + (let* ((out (assoc-ref outputs "out")) + (guile (assoc-ref (or native-inputs inputs) "guile")) + (effective (target-guile-effective-version guile)) + (module-dir (string-append out "/share/guile/site/" + effective)) + (go-dir (string-append out "/lib/guile/" + effective "/site-ccache/")) + (guild (string-append guile "/bin/guild")) + (flags (if target + (cons (string-append "--target=" target) + compile-flags) + compile-flags))) + (if target + (format #t "Cross-compiling for '~a' with Guile ~a...~%" + target effective) + (format #t "Compiling with Guile ~a...~%" effective)) + (format #t "compile flags: ~s~%" flags) + + ;; Make installation directories. + (mkdir-p module-dir) + (mkdir-p go-dir) + + ;; Compile .scm files and install. + (setenv "GUILE_AUTO_COMPILE" "0") + (setenv "GUILE_LOAD_COMPILED_PATH" + (string-append go-dir + (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))) + #t)) + +(define* (install-documentation #:key outputs + (documentation-file-regexp + %documentation-file-regexp) + #:allow-other-keys) + "Install files that mactch DOCUMENTATION-FILE-REGEXP." + (let* ((out (assoc-ref outputs "out")) + (doc (string-append out "/share/doc/" + (strip-store-file-name out)))) + (for-each (cut install-file <> doc) + (find-files "." documentation-file-regexp)) + #t)) + +(define %standard-phases + (modify-phases gnu:%standard-phases + (delete 'bootstrap) + (delete 'configure) + (add-before 'install-locale 'set-locale-path + set-locale-path) + (replace 'build build) + (add-after 'build 'install-documentation + install-documentation) + (delete 'check) + (delete 'strip) + (delete 'validate-runpath) + (delete 'install))) + +(define* (guile-build #:key (phases %standard-phases) + #:allow-other-keys #:rest args) + "Build the given Guile package, applying all of PHASES in order." + (apply gnu:gnu-build #:phases phases args)) diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm index 268d59c1be..26519ce5a6 100644 --- a/guix/build/haskell-build-system.scm +++ b/guix/build/haskell-build-system.scm @@ -66,7 +66,7 @@ (format #t "running \"runhaskell Setup.hs\" with command ~s \ and parameters ~s~%" command params) - (zero? (apply system* "runhaskell" setup-file command params))) + (apply invoke "runhaskell" setup-file command params)) (error "no Setup.hs nor Setup.lhs found")))) (define* (configure #:key outputs inputs tests? (configure-flags '()) @@ -114,7 +114,8 @@ and parameters ~s~%" (setenv "CONFIG_SHELL" "sh")) (run-setuphs "configure" params) - (setenv "GHC_PACKAGE_PATH" ghc-path))) + (setenv "GHC_PACKAGE_PATH" ghc-path) + #t)) (define* (build #:rest empty) "Build a given Haskell package." diff --git a/guix/build/java-utils.scm b/guix/build/java-utils.scm index 402d377bf8..128be1edeb 100644 --- a/guix/build/java-utils.scm +++ b/guix/build/java-utils.scm @@ -31,7 +31,7 @@ (define* (ant-build-javadoc #:key (target "javadoc") (make-flags '()) #:allow-other-keys) - (zero? (apply system* `("ant" ,target ,@make-flags)))) + (apply invoke `("ant" ,target ,@make-flags))) (define* (install-jars jar-directory) "Install jar files from JAR-DIRECTORY to the default target directory. This diff --git a/guix/build/meson-build-system.scm b/guix/build/meson-build-system.scm index 6dac007a6d..9724764424 100644 --- a/guix/build/meson-build-system.scm +++ b/guix/build/meson-build-system.scm @@ -59,17 +59,14 @@ (mkdir build-dir) (chdir build-dir) - (apply invoke "meson" args) - #t)) + (apply invoke "meson" args))) (define* (build #:key parallel-build? #:allow-other-keys) "Build a given meson package." - (apply invoke "ninja" - (if parallel-build? - `("-j" ,(number->string (parallel-job-count))) - '("-j" "1"))) - #t) + (invoke "ninja" "-j" (if parallel-build? + (number->string (parallel-job-count)) + "1"))) (define* (check #:key test-target parallel-tests? tests? #:allow-other-keys) @@ -83,8 +80,7 @@ #t) (define* (install #:rest args) - (invoke "ninja" "install") - #t) + (invoke "ninja" "install")) (define* (fix-runpath #:key (elf-directories '("lib" "lib64" "libexec" "bin" "sbin")) diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm index 819688a913..df785c85a7 100644 --- a/guix/build/profiles.scm +++ b/guix/build/profiles.scm @@ -89,7 +89,7 @@ definitions for all the SEARCH-PATHS." # When GUIX_PROFILE is undefined, the various environment variables refer # to this specific profile generation. \n" port) - (let ((variables (evaluate-search-paths (cons $PATH search-paths) + (let ((variables (evaluate-search-paths search-paths (list output)))) (for-each (write-environment-variable-definition port) (map (abstract-profile output) variables)))))) diff --git a/guix/build/ruby-build-system.scm b/guix/build/ruby-build-system.scm index abef6937bc..a346e9fb8e 100644 --- a/guix/build/ruby-build-system.scm +++ b/guix/build/ruby-build-system.scm @@ -52,18 +52,19 @@ directory." (define* (unpack #:key source #:allow-other-keys) "Unpack the gem SOURCE and enter the resulting directory." (if (gem-archive? source) - (and (zero? (system* "gem" "unpack" source)) - ;; The unpacked gem directory is named the same as the archive, - ;; sans the ".gem" extension. It is renamed to simply "gem" in an - ;; effort to keep file names shorter to avoid UNIX-domain socket - ;; file names and shebangs that exceed the system's fixed maximum - ;; length when running test suites. - (let ((dir (match:substring (string-match "^(.*)\\.gem$" - (basename source)) - 1))) - (rename-file dir "gem") - (chdir "gem") - #t)) + (begin + (invoke "gem" "unpack" source) + ;; The unpacked gem directory is named the same as the archive, + ;; sans the ".gem" extension. It is renamed to simply "gem" in an + ;; effort to keep file names shorter to avoid UNIX-domain socket + ;; file names and shebangs that exceed the system's fixed maximum + ;; length when running test suites. + (let ((dir (match:substring (string-match "^(.*)\\.gem$" + (basename source)) + 1))) + (rename-file dir "gem") + (chdir "gem")) + #t) ;; Use GNU unpack strategy for things that aren't gem archives. (gnu:unpack #:source source))) @@ -104,7 +105,8 @@ generate the files list." (write-char (read-char pipe) out)))) #t) (lambda () - (close-pipe pipe))))))) + (close-pipe pipe))))) + #t)) (define* (build #:key source #:allow-other-keys) "Build a new gem using the gemspec from the SOURCE gem." @@ -112,13 +114,13 @@ generate the files list." ;; Build a new gem from the current working directory. This also allows any ;; dynamic patching done in previous phases to be present in the installed ;; gem. - (zero? (system* "gem" "build" (first-gemspec)))) + (invoke "gem" "build" (first-gemspec))) (define* (check #:key tests? test-target #:allow-other-keys) "Run the gem's test suite rake task TEST-TARGET. Skip the tests if TESTS? is #f." (if tests? - (zero? (system* "rake" test-target)) + (invoke "rake" test-target) #t)) (define* (install #:key inputs outputs (gem-flags '()) @@ -137,43 +139,42 @@ GEM-FLAGS are passed to the 'gem' invokation, if present." 0 (- (string-length gem-file-basename) 4)))) (setenv "GEM_VENDOR" vendor-dir) - (and (let ((install-succeeded? - (zero? - (apply system* "gem" "install" gem-file - "--local" "--ignore-dependencies" "--vendor" - ;; Executables should go into /bin, not - ;; /lib/ruby/gems. - "--bindir" (string-append out "/bin") - gem-flags)))) - (or install-succeeded? - (begin - (simple-format #t "installation failed\n") - (let ((failed-output-dir (string-append (getcwd) "/out"))) - (mkdir failed-output-dir) - (copy-recursively out failed-output-dir)) - #f))) - (begin - ;; Remove the cached gem file as this is unnecessary and contains - ;; timestamped files rendering builds not reproducible. - (let ((cached-gem (string-append vendor-dir "/cache/" gem-file))) - (log-file-deletion cached-gem) - (delete-file cached-gem)) - ;; For gems with native extensions, several Makefile-related files - ;; are created that contain timestamps or other elements making - ;; them not reproducible. They are unnecessary so we remove them. - (if (file-exists? (string-append vendor-dir "/ext")) - (begin - (for-each (lambda (file) - (log-file-deletion file) - (delete-file file)) - (append - (find-files (string-append vendor-dir "/doc") - "page-Makefile.ri") - (find-files (string-append vendor-dir "/extensions") - "gem_make.out") - (find-files (string-append vendor-dir "/ext") - "Makefile"))))) - #t)))) + + (or (zero? + (apply system* "gem" "install" gem-file + "--local" "--ignore-dependencies" "--vendor" + ;; Executables should go into /bin, not + ;; /lib/ruby/gems. + "--bindir" (string-append out "/bin") + gem-flags)) + (begin + (let ((failed-output-dir (string-append (getcwd) "/out"))) + (mkdir failed-output-dir) + (copy-recursively out failed-output-dir)) + (error "installation failed"))) + + ;; Remove the cached gem file as this is unnecessary and contains + ;; timestamped files rendering builds not reproducible. + (let ((cached-gem (string-append vendor-dir "/cache/" gem-file))) + (log-file-deletion cached-gem) + (delete-file cached-gem)) + + ;; For gems with native extensions, several Makefile-related files + ;; are created that contain timestamps or other elements making + ;; them not reproducible. They are unnecessary so we remove them. + (when (file-exists? (string-append vendor-dir "/ext")) + (for-each (lambda (file) + (log-file-deletion file) + (delete-file file)) + (append + (find-files (string-append vendor-dir "/doc") + "page-Makefile.ri") + (find-files (string-append vendor-dir "/extensions") + "gem_make.out") + (find-files (string-append vendor-dir "/ext") + "Makefile")))) + + #t)) (define* (wrap-ruby-program prog #:key (gem-clear-paths #t) #:rest vars) "Make a wrapper for PROG. VARS should look like this: @@ -301,7 +302,8 @@ extended with definitions for VARS." (let ((files (list-of-files dir))) (for-each (cut wrap-ruby-program <> var) files))) - bindirs))) + bindirs)) + #t) (define (log-file-deletion file) (display (string-append "deleting '" file "' for reproducibility\n"))) diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 25726b885e..74cb675fcf 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -46,6 +46,14 @@ MNT_DETACH 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 @@ -667,6 +675,15 @@ mounted at FILE." (* (file-system-block-size fs) (file-system-blocks-available fs)))) +;; 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) + ;;; ;;; Containers. |