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.
This commit is contained in:
Julien Lepiller
parent
5654eef7e9
commit
3d3bc413b4
|
|
@ -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 \
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)))))))))
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
@ -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))))))
|
||||
|
|
@ -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)))))))
|
||||
Loading…
Reference in New Issue