diff options
author | Leo Famulari <leo@famulari.name> | 2016-03-21 12:22:31 -0400 |
---|---|---|
committer | Leo Famulari <leo@famulari.name> | 2016-03-21 12:22:31 -0400 |
commit | 09ec508a4c14d1bc09622d98f796548d79ab0552 (patch) | |
tree | 86cc5a2a67d35ad796bfa33d67869d670d65822e /guix/build | |
parent | 2dbed47f5c09347c9af42c5f5bacfccbc1ab4aff (diff) | |
parent | 71cafa0472a15f2234e24d3c6d8019ebb38685b0 (diff) | |
download | guix-patches-09ec508a4c14d1bc09622d98f796548d79ab0552.tar guix-patches-09ec508a4c14d1bc09622d98f796548d79ab0552.tar.gz |
Merge branch 'master' into core-updates
Diffstat (limited to 'guix/build')
-rw-r--r-- | guix/build/ant-build-system.scm | 160 | ||||
-rw-r--r-- | guix/build/download.scm | 32 | ||||
-rw-r--r-- | guix/build/graft.scm | 7 |
3 files changed, 190 insertions, 9 deletions
diff --git a/guix/build/ant-build-system.scm b/guix/build/ant-build-system.scm new file mode 100644 index 0000000000..d302b948b5 --- /dev/null +++ b/guix/build/ant-build-system.scm @@ -0,0 +1,160 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net> +;;; +;;; 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 ant-build-system) + #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #:use-module (guix build syscalls) + #:use-module (guix build utils) + #:use-module (sxml simple) + #:use-module (ice-9 match) + #:use-module (ice-9 ftw) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (%standard-phases + ant-build)) + +;; Commentary: +;; +;; Builder-side code of the standard build procedure for Java packages using +;; Ant. +;; +;; Code: + +(define (default-build.xml jar-name prefix) + "Create a simple build.xml with standard targets for Ant." + (call-with-output-file "build.xml" + (lambda (port) + (sxml->xml + `(project (@ (basedir ".")) + (property (@ (name "classes.dir") + (value "${basedir}/build/classes"))) + (property (@ (name "jar.dir") + (value "${basedir}/build/jar"))) + (property (@ (name "dist.dir") + (value ,prefix))) + + ;; respect the CLASSPATH environment variable + (property (@ (name "build.sysclasspath") + (value "first"))) + (property (@ (environment "env"))) + (path (@ (id "classpath")) + (pathelement (@ (location "${env.CLASSPATH}")))) + + (target (@ (name "compile")) + (mkdir (@ (dir "${classes.dir}"))) + (javac (@ (includeantruntime "false") + (srcdir "src") + (destdir "${classes.dir}") + (classpath (@ (refid "classpath")))))) + + (target (@ (name "jar") + (depends "compile")) + (mkdir (@ (dir "${jar.dir}"))) + ;; We cannot use the simpler "jar" task here, because + ;; there is no way to disable generation of a + ;; manifest. We do not include a generated manifest + ;; to ensure determinism, because we cannot easily + ;; reset the ctime/mtime before creating the archive. + (exec (@ (executable "jar")) + (arg (@ (line ,(string-append "-Mcf ${jar.dir}/" jar-name + " -C ${classes.dir} .")))))) + + (target (@ (name "install")) + (copy (@ (todir "${dist.dir}")) + (fileset (@ (dir "${jar.dir}")) + (include (@ (name "**/*.jar"))))))) + port))) + (utime "build.xml" 0 0) + #t) + +(define (generate-classpath inputs) + "Return a colon-separated string of full paths to jar files found among the +INPUTS." + (string-join + (apply append (map (match-lambda + ((_ . dir) + (find-files dir "\\.*jar$"))) + inputs)) ":")) + +(define* (configure #:key inputs outputs (jar-name #f) + #:allow-other-keys) + (when jar-name + (default-build.xml jar-name + (string-append (assoc-ref outputs "out") + "/share/java"))) + (setenv "JAVA_HOME" (assoc-ref inputs "jdk")) + (setenv "CLASSPATH" (generate-classpath inputs))) + +(define* (build #:key (make-flags '()) (build-target "jar") + #:allow-other-keys) + (zero? (apply system* `("ant" ,build-target ,@make-flags)))) + +(define* (strip-jar-timestamps #:key outputs + #:allow-other-keys) + "Unpack all jar archives, reset the timestamp of all contained files, and +repack them. This is necessary to ensure that archives are reproducible." + (define (repack-archive jar) + (format #t "repacking ~a\n" jar) + (let ((dir (mkdtemp! "jar-contents.XXXXXX"))) + (and (with-directory-excursion dir + (zero? (system* "jar" "xf" jar))) + ;; The manifest file contains timestamps + (for-each delete-file (find-files dir "MANIFEST.MF")) + (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)) + (unless (zero? (system* "jar" "-Mcf" jar "-C" dir ".")) + (error "'jar' failed")) + (utime jar 0 0) + #t))) + + (every (match-lambda + ((output . directory) + (every repack-archive (find-files directory "\\.jar$")))) + outputs)) + +(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))) + +(define* (install #:key (make-flags '()) #:allow-other-keys) + (zero? (apply system* `("ant" "install" ,@make-flags)))) + +(define %standard-phases + (modify-phases gnu:%standard-phases + (replace 'configure configure) + (replace 'build build) + (replace 'check check) + (replace 'install install) + (add-after 'install 'strip-jar-timestamps strip-jar-timestamps))) + +(define* (ant-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + "Build the given Java package, applying all of PHASES in order." + (apply gnu:gnu-build #:inputs inputs #:phases phases args)) + +;;; ant-build-system.scm ends here diff --git a/guix/build/download.scm b/guix/build/download.scm index 8843804c40..0568800d7f 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2015 Steve Sprang <scs@stevesprang.com> ;;; @@ -34,6 +34,7 @@ #:use-module (ice-9 format) #:export (open-socket-for-uri open-connection-for-uri + close-connection resolve-uri-reference maybe-expand-mirrors url-fetch @@ -236,11 +237,14 @@ abbreviation of URI showing the scheme, host, and basename of the file." (module-autoload! (current-module) '(gnutls) '(make-session connection-end/client)) -(define add-weak-reference - (let ((table (make-weak-key-hash-table))) - (lambda (from to) - "Hold a weak reference from FROM to TO." - (hashq-set! table from to)))) +(define %tls-ports + ;; Mapping of session record ports to the underlying file port. + (make-weak-key-hash-table)) + +(define (register-tls-record-port record-port port) + "Hold a weak reference from RECORD-PORT to PORT, where RECORD-PORT is a TLS +session record port using PORT as its underlying communication port." + (hashq-set! %tls-ports record-port port)) (define (tls-wrap port server) "Return PORT wrapped in a TLS connection to SERVER. SERVER must be a DNS @@ -275,7 +279,7 @@ host name without trailing dot." ;; closed when PORT is GC'd. If we used `port->fdes', it would instead ;; never be closed. So we use `fileno', but keep a weak reference to ;; PORT, so the file descriptor gets closed when RECORD is GC'd. - (add-weak-reference record port) + (register-tls-record-port record port) record))) (define (ensure-uri uri-or-string) ;XXX: copied from (web http) @@ -337,7 +341,8 @@ ETIMEDOUT error is raised." (loop (cdr addresses)))))))) (define* (open-connection-for-uri uri #:key timeout) - "Like 'open-socket-for-uri', but also handle HTTPS connections." + "Like 'open-socket-for-uri', but also handle HTTPS connections. The +resulting port must be closed with 'close-connection'." (define https? (eq? 'https (uri-scheme uri))) @@ -367,6 +372,17 @@ ETIMEDOUT error is raised." (tls-wrap s (uri-host uri)) s))))) +(define (close-connection port) + "Like 'close-port', but (1) idempotent, and (2) also closes the underlying +port if PORT is a TLS session record port." + ;; FIXME: This is a partial workaround for <http://bugs.gnu.org/20145>, + ;; because 'http-fetch' & co. may return a chunked input port whose 'close' + ;; method calls 'close-port', not 'close-connection'. + (unless (port-closed? port) + (close-port port)) + (and=> (hashq-ref %tls-ports port) + close-connection)) + ;; XXX: This is an awful hack to make sure the (set-port-encoding! p ;; "ISO-8859-1") call in `read-response' passes, even during bootstrap ;; where iconv is not available. diff --git a/guix/build/graft.scm b/guix/build/graft.scm index 0a9cd3260c..b216e6c0d7 100644 --- a/guix/build/graft.scm +++ b/guix/build/graft.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -118,6 +118,11 @@ file name pairs." (else (error "unsupported file type" stat))))) + ;; XXX: Work around occasional "suspicious ownership or permission" daemon + ;; errors that arise when we create the top-level /gnu/store/… directory as + ;; #o777. + (umask #o022) + (n-par-for-each (parallel-job-count) rewrite-leaf (find-files directory))) |