[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
01/110: guix: java-utils: Add Maven-related phases.
|
From: |
guix-commits |
|
Subject: |
01/110: guix: java-utils: Add Maven-related phases. |
|
Date: |
Thu, 16 Jul 2020 22:23:09 -0400 (EDT) |
roptat pushed a commit to branch master
in repository guix.
commit 3d3bc413b4288fbf45a61fb2136387878375ebef
Author: Julien Lepiller <julien@lepiller.eu>
AuthorDate: Sun Apr 5 19:54:29 2020 +0200
guix: java-utils: Add Maven-related phases.
* guix/build/maven/java.scm: New file.
* guix/build/maven/plugin.scm: New file.
* guix/build/maven/pom.scm: New file.
* Makefile.am (MODULES): Add them.
* guix/build-system/ant.scm (%ant-build-system-modules): Add them to the
build side.
* guix/build/java-utils.scm (generate-plugin.xml, install-pom-file)
(install-from-pom): New procedures.
---
Makefile.am | 3 +
guix/build-system/ant.scm | 3 +
guix/build/java-utils.scm | 159 +++++++++++++-
guix/build/maven/java.scm | 147 +++++++++++++
guix/build/maven/plugin.scm | 498 ++++++++++++++++++++++++++++++++++++++++++++
guix/build/maven/pom.scm | 422 +++++++++++++++++++++++++++++++++++++
6 files changed, 1231 insertions(+), 1 deletion(-)
diff --git a/Makefile.am b/Makefile.am
index 20d43cd..c067e37 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 b5626bd..1809d1f 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 8200638..a868e4d 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 0000000..daa4c88
--- /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 0000000..13148ab
--- /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 0000000..aa60af2
--- /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)))))))
- branch master updated (5654eef -> 55b90c9), guix-commits, 2020/07/16
- 02/110: gnu: java-asm: Remove dependency on bnd libraries., guix-commits, 2020/07/16
- 03/110: gnu: Add java-hamcrest-library., guix-commits, 2020/07/16
- 01/110: guix: java-utils: Add Maven-related phases.,
guix-commits <=
- 04/110: gnu: java-junit: Enable tests., guix-commits, 2020/07/16
- 05/110: gnu: java-jarjar: unbundle maven-plugin-api., guix-commits, 2020/07/16
- 06/110: gnu: java-junit: Install from pom file., guix-commits, 2020/07/16
- 07/110: gnu: Add apache-parent-pom-13., guix-commits, 2020/07/16
- 10/110: gnu: Add apache-parent-pom-16., guix-commits, 2020/07/16
- 12/110: gnu: Add apache-parent-pom-18., guix-commits, 2020/07/16
- 13/110: gnu: Add apache-parent-pom-19., guix-commits, 2020/07/16
- 14/110: gnu: Add apache-parent-pom-21., guix-commits, 2020/07/16
- 08/110: gnu: Add apache-parent-pom-6., guix-commits, 2020/07/16
- 17/110: gnu: Add apache-commons-parent-pom-48., guix-commits, 2020/07/16