diff options
| -rw-r--r-- | Makefile.am | 3 | ||||
| -rw-r--r-- | guix/build-system/ant.scm | 3 | ||||
| -rw-r--r-- | guix/build/java-utils.scm | 159 | ||||
| -rw-r--r-- | guix/build/maven/java.scm | 147 | ||||
| -rw-r--r-- | guix/build/maven/plugin.scm | 498 | ||||
| -rw-r--r-- | guix/build/maven/pom.scm | 422 |
6 files changed, 1231 insertions, 1 deletions
diff --git a/Makefile.am b/Makefile.am index 20d43cd130..c067e37c5f 100644 --- a/Makefile.am +++ b/Makefile.am @@ -212,6 +212,9 @@ MODULES = \ guix/build/emacs-utils.scm \ guix/build/java-utils.scm \ guix/build/lisp-utils.scm \ + guix/build/maven/java.scm \ + guix/build/maven/plugin.scm \ + guix/build/maven/pom.scm \ guix/build/graft.scm \ guix/build/bournish.scm \ guix/build/qt-utils.scm \ diff --git a/guix/build-system/ant.scm b/guix/build-system/ant.scm index b5626bd42d..1809d1f3d2 100644 --- a/guix/build-system/ant.scm +++ b/guix/build-system/ant.scm @@ -39,6 +39,9 @@ (define %ant-build-system-modules ;; Build-side modules imported by default. `((guix build ant-build-system) + (guix build maven java) + (guix build maven plugin) + (guix build maven pom) (guix build java-utils) (guix build syscalls) ,@%gnu-build-system-modules)) diff --git a/guix/build/java-utils.scm b/guix/build/java-utils.scm index 8200638bee..a868e4d52c 100644 --- a/guix/build/java-utils.scm +++ b/guix/build/java-utils.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Alex Vong <alexvong1995@gmail.com> +;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,9 +21,17 @@ (define-module (guix build java-utils) #:use-module (guix build utils) + #:use-module (guix build syscalls) + #:use-module (guix build maven pom) + #:use-module (guix build maven plugin) + #:use-module (ice-9 match) + #:use-module (sxml simple) #:export (ant-build-javadoc + generate-plugin.xml install-jars - install-javadoc)) + install-javadoc + install-pom-file + install-from-pom)) (define* (ant-build-javadoc #:key (target "javadoc") (make-flags '()) #:allow-other-keys) @@ -49,3 +58,151 @@ install javadocs when this is not done by the install target." (mkdir-p docs) (copy-recursively apidoc-directory docs) #t))) + +(define* (install-pom-file pom-file) + "Install a @file{.pom} file to a maven repository structure in @file{lib/m2} +that respects the file's artifact ID and group ID. This requires the parent +pom, if any, to be present in the inputs so some of this information can be +fetched." + (lambda* (#:key inputs outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (java-inputs (append (map cdr inputs) (map cdr outputs))) + (pom-content (get-pom pom-file)) + (version (pom-version pom-content java-inputs)) + (artifact (pom-artifactid pom-content)) + (group (group->dir (pom-groupid pom-content java-inputs))) + (repository (string-append out "/lib/m2/" group "/" artifact "/" + version "/")) + (pom-name (string-append repository artifact "-" version ".pom"))) + (mkdir-p (dirname pom-name)) + (copy-file pom-file pom-name)) + #t)) + +(define (install-jar-file-with-pom jar pom-file inputs) + "Unpack the jar archive, add the pom file, and repack it. This is necessary +to ensure that maven can find dependencies." + (format #t "adding ~a to ~a\n" pom-file jar) + (let* ((dir (mkdtemp! "jar-contents.XXXXXX")) + (manifest (string-append dir "/META-INF/MANIFEST.MF")) + (pom (get-pom pom-file)) + (artifact (pom-artifactid pom)) + (group (pom-groupid pom inputs)) + (version (pom-version pom inputs)) + (pom-dir (string-append "META-INF/maven/" group "/" artifact))) + (mkdir-p (string-append dir "/" pom-dir)) + (copy-file pom-file (string-append dir "/" pom-dir "/pom.xml")) + (with-directory-excursion dir + (with-output-to-file (string-append pom-dir "/pom.properties") + (lambda _ + (format #t "version=~a~%" version) + (format #t "groupId=~a~%" group) + (format #t "artifactId=~a~%" artifact))) + (invoke "jar" "uf" jar (string-append pom-dir "/pom.xml") + (string-append pom-dir "/pom.properties"))) + #t)) + +(define* (install-from-pom pom-file) + "Install a jar archive and its @var{pom-file} to a maven repository structure +in @file{lib/m2}. This requires the parent pom file, if any, to be present in +the inputs of the package being built. This phase looks either for a properly +named jar file (@file{artifactID-version.jar}) or the single jar in the build +directory. If there are more than one jar, and none is named appropriately, +the phase fails." + (lambda* (#:key inputs outputs jar-name #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (java-inputs (append (map cdr inputs) (map cdr outputs))) + (pom-content (get-pom pom-file)) + (version (pom-version pom-content java-inputs)) + (artifact (pom-artifactid pom-content)) + (group (group->dir (pom-groupid pom-content java-inputs))) + (repository (string-append out "/lib/m2/" group "/" artifact "/" + version "/")) + ;; We try to find the file that was built. If it was built from our + ;; generated ant.xml file, it is name jar-name, otherwise it should + ;; have the expected name for maven. + (jars (find-files "." (or jar-name (string-append artifact "-" + version ".jar")))) + ;; Otherwise, we try to find any jar file. + (jars (if (null? jars) + (find-files "." ".*.jar") + jars)) + (jar-name (string-append repository artifact "-" version ".jar")) + (pom-name (string-append repository artifact "-" version ".pom"))) + ;; Ensure we can override the file + (chmod pom-file #o644) + (fix-pom-dependencies pom-file java-inputs) + (mkdir-p (dirname jar-name)) + (copy-file pom-file pom-name) + ;; If there are too many jar files, we don't know which one to install, so + ;; fail. + (if (= (length jars) 1) + (begin + (copy-file (car jars) jar-name) + (install-jar-file-with-pom jar-name pom-file java-inputs)) + (throw 'no-jars jars))) + #t)) + +(define (sxml-indent sxml) + "Adds some indentation to @var{sxml}, an sxml value, to make reviewing easier +after the value is written to an xml file." + (define (sxml-indent-aux sxml lvl) + (match sxml + ((? string? str) str) + ((tag ('@ attr ...) content ...) + (cond + ((null? content) sxml) + ((string? (car content)) sxml) + (else + `(,tag (@ ,@attr) ,(sxml-indent-content content (+ lvl 1)))))) + ((tag content ...) + (cond + ((null? content) sxml) + ((string? (car content)) sxml) + (else `(,tag ,(sxml-indent-content content (+ lvl 1)))))) + (_ sxml))) + (define (sxml-indent-content sxml lvl) + (map + (lambda (sxml) + (list "\n" (string-join (make-list (* 2 lvl) " ") "") + (sxml-indent-aux sxml lvl))) + sxml)) + (sxml-indent-aux sxml 0)) + +(define* (generate-plugin.xml pom-file goal-prefix directory source-groups + #:key + (plugin.xml "build/classes/META-INF/maven/plugin.xml")) + "Generates the @file{plugin.xml} file that is required by Maven so it can +recognize the package as a plugin, and find the entry points in the plugin." + (lambda* (#:key inputs outputs #:allow-other-keys) + (let* ((pom-content (get-pom pom-file)) + (java-inputs (append (map cdr inputs) (map cdr outputs))) + (name (pom-name pom-content)) + (description (pom-description pom-content)) + (dependencies (pom-dependencies pom-content)) + (version (pom-version pom-content java-inputs)) + (artifact (pom-artifactid pom-content)) + (groupid (pom-groupid pom-content java-inputs)) + (mojos + `(mojos + ,@(with-directory-excursion directory + (map + (lambda (group) + (apply generate-mojo-from-files maven-convert-type group)) + source-groups))))) + (mkdir-p (dirname plugin.xml)) + (with-output-to-file plugin.xml + (lambda _ + (sxml->xml + (sxml-indent + `(plugin + (name ,name) + (description ,description) + (groupId ,groupid) + (artifactId ,artifact) + (version ,version) + (goalPrefix ,goal-prefix) + (isolatedRealm "false") + (inheritedByDefault "true") + ,mojos + (dependencies + ,@dependencies))))))))) diff --git a/guix/build/maven/java.scm b/guix/build/maven/java.scm new file mode 100644 index 0000000000..daa4c88045 --- /dev/null +++ b/guix/build/maven/java.scm @@ -0,0 +1,147 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019, 2020 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 maven java) + #:use-module (ice-9 peg) + #:use-module (ice-9 textual-ports) + #:export (parse-java-file)) + +(define-peg-pattern java-file body (and (* WS) (* (and top-level-statement + (* WS))))) +(define-peg-pattern WS none (or " " "\n" "\t" "\r")) +(define-peg-pattern top-level-statement body (or package import-pat class-pat comment inline-comment)) +(define-peg-pattern package all (and (ignore "package") (* WS) package-name + (* WS) (ignore ";"))) +(define-peg-pattern import-pat all (and (ignore "import") (* WS) + (? (and (ignore "static") (* WS))) + package-name + (* WS) (ignore ";"))) +(define-peg-pattern comment all (and (? (and annotation-pat (* WS))) (ignore "/*") + comment-part)) +(define-peg-pattern comment-part body (or (ignore (and (* "*") "/")) + (and (* "*") (+ comment-chr) comment-part))) +(define-peg-pattern comment-chr body (or "\t" "\n" (range #\ #\)) (range #\+ #\xffff))) +(define-peg-pattern inline-comment none (and (ignore "//") (* inline-comment-chr) + (ignore "\n"))) +(define-peg-pattern inline-comment-chr body (range #\ #\xffff)) +(define-peg-pattern package-name body (* (or (range #\a #\z) (range #\A #\Z) + (range #\0 #\9) "_" "."))) +(define-peg-pattern class-pat all (and (? (and annotation-pat (* WS))) + (* (ignore (or inline-comment comment))) + (? (and (ignore "private") (* WS))) + (? (and (ignore "public") (* WS))) + (? (and (ignore "static") (* WS))) + (? (and (ignore "final") (* WS))) + (? (and (ignore "abstract") (* WS))) + (ignore "class") + (* WS) package-name (* WS) + (? extends) + (? implements) + (ignore "{") class-body (ignore "}"))) +(define-peg-pattern extends all (? (and (ignore "extends") (* WS) + package-name (* WS)))) +(define-peg-pattern implements all (? (and (ignore "implements") (* WS) + package-name (* WS)))) +(define-peg-pattern annotation-pat all (and (ignore "@") package-name + (? (and + (* WS) + (ignore "(") (* WS) + annotation-attr (* WS) + (* (and (ignore ",") (* WS) + annotation-attr (* WS))) + (ignore ")"))))) +(define-peg-pattern annotation-attr all (or (and attr-name (* WS) (ignore "=") + (* WS) attr-value (* WS)) + attr-value)) +(define-peg-pattern attr-name all (* (or (range #\a #\z) (range #\A #\Z) (range #\0 #\9) + "_"))) +(define-peg-pattern attr-value all (or "true" "false" + (+ (or (range #\0 #\9) (range #\a #\z) + (range #\A #\Z) "." "_")) + array-pat + string-pat)) +(define-peg-pattern array-pat body + (and (ignore "{") (* WS) value + (* (and (* WS) "," (* WS) value)) + (* WS) (ignore "}"))) +(define-peg-pattern string-pat body (and (ignore "\"") (* string-chr) (ignore "\""))) +(define-peg-pattern string-chr body (or " " "!" (and (ignore "\\") "\"") + (and (ignore "\\") "\\") (range #\# #\xffff))) + +(define-peg-pattern class-body all (and (* WS) (* (and class-statement (* WS))))) +(define-peg-pattern class-statement body (or inline-comment comment param-pat + method-pat class-pat)) +(define-peg-pattern param-pat all (and (* (and annotation-pat (* WS) + (? (ignore inline-comment)) + (* WS))) + (? (and (ignore (or "private" "public" + "protected")) + (* WS))) + (? (and (ignore "static") (* WS))) + (? (and (ignore "volatile") (* WS))) + (? (and (ignore "final") (* WS))) + type-name (* WS) param-name + (? (and (* WS) (ignore "=") (* WS) value)) + (ignore ";"))) +(define-peg-pattern value none (or string-pat (+ valuechr))) +(define-peg-pattern valuechr none (or comment inline-comment "\n" + "\t" "\r" + (range #\ #\:) (range #\< #\xffff))) +(define-peg-pattern param-name all (* (or (range #\a #\z) (range #\A #\Z) (range #\0 #\9) + "_"))) +(define-peg-pattern type-name all type-pat) +(define-peg-pattern type-pat body + (or "?" + (and (* (or (range #\a #\z) (range #\A #\Z) (range #\0 #\9) "_")) + (? "...") + (? "[]") + (? type-param)))) +(define-peg-pattern type-param body (and "<" (? type-pat) + (* (and (* WS) "," (* WS) type-pat)) + (* WS) ">")) +(define-peg-pattern method-pat all (and (* (and annotation-pat (* WS))) + (? (and (ignore (or "private" "public" "protected")) + (* WS))) + (? (and (ignore type-param) (* WS))) + (? (and (ignore (or "abstract" "final")) + (* WS))) + (? (and (ignore "static") (* WS))) + type-name (* WS) param-name (* WS) + (ignore "(") + param-list (ignore ")") (* WS) + (? (and (ignore "throws") (* WS) package-name (* WS) + (* (and (ignore ",") (* WS) package-name + (* WS))))) + (or (ignore ";") + (and (ignore "{") (* WS) + (? (and method-statements (* WS))) + (ignore "}"))))) +(define-peg-pattern param-list all (and (* WS) (* (and (? annotation-pat) (* WS) + type-name (* WS) + param-name (* WS) + (? (ignore ",")) (* WS))))) +(define-peg-pattern method-statements none (and (or (+ method-chr) + (and "{" method-statements "}") + string-pat) + (? method-statements))) +(define-peg-pattern method-chr none (or "\t" "\n" "\r" " " "!" (range #\# #\z) "|" + (range #\~ #\xffff))) + + +(define (parse-java-file file) + (peg:tree (match-pattern java-file (call-with-input-file file get-string-all)))) diff --git a/guix/build/maven/plugin.scm b/guix/build/maven/plugin.scm new file mode 100644 index 0000000000..13148ab53c --- /dev/null +++ b/guix/build/maven/plugin.scm @@ -0,0 +1,498 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019, 2020 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 maven plugin) + #:use-module (guix build maven java) + #:use-module (ice-9 textual-ports) + #:use-module (ice-9 match) + #:use-module (srfi srfi-9) + #:export (generate-mojo-from-files + default-convert-type + maven-convert-type)) + +(define-record-type mojo + (make-mojo package name goal description requires-dependency-collection + requires-dependency-resolution requires-direct-invocation? + requires-project? requires-reports? aggregator? requires-online? + inherited-by-default? instantiation-strategy execution-strategy + since thread-safe? phase parameters components) + mojo? + (package mojo-package) + (name mojo-name) + (goal mojo-goal) + (description mojo-description) + (requires-dependency-collection mojo-requires-dependency-collection) + (requires-dependency-resolution mojo-requires-dependency-resolution) + (requires-direct-invocation? mojo-requires-direct-invocation?) + (requires-project? mojo-requires-project?) + (requires-reports? mojo-requires-reports?) + (aggregator? mojo-aggregator?) + (requires-online? mojo-requires-online?) + (inherited-by-default? mojo-inherited-by-default?) + (instantiation-strategy mojo-instantiation-strategy) + (execution-strategy mojo-execution-strategy) + (since mojo-since) + (thread-safe? mojo-thread-safe?) + (phase mojo-phase) + (parameters mojo-parameters) + (components mojo-components)) + +(define* (update-mojo mojo + #:key + (package (mojo-package mojo)) + (name (mojo-name mojo)) + (goal (mojo-goal mojo)) + (description (mojo-description mojo)) + (requires-dependency-collection (mojo-requires-dependency-collection mojo)) + (requires-dependency-resolution (mojo-requires-dependency-resolution mojo)) + (requires-direct-invocation? (mojo-requires-direct-invocation? mojo)) + (requires-project? (mojo-requires-project? mojo)) + (requires-reports? (mojo-requires-reports? mojo)) + (aggregator? (mojo-aggregator? mojo)) + (requires-online? (mojo-requires-online? mojo)) + (inherited-by-default? (mojo-inherited-by-default? mojo)) + (instantiation-strategy (mojo-instantiation-strategy mojo)) + (execution-strategy (mojo-execution-strategy mojo)) + (since (mojo-since mojo)) + (thread-safe? (mojo-thread-safe? mojo)) + (phase (mojo-phase mojo)) + (parameters (mojo-parameters mojo)) + (components (mojo-components mojo))) + (make-mojo package name goal description requires-dependency-collection + requires-dependency-resolution requires-direct-invocation? + requires-project? requires-reports? aggregator? requires-online? + inherited-by-default? instantiation-strategy execution-strategy + since thread-safe? phase parameters components)) + +(define-record-type mojo-parameter + (make-mojo-parameter name type since required editable property description + configuration) + mojo-parameter? + (name mojo-parameter-name) + (type mojo-parameter-type) + (since mojo-parameter-since) + (required mojo-parameter-required) + (editable mojo-parameter-editable) + (property mojo-parameter-property) + (description mojo-parameter-description) + (configuration mojo-parameter-configuration)) + +(define* (update-mojo-parameter mojo-parameter + #:key (name (mojo-parameter-name mojo-parameter)) + (type (mojo-parameter-type mojo-parameter)) + (since (mojo-parameter-since mojo-parameter)) + (required (mojo-parameter-required mojo-parameter)) + (editable (mojo-parameter-editable mojo-parameter)) + (property (mojo-parameter-property mojo-parameter)) + (description (mojo-parameter-description mojo-parameter)) + (configuration (mojo-parameter-configuration mojo-parameter))) + (make-mojo-parameter name type since required editable property description + configuration)) + +(define-record-type <mojo-component> + (make-mojo-component field role hint) + mojo-component? + (field mojo-component-field) + (role mojo-component-role) + (hint mojo-component-hint)) + +(define* (update-mojo-component mojo-component + #:key (field (mojo-component-field mojo-component)) + (role (mojo-component-role mojo-component)) + (hint (mojo-component-hint mojo-component))) + (make-mojo-component field role hint)) + +(define (generate-mojo-parameter mojo-parameter) + `(parameter (name ,(mojo-parameter-name mojo-parameter)) + (type ,(mojo-parameter-type mojo-parameter)) + ,@(if (mojo-parameter-since mojo-parameter) + `(since (mojo-parameter-since mojo-parameter)) + '()) + (required ,(if (mojo-parameter-required mojo-parameter) "true" "false")) + (editable ,(if (mojo-parameter-editable mojo-parameter) "true" "false")) + (description ,(mojo-parameter-description mojo-parameter)))) + +(define (generate-mojo-configuration mojo-parameter) + (let ((config (mojo-parameter-configuration mojo-parameter))) + (if (or config (mojo-parameter-property mojo-parameter)) + `(,(string->symbol (mojo-parameter-name mojo-parameter)) + (@ ,@(cons (list 'implementation (mojo-parameter-type mojo-parameter)) + (or config '()))) + ,@(if (mojo-parameter-property mojo-parameter) + (list (string-append "${" (mojo-parameter-property mojo-parameter) + "}")) + '())) + #f))) + +(define (generate-mojo-component mojo-component) + (let ((role (mojo-component-role mojo-component)) + (field (mojo-component-field mojo-component)) + (hint (mojo-component-hint mojo-component))) + `(requirement + (role ,role) + ,@(if hint + `((role-hint ,hint)) + '()) + (field-name ,field)))) + +(define (generate-mojo mojo) + `(mojo + (goal ,(mojo-goal mojo)) + (description ,(mojo-description mojo)) + ,@(let ((val (mojo-requires-dependency-collection mojo))) + (if val + `((requiresDependencyCollection ,val)) + '())) + ,@(let ((val (mojo-requires-dependency-resolution mojo))) + (if val + `((requiresDependencyResolution ,val)) + '())) + ,@(let ((val (mojo-requires-direct-invocation? mojo))) + (if val + `((requiresDirectInvocation ,val)) + '())) + ,@(let ((val (mojo-requires-project? mojo))) + (if val + `((requiresProject ,val)) + '())) + ,@(let ((val (mojo-requires-reports? mojo))) + (if val + `((requiresReports ,val)) + '())) + ,@(let ((val (mojo-aggregator? mojo))) + (if val + `((aggregator ,val)) + '())) + ,@(let ((val (mojo-requires-online? mojo))) + (if val + `((requiresOnline ,val)) + '())) + ,@(let ((val (mojo-inherited-by-default? mojo))) + (if val + `((inheritedByDefault ,val)) + '())) + ,@(let ((phase (mojo-phase mojo))) + (if phase + `((phase ,phase)) + '())) + (implementation ,(string-append (mojo-package mojo) "." (mojo-name mojo))) + (language "java") + (instantiationStrategy ,(mojo-instantiation-strategy mojo)) + (executionStrategy ,(mojo-execution-strategy mojo)) + ,@(let ((since (mojo-since mojo))) + (if since + `((since ,since)) + '())) + ,@(let ((val (mojo-thread-safe? mojo))) + (if val + `((threadSafe ,val)) + '())) + (parameters + ,(map generate-mojo-parameter (mojo-parameters mojo))) + (configuration + ,@(filter (lambda (a) a) (map generate-mojo-configuration (mojo-parameters mojo)))) + (requirements + ,@(map generate-mojo-component (mojo-components mojo))))) + + +(define (default-convert-type type) + (cond + ((equal? type "String") "java.lang.String") + ((equal? type "String[]") "java.lang.String[]") + ((equal? type "File") "java.io.File") + ((equal? type "File[]") "java.io.File[]") + ((equal? type "List") "java.util.List") + ((equal? type "Boolean") "java.lang.Boolean") + ((equal? type "Properties") "java.util.Properties") + ((and (> (string-length type) 5) + (equal? (substring type 0 4) "Map<")) + "java.util.Map") + ((and (> (string-length type) 6) + (equal? (substring type 0 5) "List<")) + "java.util.List") + ((and (> (string-length type) 15) + (equal? (substring type 0 14) "LinkedHashSet<")) + "java.util.LinkedHashSet") + (else type))) + +(define (maven-convert-type type) + (cond + ((equal? type "MavenProject") + "org.apache.maven.project.MavenProject") + (else (default-convert-type type)))) + +(define (update-mojo-from-file mojo file convert-type) + (define parse-tree (parse-java-file file)) + + (define (update-mojo-from-attrs mojo attrs) + (let loop ((mojo mojo) (attrs attrs)) + (match attrs + ('() mojo) + ((attr attrs ...) + (match attr + (('annotation-attr ('attr-name name) ('attr-value value)) + (cond + ((equal? name "name") + (loop (update-mojo mojo #:goal value) attrs)) + ((equal? name "defaultPhase") + (let* ((phase (car (reverse (string-split value #\.)))) + (phase (string-downcase phase)) + (phase (string-join (string-split phase #\_) "-"))) + (loop (update-mojo mojo #:phase phase) attrs))) + ((equal? name "requiresProject") + (loop (update-mojo mojo #:requires-project? value) attrs)) + ((equal? name "threadSafe") + (loop (update-mojo mojo #:thread-safe? value) attrs)) + ((equal? name "aggregator") + (loop (update-mojo mojo #:aggregator? value) attrs)) + ((equal? name "requiresDependencyCollection") + (loop + (update-mojo mojo #:requires-dependency-collection + (match value + ("ResolutionScope.COMPILE" "compile") + ("ResolutionScope.COMPILE_PLUS_RUNTIME" + "compile+runtime") + ("ResolutionScope.RUNTIME" "runtime") + ("ResolutionScope.RUNTIME_PLUS_SYSTEM" + "runtime+system") + ("ResolutionScope.TEST" "test") + ("ResolutionScope.PROVIDED" "provided") + ("ResolutionScope.SYSTEM" "system") + ("ResolutionScope.IMPORT" "import"))) + attrs)) + ((equal? name "requiresDependencyResolution") + (loop + (update-mojo mojo #:requires-dependency-resolution + (match value + ("ResolutionScope.COMPILE" "compile") + ("ResolutionScope.COMPILE_PLUS_RUNTIME" + "compile+runtime") + ("ResolutionScope.RUNTIME" "runtime") + ("ResolutionScope.RUNTIME_PLUS_SYSTEM" + "runtime+system") + ("ResolutionScope.TEST" "test") + ("ResolutionScope.PROVIDED" "provided") + ("ResolutionScope.SYSTEM" "system") + ("ResolutionScope.IMPORT" "import"))) + attrs)) + (else + (throw 'not-found-attr name)))) + ((attrs ...) (loop mojo attrs)) + (_ (loop mojo attrs))))))) + + (define (string->attr name) + (define (string-split-upper s) + (let ((i (string-index s char-set:upper-case))) + (if (and i (> i 0)) + (cons (substring s 0 i) (string-split-upper (substring s i))) + (list s)))) + (string->symbol + (string-join (map string-downcase (string-split-upper name)) "-"))) + + (define (update-mojo-parameter-from-attrs mojo-parameter attrs) + (match attrs + ('() mojo-parameter) + (('annotation-attr ('attr-name name) 'attr-value) + mojo-parameter) + ;(update-mojo-parameter-from-attrs mojo-parameter + ; `(annotation-attr (attr-name ,name) (attr-value "")))) + (('annotation-attr ('attr-name name) ('attr-value value)) + (cond + ((equal? name "editable") + (update-mojo-parameter mojo-parameter #:editable value)) + ((equal? name "required") + (update-mojo-parameter mojo-parameter #:required value)) + ((equal? name "property") + (update-mojo-parameter mojo-parameter #:property value)) + (else + (update-mojo-parameter mojo-parameter + #:configuration + (cons + (list (string->attr name) value) + (or + (mojo-parameter-configuration mojo-parameter) + '())))))) + ((attr attrs ...) + (update-mojo-parameter-from-attrs + (update-mojo-parameter-from-attrs mojo-parameter attr) + attrs)))) + + (define (update-mojo-component-from-attrs mojo-component inverse-import attrs) + (match attrs + ('() mojo-component) + ((attr attrs ...) + (match attr + (('annotation-attr ('attr-name name) ('attr-value value)) + (cond + ((equal? name "role") + (update-mojo-component-from-attrs + (update-mojo-component mojo-component + #:role (select-import inverse-import value convert-type)) + inverse-import + attrs)) + ((equal? name "hint") + (update-mojo-component-from-attrs + (update-mojo-component mojo-component #:hint value) + inverse-import + attrs)) + (else (throw 'not-found-attr name)))) + ((attrss ...) + (update-mojo-component-from-attrs + mojo-component inverse-import (append attrss attrs))))))) + + (define (add-mojo-parameter parameters name type last-comment attrs inverse-import) + (let loop ((parameters parameters)) + (match parameters + ('() (list (update-mojo-parameter-from-attrs + (make-mojo-parameter + ;; name convert since required editable property comment config + name (select-import inverse-import type convert-type) + #f #f #t #f last-comment #f) + attrs))) + ((parameter parameters ...) + (if (equal? (mojo-parameter-name parameter) name) + (cons (update-mojo-parameter-from-attrs + (make-mojo-parameter + name (select-import inverse-import type convert-type) + #f #f #t #f last-comment #f) + attrs) parameters) + (cons parameter (loop parameters))))))) + + (define (update-mojo-from-class-content mojo inverse-import content) + (let loop ((content content) + (mojo mojo) + (last-comment #f)) + (match content + ('() mojo) + ((('comment ('annotation-pat _ ...) last-comment) content ...) + (loop content mojo last-comment)) + ((('comment last-comment) content ...) + (loop content mojo last-comment)) + ((('param-pat ('annotation-pat annot-name attrs ...) ('type-name type) + ('param-name name)) content ...) + (cond + ((equal? annot-name "Parameter") + (loop content + (update-mojo mojo + #:parameters + (add-mojo-parameter + (mojo-parameters mojo) name type last-comment + attrs inverse-import)) + #f)) + ((equal? annot-name "Component") + (loop content + (update-mojo mojo + #:components + (cons (update-mojo-component-from-attrs + (make-mojo-component + name + (select-import inverse-import type + convert-type) + #f) + inverse-import + attrs) + (mojo-components mojo))) + #f)) + (else (throw 'not-found-annot annot-name)))) + ((('class-pat _ ...) content ...) + (loop content mojo #f)) + ((('param-pat _ ...) content ...) + (loop content mojo #f)) + ((('method-pat _ ...) content ...) + (loop content mojo #f))))) + + (define (update-inverse-import inverse-import package) + (let ((package-name (car (reverse (string-split package #\.))))) + (cons (cons package-name package) inverse-import))) + + (define (select-import inverse-import package convert-type) + (let* ((package (car (string-split package #\<))) + (package (string-split package #\.)) + (rest (reverse (cdr package))) + (rest (cond + ((null? rest) '()) + ((equal? (car rest) "class") (cdr rest)) + (else rest))) + (base (or (assoc-ref inverse-import (car package)) (car package)))) + (convert-type (string-join (cons base rest) ".")))) + + (let loop ((content parse-tree) + (mojo mojo) + (inverse-import '()) + (last-comment #f)) + (if (null? content) + mojo + (match content + ((tls content ...) + (match tls + (('package package) + (loop content (update-mojo mojo #:package package) inverse-import + last-comment)) + (('import-pat package) + (loop content mojo (update-inverse-import inverse-import package) + last-comment)) + (('comment last-comment) + (loop content mojo inverse-import last-comment)) + (('class-pat class-tls ...) + (let loop2 ((class-tls class-tls) (mojo mojo)) + (match class-tls + ('() (loop content mojo inverse-import #f)) + (((? string? name) class-tls ...) + (loop2 class-tls (update-mojo mojo #:name name))) + ((('annotation-pat annot-name (attrs ...)) class-tls ...) + (loop2 + class-tls + (update-mojo-from-attrs mojo attrs))) + ((('class-body class-content ...) class-tls ...) + (loop2 + class-tls + (update-mojo-from-class-content + mojo inverse-import class-content))) + ((_ class-tls ...) + (loop2 class-tls mojo))))) + (_ + (loop content mojo inverse-import last-comment)))))))) + +(define (generate-mojo-from-files convert-type . files) + (let ((mojo (make-mojo #f #f #f #f #f #f #f #f #f #f #f #f "per-lookup" + "once-per-session" #f #f #f '() '()))) + (let loop ((files files) (mojo mojo)) + (if (null? files) + (generate-mojo mojo) + (loop + (cdr files) + (update-mojo-from-file + (update-mojo mojo + #:package #f + #:name #f + #:goal #f + #:description #f + #:requires-dependency-resolution #f + #:requires-direct-invocation? #f + #:requires-project? #f + #:requires-reports? #f + #:aggregator? #f + #:requires-online? #f + #:inherited-by-default? #f + #:instantiation-strategy "per-lookup" + #:execution-strategy "once-per-session" + #:since #f + #:thread-safe? #f + #:phase #f) + (car files) + convert-type)))))) diff --git a/guix/build/maven/pom.scm b/guix/build/maven/pom.scm new file mode 100644 index 0000000000..aa60af2afa --- /dev/null +++ b/guix/build/maven/pom.scm @@ -0,0 +1,422 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019, 2020 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 maven pom) + #:use-module (sxml simple) + #:use-module (system foreign) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:export (get-pom + pom-ref + pom-description + pom-name + pom-version + pom-artifactid + pom-groupid + pom-dependencies + group->dir + fix-pom-dependencies)) + +(define (get-pom file) + "Return the content of a @file{.pom} file." + (let ((pom-content (call-with-input-file file xml->sxml))) + (match pom-content + (('*TOP* _ (_ ('@ _ ...) content ...)) + content) + (('*TOP* (_ ('@ _ ...) content ...)) + content) + (('*TOP* _ (_ content ...)) + content) + (('*TOP* (_ content ...)) + content)))) + +(define (pom-ref content attr) + "Gets a value associated to @var{attr} in @var{content}, an sxml value that +represents a @file{.pom} file content, or parts of it." + (or + (assoc-ref + content + (string->symbol + (string-append "http://maven.apache.org/POM/4.0.0:" attr))) + (assoc-ref content (string->symbol attr)))) + +(define (get-parent content) + (pom-ref content "parent")) + +(define* (find-parent content inputs #:optional local-packages) + "Find the parent pom for the pom file whith @var{content} in a package's +@var{inputs}. When the parent pom cannot be found in @var{inputs}, but +@var{local-packages} is defined, the parent pom is looked up in it. + +@var{local-packages} is an association list of groupID to an association list +of artifactID to version number. + +The result is an sxml document that describes the content of the parent pom, or +of an hypothetical parent pom if it was generated from @var{local-packages}. +If no result is found, the result is @code{#f}." + (let ((parent (pom-ref content "parent"))) + (if parent + (let* ((groupid (car (pom-ref parent "groupId"))) + (artifactid (car (pom-ref parent "artifactId"))) + (version (car (pom-ref parent "version"))) + (pom-file (string-append "lib/m2/" (group->dir groupid) + "/" artifactid "/" version "/" + artifactid "-" version ".pom")) + (java-inputs (filter + (lambda (input) + (file-exists? (string-append input "/" pom-file))) + inputs)) + (java-inputs (map (lambda (input) (string-append input "/" pom-file)) + java-inputs))) + (if (null? java-inputs) + (let ((version (assoc-ref (assoc-ref local-packages groupid) artifactid))) + (if version + `((groupId ,groupid) + (artifactId ,artifactid) + (version ,version)) + #f)) + (get-pom (car java-inputs)))) + #f))) + +(define* (pom-groupid content inputs #:optional local-packages) + "Find the groupID of a pom file, potentially looking at its parent pom file. +See @code{find-parent} for the meaning of the arguments." + (if content + (let ((res (or (pom-ref content "groupId") + (pom-groupid (find-parent content inputs local-packages) + inputs)))) + (cond + ((string? res) res) + ((null? res) #f) + ((list? res) (car res)) + (else #f))) + #f)) + +(define (pom-artifactid content) + "Find the artifactID of a pom file, from its sxml @var{content}." + (let ((res (pom-ref content "artifactId"))) + (if (and res (>= (length res) 1)) + (car res) + #f))) + +(define* (pom-version content inputs #:optional local-packages) + "Find the version of a pom file, potentially looking at its parent pom file. +See @code{find-parent} for the meaning of the arguments." + (if content + (let ((res (or (pom-ref content "version") + (pom-version (find-parent content inputs local-packages) + inputs)))) + (cond + ((string? res) res) + ((null? res) #f) + ((list? res) (car res)) + (else #f))) + #f)) + +(define (pom-name content) + "Return the name of the package as contained in the sxml @var{content} of the +pom file." + (let ((res (pom-ref content "name"))) + (if (and res (>= (length res) 1)) + (car res) + #f))) + +(define (pom-description content) + "Return the description of the package as contained in the sxml @var{content} +of the pom file." + (let ((res (pom-ref content "description"))) + (if (and res (>= (length res) 1)) + (car res) + #f))) + +(define (pom-dependencies content) + "Return the list of dependencies listed in the sxml @var{content} of the pom +file." + (filter + (lambda (a) a) + (map + (match-lambda + ((? string? _) #f) + (('http://maven.apache.org/POM/4.0.0:dependency content ...) + (let loop ((content content) (groupid #f) (artifactid #f) (version #f) (scope #f)) + (match content + ('() + `(dependency + (groupId ,groupid) + (artifactId ,artifactid) + (version ,version) + ,@(if scope `((scope ,scope)) '()))) + (((? string? _) content ...) + (loop content groupid artifactid version scope)) + ((('http://maven.apache.org/POM/4.0.0:scope scope) content ...) + (loop content groupid artifactid version scope)) + ((('http://maven.apache.org/POM/4.0.0:groupId groupid) content ...) + (loop content groupid artifactid version scope)) + ((('http://maven.apache.org/POM/4.0.0:artifactId artifactid) content ...) + (loop content groupid artifactid version scope)) + ((('http://maven.apache.org/POM/4.0.0:version version) content ...) + (loop content groupid artifactid version scope)) + ((_ content ...) + (loop content groupid artifactid version scope)))))) + (pom-ref content "dependencies")))) + +(define version-compare + (let ((strverscmp + (let ((sym (or (dynamic-func "strverscmp" (dynamic-link)) + (error "could not find `strverscmp' (from GNU libc)")))) + (pointer->procedure int sym (list '* '*))))) + (lambda (a b) + "Return '> when A denotes a newer version than B, +'< when A denotes a older version than B, +or '= when they denote equal versions." + (let ((result (strverscmp (string->pointer a) (string->pointer b)))) + (cond ((positive? result) '>) + ((negative? result) '<) + (else '=)))))) + +(define (version>? a b) + "Return #t when A denotes a version strictly newer than B." + (eq? '> (version-compare a b))) + +(define (fix-maven-xml sxml) + "When writing an xml file from an sxml representation, it is not possible to +use namespaces in tag names. This procedure takes an @var{sxml} representation +of a pom file and removes the namespace uses. It also adds the required bits +to re-declare the namespaces in the top-level element." + (define (fix-xml sxml) + (match sxml + ((tag ('@ opts ...) rest ...) + (if (> (string-length (symbol->string tag)) + (string-length "http://maven.apache.org/POM/4.0.0:")) + (let* ((tag (symbol->string tag)) + (tag (substring tag (string-length + "http://maven.apache.org/POM/4.0.0:"))) + (tag (string->symbol tag))) + `(,tag (@ ,@opts) ,@(map fix-xml rest))) + `(,tag (@ ,@opts) ,@(map fix-xml rest)))) + ((tag (rest ...)) + (if (> (string-length (symbol->string tag)) + (string-length "http://maven.apache.org/POM/4.0.0:")) + (let* ((tag (symbol->string tag)) + (tag (substring tag (string-length + "http://maven.apache.org/POM/4.0.0:"))) + (tag (string->symbol tag))) + `(,tag ,@(map fix-xml rest))) + `(,tag ,@(map fix-xml rest)))) + ((tag rest ...) + (if (> (string-length (symbol->string tag)) + (string-length "http://maven.apache.org/POM/4.0.0:")) + (let* ((tag (symbol->string tag)) + (tag (substring tag (string-length + "http://maven.apache.org/POM/4.0.0:"))) + (tag (string->symbol tag))) + `(,tag ,@(map fix-xml rest))) + `(,tag ,@(map fix-xml rest)))) + (_ sxml))) + + `((*TOP* (*PI* xml "version=\"1.0\" encoding=\"UTF-8\"") + (project (@ (xmlns "http://maven.apache.org/POM/4.0.0") + (xmlns:xsi "http://www.w3.org/2001/XMLSchema-instance") + (xmlns:schemaLocation "http://maven.apache.org/POM/4.0.0 + http://maven.apache.org/xsd/maven-4.0.0.xsd")) + ,(map fix-xml sxml))))) + +(define (group->dir group) + "Convert a group ID to a directory path." + (string-join (string-split group #\.) "/")) + +(define* (fix-pom-dependencies pom-file inputs + #:key with-plugins? with-build-dependencies? + (excludes '()) (local-packages '())) + "Open @var{pom-file}, and override its content, rewritting its dependencies +to set their version to the latest version available in the @var{inputs}. + +@var{#:with-plugins?} controls whether plugins are also overiden. +@var{#:with-build-dependencies?} controls whether build dependencies (whose +scope is not empty) are also overiden. By default build dependencies and +plugins are not overiden. + +@var{#:excludes} is an association list of groupID to a list of artifactIDs. +When a pair (groupID, artifactID) is present in the list, its entry is +removed instead of being overiden. If the entry is ignored because of the +previous arguments, the entry is not removed. + +@var{#:local-packages} is an association list that contains additional version +information for packages that are not in @var{inputs}. If the package is +not found in @var{inputs}, information from this list is used instead to determine +the latest version of the package. This is an association list of group IDs +to another association list of artifact IDs to a version number. + +Returns nothing, but overides the @var{pom-file} as a side-effect." + (define pom (get-pom pom-file)) + + (define (ls dir) + (let ((dir (opendir dir))) + (let loop ((res '())) + (let ((entry (readdir dir))) + (if (eof-object? entry) + res + (loop (cons entry res))))))) + + (define fix-pom + (match-lambda + ('() '()) + ((tag rest ...) + (match tag + (('http://maven.apache.org/POM/4.0.0:dependencies deps ...) + `((http://maven.apache.org/POM/4.0.0:dependencies ,(fix-deps deps)) + ,@(fix-pom rest))) + (('http://maven.apache.org/POM/4.0.0:dependencyManagement deps ...) + `((http://maven.apache.org/POM/4.0.0:dependencyManagement + ,(fix-dep-management deps)) + ,@(fix-pom rest))) + (('http://maven.apache.org/POM/4.0.0:build build ...) + (if with-plugins? + `((http://maven.apache.org/POM/4.0.0:build ,(fix-build build)) + ,@(fix-pom rest)) + (cons tag (fix-pom rest)))) + (tag (cons tag (fix-pom rest))))))) + + (define fix-dep-management + (match-lambda + ('() '()) + ((tag rest ...) + (match tag + (('http://maven.apache.org/POM/4.0.0:dependencies deps ...) + `((http://maven.apache.org/POM/4.0.0:dependencies ,(fix-deps deps #t)) + ,@(fix-dep-management rest))) + (tag (cons tag (fix-dep-management rest))))))) + + (define* (fix-deps deps #:optional optional?) + (match deps + ('() '()) + ((tag rest ...) + (match tag + (('http://maven.apache.org/POM/4.0.0:dependency dep ...) + `((http://maven.apache.org/POM/4.0.0:dependency ,(fix-dep dep optional?)) + ,@(fix-deps rest optional?))) + (tag (cons tag (fix-deps rest optional?))))))) + + (define fix-build + (match-lambda + ('() '()) + ((tag rest ...) + (match tag + (('http://maven.apache.org/POM/4.0.0:pluginManagement management ...) + `((http://maven.apache.org/POM/4.0.0:pluginManagement + ,(fix-management management)) + ,@(fix-build rest))) + (('http://maven.apache.org/POM/4.0.0:plugins plugins ...) + `((http://maven.apache.org/POM/4.0.0:plugins + ,(fix-plugins plugins)) + ,@(fix-build rest))) + (tag (cons tag (fix-build rest))))))) + + (define fix-management + (match-lambda + ('() '()) + ((tag rest ...) + (match tag + (('http://maven.apache.org/POM/4.0.0:plugins plugins ...) + `((http://maven.apache.org/POM/4.0.0:plugins + ,(fix-plugins plugins #t)) + ,@(fix-management rest))) + (tag (cons tag (fix-management rest))))))) + + (define* (fix-plugins plugins #:optional optional?) + (match plugins + ('() '()) + ((tag rest ...) + (match tag + (('http://maven.apache.org/POM/4.0.0:plugin plugin ...) + (let ((group (or (pom-groupid plugin inputs) "org.apache.maven.plugins")) + (artifact (pom-artifactid plugin))) + (if (member artifact (or (assoc-ref excludes group) '())) + (fix-plugins rest optional?) + `((http://maven.apache.org/POM/4.0.0:plugin + ,(fix-plugin plugin optional?)) + ,@(fix-plugins rest optional?))))) + (tag (cons tag (fix-plugins rest optional?))))))) + + (define* (fix-plugin plugin #:optional optional?) + (let* ((artifact (pom-artifactid plugin)) + (group (or (pom-groupid plugin inputs) "org.apache.maven.plugins")) + (version (or (assoc-ref (assoc-ref local-packages group) artifact) + (find-version inputs group artifact optional?) + (pom-version plugin inputs)))) + (if (pom-version plugin inputs) + (map + (lambda (tag) + (match tag + (('http://maven.apache.org/POM/4.0.0:version _) + `(http://maven.apache.org/POM/4.0.0:version ,version)) + (('version _) + `(http://maven.apache.org/POM/4.0.0:version ,version)) + (tag tag))) + plugin) + (cons `(http://maven.apache.org/POM/4.0.0:version ,version) plugin)))) + + (define* (fix-dep dep #:optional optional?) + (let* ((artifact (pom-artifactid dep)) + (group (or (pom-groupid dep inputs) (pom-groupid pom inputs))) + (scope (pom-ref dep "scope")) + (is-optional? (equal? (pom-ref dep "optional") '("true")))) + (format (current-error-port) "maven: ~a:~a :: ~a (optional: ~a)~%" + group artifact scope optional?) + (if (or (and (not (equal? scope '("test"))) (not is-optional?)) + with-build-dependencies?) + (let ((version (or (assoc-ref (assoc-ref local-packages group) artifact) + (find-version inputs group artifact optional?) + (pom-version dep inputs)))) + (if (pom-version dep inputs) + (map + (lambda (tag) + (match tag + (('http://maven.apache.org/POM/4.0.0:version _) + `(http://maven.apache.org/POM/4.0.0:version ,version)) + (('version _) + `(http://maven.apache.org/POM/4.0.0:version ,version)) + (_ tag))) + dep) + (cons `(http://maven.apache.org/POM/4.0.0:version ,version) dep))) + dep))) + + (define* (find-version inputs group artifact #:optional optional?) + (let* ((directory (string-append "lib/m2/" (group->dir group) + "/" artifact)) + (java-inputs (filter + (lambda (input) + (file-exists? (string-append input "/" directory))) + inputs)) + (java-inputs (map (lambda (input) (string-append input "/" directory)) + java-inputs)) + (versions (append-map ls java-inputs)) + (versions (sort versions version>?))) + (if (null? versions) + (if optional? + #f + (begin + (format (current-error-port) "maven: ~a:~a is missing from inputs~%" + group artifact) + (throw 'no-such-input group artifact))) + (car versions)))) + + (let ((tmpfile (string-append pom-file ".tmp"))) + (with-output-to-file pom-file + (lambda _ + (sxml->xml (fix-maven-xml (fix-pom pom))))))) |