diff options
Diffstat (limited to 'guix/build')
| -rw-r--r-- | guix/build/clojure-build-system.scm | 110 | ||||
| -rw-r--r-- | guix/build/clojure-utils.scm | 265 | ||||
| -rw-r--r-- | guix/build/dub-build-system.scm | 33 | ||||
| -rw-r--r-- | guix/build/git.scm | 2 | ||||
| -rw-r--r-- | guix/build/go-build-system.scm | 3 | ||||
| -rw-r--r-- | guix/build/haskell-build-system.scm | 2 | ||||
| -rw-r--r-- | guix/build/hg.scm | 7 | ||||
| -rw-r--r-- | guix/build/ocaml-build-system.scm | 45 | ||||
| -rw-r--r-- | guix/build/store-copy.scm | 28 |
9 files changed, 455 insertions, 40 deletions
diff --git a/guix/build/clojure-build-system.scm b/guix/build/clojure-build-system.scm new file mode 100644 index 0000000000..d8f7c89f85 --- /dev/null +++ b/guix/build/clojure-build-system.scm @@ -0,0 +1,110 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Alex Vong <alexvong1995@gmail.com> +;;; +;;; 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 clojure-build-system) + #:use-module ((guix build ant-build-system) + #:select ((%standard-phases . %standard-phases@ant) + ant-build)) + #:use-module (guix build clojure-utils) + #:use-module (guix build java-utils) + #:use-module (guix build utils) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (%standard-phases + clojure-build)) + +;; Commentary: +;; +;; Builder-side code of the standard build procedure for Clojure packages. +;; +;; Code: + +(define* (build #:key + source-dirs compile-dir + jar-names main-class omit-source? + aot-include aot-exclude + #:allow-other-keys) + "Standard 'build' phase for clojure-build-system." + (let* ((libs (append-map find-clojure-libs source-dirs)) + (libs* (include-list\exclude-list aot-include + aot-exclude + #:all-list libs))) + (mkdir-p compile-dir) + (eval-with-clojure `(run! compile ',libs*) + source-dirs) + (let ((source-dir-files-alist (map (lambda (dir) + (cons dir (find-files* dir))) + source-dirs)) + ;; workaround transitive compilation in Clojure + (classes (filter (lambda (class) + (any (cut compiled-from? class <>) + libs*)) + (find-files* compile-dir)))) + (for-each (cut create-jar <> (cons (cons compile-dir classes) + (if omit-source? + '() + source-dir-files-alist)) + #:main-class main-class) + jar-names) + #t))) + +(define* (check #:key + test-dirs + jar-names + tests? test-include test-exclude + #:allow-other-keys) + "Standard 'check' phase for clojure-build-system. Note that TEST-EXCLUDE has +priority over TEST-INCLUDE." + (if tests? + (let* ((libs (append-map find-clojure-libs test-dirs)) + (libs* (include-list\exclude-list test-include + test-exclude + #:all-list libs))) + (for-each (lambda (jar) + (eval-with-clojure `(do (apply require + '(clojure.test ,@libs*)) + (apply clojure.test/run-tests + ',libs*)) + (cons jar test-dirs))) + jar-names))) + #t) + +(define-with-docs install + "Standard 'install' phase for clojure-build-system." + (install-jars "./")) + +(define-with-docs %standard-phases + "Standard build phases for clojure-build-system." + (modify-phases %standard-phases@ant + (replace 'build build) + (replace 'check check) + (replace 'install install) + (add-after 'install-license-files 'install-doc install-doc))) + +(define* (clojure-build #:key + inputs + (phases %standard-phases) + #:allow-other-keys + #:rest args) + "Build the given Clojure package, applying all of PHASES in order." + (apply ant-build + #:inputs inputs + #:phases phases + args)) + +;;; clojure-build-system.scm ends here diff --git a/guix/build/clojure-utils.scm b/guix/build/clojure-utils.scm new file mode 100644 index 0000000000..027777b4d1 --- /dev/null +++ b/guix/build/clojure-utils.scm @@ -0,0 +1,265 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Alex Vong <alexvong1995@gmail.com> +;;; +;;; 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 clojure-utils) + #:use-module (guix build utils) + #:use-module (ice-9 ftw) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-8) + #:use-module (srfi srfi-26) + #:export (@* + @@* + define-with-docs + + %doc-regex + install-doc + + %source-dirs + %test-dirs + %compile-dir + package-name->jar-names + %main-class + %omit-source? + %aot-include + %aot-exclude + %tests? + %test-include + %test-exclude + + %clojure-regex + canonicalize-relative-path + find-files* + file-sans-extension + relative-path->clojure-lib-string + find-clojure-libs + compiled-from? + include-list\exclude-list + eval-with-clojure + create-jar)) + +(define-syntax-rule (@* module name) + "Like (@ MODULE NAME), but resolves at run time." + (module-ref (resolve-interface 'module) 'name)) + +(define-syntax-rule (@@* module name) + "Like (@@ MODULE NAME), but resolves at run time." + (module-ref (resolve-module 'module) 'name)) + +(define-syntax-rule (define-with-docs name docs val) + "Create top-level variable named NAME with doc string DOCS and value VAL." + (begin (define name val) + (set-object-property! name 'documentation docs))) + +(define-with-docs %doc-regex + "Default regex for matching the base name of top-level documentation files." + (format #f + "(~a)|(\\.(html|markdown|md|txt)$)" + (@@ (guix build guile-build-system) + %documentation-file-regexp))) + +(define* (install-doc #:key + doc-dirs + (doc-regex %doc-regex) + outputs + #:allow-other-keys) + "Install the following to the default documentation directory: + +1. Top-level files with base name matching DOC-REGEX. +2. All files (recursively) inside DOC-DIRS. + +DOC-REGEX can be compiled or uncompiled." + (let* ((out (assoc-ref outputs "out")) + (doc (assoc-ref outputs "doc")) + (name-ver (strip-store-file-name out)) + (dest-dir (string-append (or doc out) "/share/doc/" name-ver "/")) + (doc-regex* (if (string? doc-regex) + (make-regexp doc-regex) + doc-regex))) + (for-each (cut install-file <> dest-dir) + (remove (compose file-exists? + (cut string-append dest-dir <>)) + (scandir "./" (cut regexp-exec doc-regex* <>)))) + (for-each (cut copy-recursively <> dest-dir) + doc-dirs) + #t)) + +(define-with-docs %source-dirs + "A default list of source directories." + '("src/")) + +(define-with-docs %test-dirs + "A default list of test directories." + '("test/")) + +(define-with-docs %compile-dir + "Default directory for holding class files." + "classes/") + +(define (package-name->jar-names name) + "Given NAME, a package name like \"foo-0.9.1b\", +return the list of default jar names: (\"foo-0.9.1b.jar\" \"foo.jar\")." + (map (cut string-append <> ".jar") + (list name + (receive (base-name _) + (package-name->name+version name) + base-name)))) + +(define-with-docs %main-class + "Default name for main class. It should be a symbol or #f." + #f) + +(define-with-docs %omit-source? + "Include source in jars by default." + #f) + +(define-with-docs %aot-include + "A default list of symbols deciding what to compile. Note that the exclude +list has priority over the include list. The special keyword #:all represents +all libraries found under the source directories." + '(#:all)) + +(define-with-docs %aot-exclude + "A default list of symbols deciding what not to compile. +See the doc string of '%aot-include' for more details." + '()) + +(define-with-docs %tests? + "Enable tests by default." + #t) + +(define-with-docs %test-include + "A default list of symbols deciding what tests to include. Note that the +exclude list has priority over the include list. The special keyword #:all +represents all tests found under the test directories." + '(#:all)) + +(define-with-docs %test-exclude + "A default list of symbols deciding what tests to exclude. +See the doc string of '%test-include' for more details." + '()) + +(define-with-docs %clojure-regex + "Default regex for matching the base name of clojure source files." + "\\.cljc?$") + +(define-with-docs canonicalize-relative-path + "Like 'canonicalize-path', but for relative paths. +Canonicalizations requiring the path to exist are omitted." + (let ((remove.. (lambda (ls) + (fold-right (match-lambda* + (((and comp (not "..")) (".." comps ...)) + comps) + ((comp (comps ...)) + (cons comp comps))) + '() + ls)))) + (compose (match-lambda + (() ".") + (ls (string-join ls "/"))) + remove.. + (cut remove (cut member <> '("" ".")) <>) + (cut string-split <> #\/)))) + +(define (find-files* base-dir . args) + "Similar to 'find-files', but with BASE-DIR stripped and result +canonicalized." + (map canonicalize-relative-path + (with-directory-excursion base-dir + (apply find-files "./" args)))) + +;;; FIXME: should be moved to (guix build utils) +(define-with-docs file-sans-extension + "Strip extension from path, if any." + (@@ (guix build guile-build-system) + file-sans-extension)) + +(define (relative-path->clojure-lib-string path) + "Convert PATH to a clojure library string." + (string-map (match-lambda + (#\/ #\.) + (#\_ #\-) + (chr chr)) + (file-sans-extension path))) + +(define* (find-clojure-libs base-dir + #:key (clojure-regex %clojure-regex)) + "Return the list of clojure libraries found under BASE-DIR. + +CLOJURE-REGEX can be compiled or uncompiled." + (map (compose string->symbol + relative-path->clojure-lib-string) + (find-files* base-dir clojure-regex))) + +(define (compiled-from? class lib) + "Given class file CLASS and clojure library symbol LIB, decide if CLASS +results from compiling LIB." + (string-prefix? (symbol->string lib) + (relative-path->clojure-lib-string class))) + +(define* (include-list\exclude-list include-list exclude-list + #:key all-list) + "Given INCLUDE-LIST and EXCLUDE-LIST, replace all occurences of #:all by +slicing ALL-LIST into them and compute their list difference." + (define (replace-#:all ls all-ls) + (append-map (match-lambda + (#:all all-ls) + (x (list x))) + ls)) + (let ((include-list* (replace-#:all include-list all-list)) + (exclude-list* (replace-#:all exclude-list all-list))) + (lset-difference equal? include-list* exclude-list*))) + +(define (eval-with-clojure expr extra-paths) + "Evaluate EXPR with clojure. + +EXPR must be a s-expression writable by guile and readable by clojure. +For examples, '(require '[clojure.string]) will not work, +because the guile writer converts brackets to parentheses. + +EXTRA-PATHS is a list of paths which will be appended to $CLASSPATH." + (let* ((classpath (getenv "CLASSPATH")) + (classpath* (string-join (cons classpath extra-paths) ":"))) + (invoke "java" + "-classpath" classpath* + "clojure.main" + "--eval" (object->string expr)))) + +(define* (create-jar output-jar dir-files-alist + #:key + (verbose? #t) + (compress? #f) + (main-class %main-class)) + "Given DIR-FILES-ALIST, an alist of the form: ((DIR . FILES) ...) +Create jar named OUTPUT-JAR from FILES with DIR stripped." + (let ((grouped-options (string-append "c" + (if verbose? "v" "") + "f" + (if compress? "" "0") + (if main-class "e" "")))) + (apply invoke `("jar" + ,grouped-options + ,output-jar + ,@(if main-class (list (symbol->string main-class)) '()) + ,@(append-map (match-lambda + ((dir . files) + (append-map (lambda (file) + `("-C" ,dir ,file)) + files))) + dir-files-alist))))) diff --git a/guix/build/dub-build-system.scm b/guix/build/dub-build-system.scm index 9a72e3d544..3ab50733de 100644 --- a/guix/build/dub-build-system.scm +++ b/guix/build/dub-build-system.scm @@ -67,7 +67,8 @@ (symlink (string-append path "/lib/dub/" d-basename) (string-append vendor-dir "/" d-basename)))))))) inputs) - (zero? (system* "dub" "add-path" vendor-dir)))) + (invoke "dub" "add-path" vendor-dir) + #t)) (define (grep string file-name) "Find the first occurrence of STRING in the file named FILE-NAME. @@ -88,24 +89,22 @@ (define* (build #:key (dub-build-flags '()) #:allow-other-keys) "Build a given DUB package." - (if (or (grep* "sourceLibrary" "package.json") - (grep* "sourceLibrary" "dub.sdl") ; note: format is different! - (grep* "sourceLibrary" "dub.json")) - #t - (let ((status (zero? (apply system* `("dub" "build" ,@dub-build-flags))))) - (substitute* ".dub/dub.json" - (("\"lastUpgrade\": \"[^\"]*\"") - "\"lastUpgrade\": \"1970-01-01T00:00:00.0000000\"")) - status))) + (unless (or (grep* "sourceLibrary" "package.json") + (grep* "sourceLibrary" "dub.sdl") ; note: format is different! + (grep* "sourceLibrary" "dub.json")) + (apply invoke `("dub" "build" ,@dub-build-flags)) + (substitute* ".dub/dub.json" + (("\"lastUpgrade\": \"[^\"]*\"") + "\"lastUpgrade\": \"1970-01-01T00:00:00.0000000\""))) + #t) (define* (check #:key tests? #:allow-other-keys) - (if tests? - (let ((status (zero? (system* "dub" "test")))) - (substitute* ".dub/dub.json" - (("\"lastUpgrade\": \"[^\"]*\"") - "\"lastUpgrade\": \"1970-01-01T00:00:00.0000000\"")) - status) - #t)) + (when tests? + (invoke "dub" "test") + (substitute* ".dub/dub.json" + (("\"lastUpgrade\": \"[^\"]*\"") + "\"lastUpgrade\": \"1970-01-01T00:00:00.0000000\""))) + #t) (define* (install #:key inputs outputs #:allow-other-keys) "Install a given DUB package." diff --git a/guix/build/git.scm b/guix/build/git.scm index 14d415a6f8..2d1700a9b9 100644 --- a/guix/build/git.scm +++ b/guix/build/git.scm @@ -45,6 +45,8 @@ recursively. Return #t on success, #f otherwise." (if (zero? (system* git-command "fetch" "--depth" "1" "origin" commit)) (invoke git-command "checkout" "FETCH_HEAD") (begin + (setvbuf (current-output-port) 'line) + (format #t "Failed to do a shallow fetch; retrying a full fetch...~%") (invoke git-command "fetch" "origin") (invoke git-command "checkout" commit))) (when recursive? diff --git a/guix/build/go-build-system.scm b/guix/build/go-build-system.scm index 6be0167063..022d4fe16b 100644 --- a/guix/build/go-build-system.scm +++ b/guix/build/go-build-system.scm @@ -204,6 +204,9 @@ respectively." $GOPATH/pkg, so we have to copy them into the output directory manually. Compiled executable files should have already been installed to the store based on $GOBIN in the build phase." + ;; TODO: From go-1.10 onward, the pkg folder should not be needed (see + ;; https://lists.gnu.org/archive/html/guix-devel/2018-11/msg00208.html). + ;; Remove it? (when (file-exists? "pkg") (copy-recursively "pkg" (string-append (assoc-ref outputs "out") "/pkg"))) #t) diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm index 7b556f6431..23d97e6602 100644 --- a/guix/build/haskell-build-system.scm +++ b/guix/build/haskell-build-system.scm @@ -239,7 +239,7 @@ given Haskell package." (list (string-append "--gen-pkg-config=" config-file)))) (run-setuphs "register" params) ;; The conf file is created only when there is a library to register. - (unless (file-exists? config-file) + (when (file-exists? config-file) (mkdir-p config-dir) (let* ((config-file-name+id (call-with-ascii-input-file config-file (cut grep id-rx <>)))) diff --git a/guix/build/hg.scm b/guix/build/hg.scm index ea51eb670b..b3e3ff7ac3 100644 --- a/guix/build/hg.scm +++ b/guix/build/hg.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> +;;; Copyright © 2018 Björn Höfling <bjoern.hoefling@bjoernhoefling.de> ;;; ;;; This file is part of GNU Guix. ;;; @@ -45,8 +46,10 @@ Mercurial changeset identifier. Return #t on success, #f otherwise." ;; The contents of '.hg' vary as a function of the current ;; status of the Mercurial repo. Since we want a fixed ;; output, this directory needs to be taken out. - (with-directory-excursion directory - (delete-file-recursively ".hg")) + ;; Since the '.hg' file is also in sub-modules, we have to + ;; search for it in all sub-directories. + (for-each delete-file-recursively + (find-files directory "^\\.hg$" #:directories? #t)) #t) diff --git a/guix/build/ocaml-build-system.scm b/guix/build/ocaml-build-system.scm index d10431d8ef..99111ad300 100644 --- a/guix/build/ocaml-build-system.scm +++ b/guix/build/ocaml-build-system.scm @@ -49,37 +49,40 @@ '()) ,@configure-flags))) (format #t "running 'setup.ml' with arguments ~s~%" args) - (zero? (apply system* "ocaml" "setup.ml" args))) + (apply invoke "ocaml" "setup.ml" args)) (let ((args `("-prefix" ,out ,@configure-flags))) (format #t "running 'configure' with arguments ~s~%" args) - (zero? (apply system* "./configure" args)))))) + (apply invoke "./configure" args)))) + #t) (define* (build #:key inputs outputs (build-flags '()) (make-flags '()) (use-make? #f) #:allow-other-keys) "Build the given package." (if (and (file-exists? "setup.ml") (not use-make?)) - (zero? (apply system* "ocaml" "setup.ml" "-build" build-flags)) + (apply invoke "ocaml" "setup.ml" "-build" build-flags) (if (file-exists? "Makefile") - (zero? (apply system* "make" make-flags)) + (apply invoke "make" make-flags) (let ((file (if (file-exists? "pkg/pkg.ml") "pkg/pkg.ml" "pkg/build.ml"))) - (zero? (apply system* "ocaml" "-I" - (string-append (assoc-ref inputs "findlib") - "/lib/ocaml/site-lib") - file build-flags)))))) + (apply invoke "ocaml" "-I" + (string-append (assoc-ref inputs "findlib") + "/lib/ocaml/site-lib") + file build-flags)))) + #t) (define* (check #:key inputs outputs (make-flags '()) (test-target "test") tests? (use-make? #f) #:allow-other-keys) "Install the given package." (when tests? (if (and (file-exists? "setup.ml") (not use-make?)) - (zero? (system* "ocaml" "setup.ml" (string-append "-" test-target))) + (invoke "ocaml" "setup.ml" (string-append "-" test-target)) (if (file-exists? "Makefile") - (zero? (apply system* "make" test-target make-flags)) + (apply invoke "make" test-target make-flags) (let ((file (if (file-exists? "pkg/pkg.ml") "pkg/pkg.ml" "pkg/build.ml"))) - (zero? (system* "ocaml" "-I" - (string-append (assoc-ref inputs "findlib") - "/lib/ocaml/site-lib") - file test-target))))))) + (invoke "ocaml" "-I" + (string-append (assoc-ref inputs "findlib") + "/lib/ocaml/site-lib") + file test-target))))) + #t) (define* (install #:key outputs (build-flags '()) (make-flags '()) (use-make? #f) (install-target "install") @@ -87,17 +90,19 @@ "Install the given package." (let ((out (assoc-ref outputs "out"))) (if (and (file-exists? "setup.ml") (not use-make?)) - (zero? (apply system* "ocaml" "setup.ml" - (string-append "-" install-target) build-flags)) + (apply invoke "ocaml" "setup.ml" + (string-append "-" install-target) build-flags) (if (file-exists? "Makefile") - (zero? (apply system* "make" install-target make-flags)) - (zero? (system* "opam-installer" "-i" (string-append "--prefix=" out) - (string-append "--libdir=" out "/lib/ocaml/site-lib"))))))) + (apply invoke "make" install-target make-flags) + (invoke "opam-installer" "-i" (string-append "--prefix=" out) + (string-append "--libdir=" out "/lib/ocaml/site-lib"))))) + #t) (define* (prepare-install #:key outputs #:allow-other-keys) "Prepare for building the given package." (mkdir-p (string-append (assoc-ref outputs "out") "/lib/ocaml/site-lib")) - (mkdir-p (string-append (assoc-ref outputs "out") "/bin"))) + (mkdir-p (string-append (assoc-ref outputs "out") "/bin")) + #t) (define %standard-phases ;; Everything is as with the GNU Build System except for the `configure' diff --git a/guix/build/store-copy.scm b/guix/build/store-copy.scm index 64ade7885c..549aa4f28b 100644 --- a/guix/build/store-copy.scm +++ b/guix/build/store-copy.scm @@ -168,6 +168,28 @@ REFERENCE-GRAPHS, a list of reference-graph files." (reduce + 0 (map file-size items))) +(define (reset-permissions file) + "Reset the permissions on FILE and its sub-directories so that they are all +read-only." + ;; XXX: This procedure exists just to work around the inability of + ;; 'copy-recursively' to preserve permissions. + (file-system-fold (const #t) ;enter? + (lambda (file stat _) ;leaf + (unless (eq? 'symlink (stat:type stat)) + (chmod file + (if (zero? (logand (stat:mode stat) + #o100)) + #o444 + #o555)))) + (const #t) ;down + (lambda (directory stat _) ;up + (chmod directory #o555)) + (const #f) ;skip + (const #f) ;error + #t + file + lstat)) + (define* (populate-store reference-graphs target #:key (log-port (current-error-port))) "Populate the store under directory TARGET with the items specified in @@ -197,7 +219,13 @@ REFERENCE-GRAPHS, a list of reference-graph files." (for-each (lambda (thing) (copy-recursively thing (string-append target thing) + #:keep-mtime? #t #:log (%make-void-port "w")) + + ;; XXX: Since 'copy-recursively' doesn't allow us to + ;; preserve permissions, we have to traverse TARGET to + ;; make sure everything is read-only. + (reset-permissions (string-append target thing)) (report)) things))))) |