Merge branch 'master' into staging

7 files changed, 1398 insertions, 7 deletions

diff --git a/guix/build/download-nar.scm b/guix/build/download-nar.scm
index cb146038ad..377e428341 100644
--- a/guix/build/download-nar.scm
+++ b/guix/build/download-nar.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -19,7 +19,7 @@
 (define-module (guix build download-nar)
   #:use-module (guix build download)
   #:use-module (guix build utils)
-  #:use-module (guix serialization)
+  #:use-module ((guix serialization) #:hide (dump-port*))
   #:use-module (guix zlib)
   #:use-module (guix progress)
   #:use-module (web uri)
@@ -42,10 +42,10 @@
   "Return the fallback nar URL for ITEM--e.g.,
 \"/gnu/store/cabbag3…-foo-1.2-checkout\"."
   ;; Here we hard-code nar URLs without checking narinfos.  That's probably OK
-  ;; though.  Use berlin.guixsd.org instead of its ci.guix.gnu.org front end to
+  ;; though.  Use berlin.guix.gnu.org instead of its ci.guix.gnu.org front end to
   ;; avoid sending these requests to CDN providers without user consent.
   ;; TODO: Use HTTPS?  The downside is the extra dependency.
-  (let ((bases '("http://berlin.guixsd.org"))
+  (let ((bases '("http://berlin.guix.gnu.org"))
         (item  (basename item)))
     (append (map (cut string-append <> "/nar/gzip/" item) bases)
             (map (cut string-append <> "/nar/" item) bases))))
diff --git a/guix/build/java-utils.scm b/guix/build/java-utils.scm
index 8200638bee..a868e4d52c 100644
--- a/guix/build/java-utils.scm
+++ b/guix/build/java-utils.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
 ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2018 Alex Vong <alexvong1995@gmail.com>
+;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -20,9 +21,17 @@
 
 (define-module (guix build java-utils)
   #:use-module (guix build utils)
+  #:use-module (guix build syscalls)
+  #:use-module (guix build maven pom)
+  #:use-module (guix build maven plugin)
+  #:use-module (ice-9 match)
+  #:use-module (sxml simple)
   #:export (ant-build-javadoc
+            generate-plugin.xml
             install-jars
-            install-javadoc))
+            install-javadoc
+            install-pom-file
+            install-from-pom))
 
 (define* (ant-build-javadoc #:key (target "javadoc") (make-flags '())
                             #:allow-other-keys)
@@ -49,3 +58,151 @@ install javadocs when this is not done by the install target."
       (mkdir-p docs)
       (copy-recursively apidoc-directory docs)
       #t)))
+
+(define* (install-pom-file pom-file)
+  "Install a @file{.pom} file to a maven repository structure in @file{lib/m2}
+that respects the file's artifact ID and group ID.  This requires the parent
+pom, if any, to be present in the inputs so some of this information can be
+fetched."
+  (lambda* (#:key inputs outputs #:allow-other-keys)
+    (let* ((out (assoc-ref outputs "out"))
+           (java-inputs (append (map cdr inputs) (map cdr outputs)))
+           (pom-content (get-pom pom-file))
+           (version (pom-version pom-content java-inputs))
+           (artifact (pom-artifactid pom-content))
+           (group (group->dir (pom-groupid pom-content java-inputs)))
+           (repository (string-append out "/lib/m2/" group "/" artifact "/"
+                                      version "/"))
+           (pom-name (string-append repository artifact "-" version ".pom")))
+      (mkdir-p (dirname pom-name))
+      (copy-file pom-file pom-name))
+    #t))
+
+(define (install-jar-file-with-pom jar pom-file inputs)
+  "Unpack the jar archive, add the pom file, and repack it.  This is necessary
+to ensure that maven can find dependencies."
+  (format #t "adding ~a to ~a\n" pom-file jar)
+  (let* ((dir (mkdtemp! "jar-contents.XXXXXX"))
+         (manifest (string-append dir "/META-INF/MANIFEST.MF"))
+         (pom (get-pom pom-file))
+         (artifact (pom-artifactid pom))
+         (group (pom-groupid pom inputs))
+         (version (pom-version pom inputs))
+         (pom-dir (string-append "META-INF/maven/" group "/" artifact)))
+    (mkdir-p (string-append dir "/" pom-dir))
+    (copy-file pom-file (string-append dir "/" pom-dir "/pom.xml"))
+    (with-directory-excursion dir
+      (with-output-to-file (string-append pom-dir "/pom.properties")
+        (lambda _
+          (format #t "version=~a~%" version)
+          (format #t "groupId=~a~%" group)
+          (format #t "artifactId=~a~%" artifact)))
+      (invoke "jar" "uf" jar (string-append pom-dir "/pom.xml")
+              (string-append pom-dir "/pom.properties")))
+    #t))
+
+(define* (install-from-pom pom-file)
+  "Install a jar archive and its @var{pom-file} to a maven repository structure
+in @file{lib/m2}.  This requires the parent pom file, if any, to be present in
+the inputs of the package being built.  This phase looks either for a properly
+named jar file (@file{artifactID-version.jar}) or the single jar in the build
+directory.  If there are more than one jar, and none is named appropriately,
+the phase fails."
+  (lambda* (#:key inputs outputs jar-name #:allow-other-keys)
+    (let* ((out (assoc-ref outputs "out"))
+           (java-inputs (append (map cdr inputs) (map cdr outputs)))
+           (pom-content (get-pom pom-file))
+           (version (pom-version pom-content java-inputs))
+           (artifact (pom-artifactid pom-content))
+           (group (group->dir (pom-groupid pom-content java-inputs)))
+           (repository (string-append out "/lib/m2/" group "/" artifact "/"
+                                      version "/"))
+           ;; We try to find the file that was built.  If it was built from our
+           ;; generated ant.xml file, it is name jar-name, otherwise it should
+           ;; have the expected name for maven.
+           (jars (find-files "." (or jar-name (string-append artifact "-"
+                                                             version ".jar"))))
+           ;; Otherwise, we try to find any jar file.
+           (jars (if (null? jars)
+                     (find-files "." ".*.jar")
+                     jars))
+           (jar-name (string-append repository artifact "-" version ".jar"))
+           (pom-name (string-append repository artifact "-" version ".pom")))
+      ;; Ensure we can override the file
+      (chmod pom-file #o644)
+      (fix-pom-dependencies pom-file java-inputs)
+      (mkdir-p (dirname jar-name))
+      (copy-file pom-file pom-name)
+      ;; If there are too many jar files, we don't know which one to install, so
+      ;; fail.
+      (if (= (length jars) 1)
+          (begin
+            (copy-file (car jars) jar-name)
+            (install-jar-file-with-pom jar-name pom-file java-inputs))
+          (throw 'no-jars jars)))
+    #t))
+
+(define (sxml-indent sxml)
+  "Adds some indentation to @var{sxml}, an sxml value, to make reviewing easier
+after the value is written to an xml file."
+  (define (sxml-indent-aux sxml lvl)
+    (match sxml
+      ((? string? str) str)
+      ((tag ('@ attr ...) content ...)
+       (cond
+         ((null? content) sxml)
+         ((string? (car content)) sxml)
+         (else
+           `(,tag (@ ,@attr) ,(sxml-indent-content content (+ lvl 1))))))
+      ((tag content ...)
+       (cond
+         ((null? content) sxml)
+         ((string? (car content)) sxml)
+         (else `(,tag ,(sxml-indent-content content (+ lvl 1))))))
+      (_ sxml)))
+  (define (sxml-indent-content sxml lvl)
+    (map
+      (lambda (sxml)
+        (list "\n" (string-join (make-list (* 2 lvl) " ") "")
+              (sxml-indent-aux sxml lvl)))
+      sxml))
+  (sxml-indent-aux sxml 0))
+
+(define* (generate-plugin.xml pom-file goal-prefix directory source-groups
+                              #:key
+                              (plugin.xml "build/classes/META-INF/maven/plugin.xml"))
+  "Generates the @file{plugin.xml} file that is required by Maven so it can
+recognize the package as a plugin, and find the entry points in the plugin."
+  (lambda* (#:key inputs outputs #:allow-other-keys)
+    (let* ((pom-content (get-pom pom-file))
+           (java-inputs (append (map cdr inputs) (map cdr outputs)))
+           (name (pom-name pom-content))
+           (description (pom-description pom-content))
+           (dependencies (pom-dependencies pom-content))
+           (version (pom-version pom-content java-inputs))
+           (artifact (pom-artifactid pom-content))
+           (groupid (pom-groupid pom-content java-inputs))
+           (mojos
+            `(mojos
+               ,@(with-directory-excursion directory
+                   (map
+                     (lambda (group)
+                       (apply generate-mojo-from-files maven-convert-type group))
+                     source-groups)))))
+      (mkdir-p (dirname plugin.xml))
+      (with-output-to-file plugin.xml
+        (lambda _
+          (sxml->xml
+            (sxml-indent
+              `(plugin
+                 (name ,name)
+                 (description ,description)
+                 (groupId ,groupid)
+                 (artifactId ,artifact)
+                 (version ,version)
+                 (goalPrefix ,goal-prefix)
+                 (isolatedRealm "false")
+                 (inheritedByDefault "true")
+                 ,mojos
+                 (dependencies
+                  ,@dependencies)))))))))
diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm
index 5bb3d81c9e..f6d9168c48 100644
--- a/guix/build/lisp-utils.scm
+++ b/guix/build/lisp-utils.scm
@@ -327,8 +327,12 @@ system to find its dependencies, as described by GENERATE-DEPENDENCY-LINKS."
                  #:version version
                  #:dependencies dependencies
                  ;; Some .asd don't have components, and thus they don't generate any .fasl.
-                 #:component? (pair?
-                               (find-files (dirname asd-file) "--system\\.fasl$")))
+                 #:component? (match (%lisp-type)
+                                ("sbcl" (pair? (find-files (dirname asd-file)
+                                                           "--system\\.fasl$")))
+                                ("ecl" (pair? (find-files (dirname asd-file)
+                                                          "\\.fasb$")))
+                                (_ (error "The LISP provided is not supported at this time."))))
                 (generate-dependency-links registry system)))
        port))))
 
diff --git a/guix/build/maven-build-system.scm b/guix/build/maven-build-system.scm
new file mode 100644
index 0000000000..914298d584
--- /dev/null
+++ b/guix/build/maven-build-system.scm
@@ -0,0 +1,163 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 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-build-system)
+  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
+  #:use-module (guix build utils)
+  #:use-module (guix build maven pom)
+  #:use-module (ice-9 match)
+  #:export (%standard-phases
+            maven-build))
+
+;; Commentary:
+;;
+;; Builder-side code of the standard maven build procedure.
+;;
+;; Code:
+
+(define* (set-home #:key outputs inputs #:allow-other-keys)
+  (let ((home (string-append (getcwd) "/build-home")))
+    (setenv "HOME" home))
+  (setenv "JAVA_HOME" (assoc-ref inputs "jdk"))
+  #t)
+
+(define* (configure #:key inputs #:allow-other-keys)
+  (let* ((m2-files (map
+                     (lambda (input)
+                       (match input
+                         ((name . dir)
+                          (let ((m2-dir (string-append dir "/lib/m2")))
+                            (if (file-exists? m2-dir) m2-dir #f)))))
+                     inputs))
+         (m2-files (filter (lambda (a) a) m2-files)))
+    (for-each
+      (lambda (m2-dir)
+        (for-each
+          (lambda (file)
+            (let ((dir (string-append (getenv "HOME") "/.m2/repository/"
+                                      (dirname file))))
+              (mkdir-p dir)
+              (symlink (string-append m2-dir "/" file)
+                       (string-append dir "/" (basename file)))))
+          (with-directory-excursion m2-dir
+            (find-files "." ".*.(jar|pom)$"))))
+      m2-files))
+  (invoke "mvn" "-v")
+  #t)
+
+(define (add-local-package local-packages group artifact version)
+  (define (alist-set lst key val)
+    (match lst
+      ('() (list (cons key val)))
+      (((k . v) lst ...)
+       (if (equal? k key)
+         (cons (cons key val) lst)
+         (cons (cons k v) (alist-set lst key val))))))
+  (alist-set local-packages group
+    (alist-set (or (assoc-ref local-packages group) '()) artifact
+      version)))
+
+(define (fix-pom pom-file inputs local-packages excludes)
+  (chmod pom-file #o644)
+  (format #t "fixing ~a~%" pom-file)
+  (fix-pom-dependencies pom-file (map cdr inputs)
+                        #:with-plugins? #t #:with-build-dependencies? #t
+                        #:local-packages local-packages
+                        #:excludes excludes)
+  (let* ((pom (get-pom pom-file))
+         (java-inputs (map cdr inputs))
+         (artifact (pom-artifactid pom))
+         (group (pom-groupid pom java-inputs local-packages))
+         (version (pom-version pom java-inputs local-packages)))
+    (let loop ((modules (pom-ref pom "modules"))
+               (local-packages
+                 (add-local-package local-packages group artifact version)))
+      (pk 'local-packages local-packages)
+      (match modules
+        (#f local-packages)
+        ('() local-packages)
+        (((? string? _) modules ...)
+         (loop modules local-packages))
+        (((_ module) modules ...)
+         (loop
+           modules
+           (fix-pom (string-append (dirname pom-file) "/" module "/pom.xml")
+                    inputs local-packages excludes)))))))
+
+(define* (fix-pom-files #:key inputs local-packages exclude #:allow-other-keys)
+  (fix-pom "pom.xml" inputs local-packages exclude))
+
+(define* (build #:key outputs #:allow-other-keys)
+  "Build the given package."
+  (invoke "mvn" "package"
+          ;; offline mode: don't download dependencies
+          "-o"
+          ;, set directory where dependencies are installed
+          (string-append "-Duser.home=" (getenv "HOME")))
+  #t)
+
+(define* (check #:key tests? #:allow-other-keys)
+  "Check the given package."
+  (when tests?
+    (invoke "mvn" "test"
+            (string-append "-Duser.home=" (getenv "HOME"))
+            "-e"))
+  #t)
+
+(define* (install #:key outputs #:allow-other-keys)
+  "Install the given package."
+  (let* ((out (assoc-ref outputs "out"))
+         (java (string-append out "/lib/m2")))
+    (invoke "mvn" "install" "-o" "-e"
+            "-DskipTests"
+            (string-append "-Duser.home=" (getenv "HOME")))
+    ;; Go through the repository to find files that can be installed
+    (with-directory-excursion (string-append (getenv "HOME") "/.m2/repository")
+      (let ((installable
+              (filter (lambda (file)
+                        (not (eq? 'symlink (stat:type (lstat file)))))
+                      (find-files "." "."))))
+        (mkdir-p java)
+        (for-each
+          (lambda (file)
+            (mkdir-p (string-append java "/" (dirname file)))
+            (copy-file file (string-append java "/" file)))
+          installable)))
+    ;; Remove some files that are not required and introduce timestamps
+    (for-each delete-file (find-files out "maven-metadata-local.xml"))
+    (for-each delete-file (find-files out "_remote.repositories")))
+  #t)
+
+(define %standard-phases
+  ;; Everything is as with the GNU Build System except for the `configure'
+  ;; , `build', `check' and `install' phases.
+  (modify-phases gnu:%standard-phases
+    (delete 'bootstrap)
+    (add-before 'configure 'set-home set-home)
+    (replace 'configure configure)
+    (add-after 'configure 'fix-pom-files fix-pom-files)
+    (replace 'build build)
+    (replace 'check check)
+    (replace 'install install)))
+
+(define* (maven-build #:key inputs (phases %standard-phases)
+                      #:allow-other-keys #:rest args)
+  "Build the given package, applying all of PHASES in order."
+  (apply gnu:gnu-build #:inputs inputs #:phases phases args))
+
+;;; maven-build-system.scm ends here
diff --git a/guix/build/maven/java.scm b/guix/build/maven/java.scm
new file mode 100644
index 0000000000..daa4c88045
--- /dev/null
+++ b/guix/build/maven/java.scm
@@ -0,0 +1,147 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019, 2020 Julien Lepiller <julien@lepiller.eu>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build maven java)
+  #:use-module (ice-9 peg)
+  #:use-module (ice-9 textual-ports)
+  #:export (parse-java-file))
+
+(define-peg-pattern java-file body (and (* WS) (* (and top-level-statement
+                                                       (* WS)))))
+(define-peg-pattern WS none (or " " "\n" "\t" "\r"))
+(define-peg-pattern top-level-statement body (or package import-pat class-pat comment inline-comment))
+(define-peg-pattern package all (and (ignore "package") (* WS) package-name
+                                     (* WS) (ignore ";")))
+(define-peg-pattern import-pat all (and (ignore "import") (* WS)
+                                        (? (and (ignore "static") (* WS)))
+                                        package-name
+                                        (* WS) (ignore ";")))
+(define-peg-pattern comment all (and (? (and annotation-pat (* WS))) (ignore "/*")
+                                     comment-part))
+(define-peg-pattern comment-part body (or (ignore (and (* "*") "/"))
+                                          (and (* "*") (+ comment-chr) comment-part)))
+(define-peg-pattern comment-chr body (or "\t" "\n" (range #\ #\)) (range #\+ #\xffff)))
+(define-peg-pattern inline-comment none (and (ignore "//") (* inline-comment-chr)
+                                            (ignore "\n")))
+(define-peg-pattern inline-comment-chr body (range #\ #\xffff))
+(define-peg-pattern package-name body (* (or (range #\a #\z) (range #\A #\Z)
+                                             (range #\0 #\9) "_" ".")))
+(define-peg-pattern class-pat all (and (? (and annotation-pat (* WS)))
+                                       (* (ignore (or inline-comment comment)))
+                                       (? (and (ignore "private") (* WS)))
+                                       (? (and (ignore "public") (* WS)))
+                                       (? (and (ignore "static") (* WS)))
+                                       (? (and (ignore "final") (* WS)))
+                                       (? (and (ignore "abstract") (* WS)))
+                                       (ignore "class")
+                                       (* WS) package-name (* WS)
+                                       (? extends)
+                                       (? implements)
+                                       (ignore "{") class-body (ignore "}")))
+(define-peg-pattern extends all (? (and (ignore "extends") (* WS)
+                                        package-name (* WS))))
+(define-peg-pattern implements all (? (and (ignore "implements") (* WS)
+                                           package-name (* WS))))
+(define-peg-pattern annotation-pat all (and (ignore "@") package-name
+                                            (? (and
+                                                 (* WS)
+                                                 (ignore "(") (* WS)
+                                                 annotation-attr (* WS)
+                                                 (* (and (ignore ",") (* WS)
+                                                         annotation-attr (* WS)))
+                                                 (ignore ")")))))
+(define-peg-pattern annotation-attr all (or (and attr-name (* WS) (ignore "=")
+                                                 (* WS) attr-value (* WS))
+                                            attr-value))
+(define-peg-pattern attr-name all (* (or (range #\a #\z) (range #\A #\Z) (range #\0 #\9)
+                                         "_")))
+(define-peg-pattern attr-value all (or "true" "false"
+                                       (+ (or (range #\0 #\9) (range #\a #\z)
+                                              (range #\A #\Z) "." "_"))
+                                       array-pat
+                                       string-pat))
+(define-peg-pattern array-pat body
+  (and (ignore "{") (* WS) value
+       (* (and (* WS) "," (* WS) value))
+       (* WS) (ignore "}")))
+(define-peg-pattern string-pat body (and (ignore "\"") (* string-chr) (ignore "\"")))
+(define-peg-pattern string-chr body (or " " "!" (and (ignore "\\") "\"")
+                                        (and (ignore "\\") "\\") (range #\# #\xffff)))
+
+(define-peg-pattern class-body all (and (* WS) (* (and class-statement (* WS)))))
+(define-peg-pattern class-statement body (or inline-comment comment param-pat
+                                             method-pat class-pat))
+(define-peg-pattern param-pat all (and (* (and annotation-pat (* WS)
+                                               (? (ignore inline-comment))
+                                               (* WS)))
+                                       (? (and (ignore (or "private" "public"
+                                                           "protected"))
+                                               (* WS)))
+                                       (? (and (ignore "static") (* WS)))
+                                       (? (and (ignore "volatile") (* WS)))
+                                       (? (and (ignore "final") (* WS)))
+                                       type-name (* WS) param-name
+                                       (? (and (* WS) (ignore "=") (* WS) value))
+                                       (ignore ";")))
+(define-peg-pattern value none (or string-pat (+ valuechr)))
+(define-peg-pattern valuechr none (or comment inline-comment "\n"
+                                      "\t" "\r"
+                                      (range #\  #\:) (range #\< #\xffff)))
+(define-peg-pattern param-name all (* (or (range #\a #\z) (range #\A #\Z) (range #\0 #\9)
+                                          "_")))
+(define-peg-pattern type-name all type-pat)
+(define-peg-pattern type-pat body
+  (or "?"
+      (and (* (or (range #\a #\z) (range #\A #\Z) (range #\0 #\9) "_"))
+           (? "...")
+           (? "[]")
+           (? type-param))))
+(define-peg-pattern type-param body (and "<" (? type-pat)
+                                         (* (and (* WS) "," (* WS) type-pat))
+                                         (* WS) ">"))
+(define-peg-pattern method-pat all (and (* (and annotation-pat (* WS)))
+                                        (? (and (ignore (or "private" "public" "protected"))
+                                                (* WS)))
+                                        (? (and (ignore type-param) (* WS)))
+                                        (? (and (ignore (or "abstract" "final"))
+                                                (* WS)))
+                                        (? (and (ignore "static") (* WS)))
+                                        type-name (* WS) param-name (* WS)
+                                        (ignore "(")
+                                        param-list (ignore ")") (* WS)
+                                        (? (and (ignore "throws") (* WS) package-name (* WS)
+                                                (* (and (ignore ",") (* WS) package-name
+                                                        (* WS)))))
+                                        (or (ignore ";")
+                                            (and (ignore "{") (* WS)
+                                                 (? (and method-statements (* WS)))
+                                            (ignore "}")))))
+(define-peg-pattern param-list all (and (* WS) (* (and (? annotation-pat) (* WS)
+                                                       type-name (* WS)
+                                                       param-name (* WS)
+                                                       (? (ignore ",")) (* WS)))))
+(define-peg-pattern method-statements none (and (or (+ method-chr)
+                                                    (and "{" method-statements "}")
+                                                    string-pat)
+                                                (? method-statements)))
+(define-peg-pattern method-chr none (or "\t" "\n" "\r" " " "!" (range #\# #\z) "|"
+                                        (range #\~ #\xffff)))
+
+
+(define (parse-java-file file)
+  (peg:tree (match-pattern java-file (call-with-input-file file get-string-all))))
diff --git a/guix/build/maven/plugin.scm b/guix/build/maven/plugin.scm
new file mode 100644
index 0000000000..13148ab53c
--- /dev/null
+++ b/guix/build/maven/plugin.scm
@@ -0,0 +1,498 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019, 2020 Julien Lepiller <julien@lepiller.eu>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build maven plugin)
+  #:use-module (guix build maven java)
+  #:use-module (ice-9 textual-ports)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-9)
+  #:export (generate-mojo-from-files
+	    default-convert-type
+	    maven-convert-type))
+
+(define-record-type mojo
+  (make-mojo package name goal description requires-dependency-collection
+             requires-dependency-resolution requires-direct-invocation?
+             requires-project? requires-reports? aggregator? requires-online?
+             inherited-by-default?  instantiation-strategy execution-strategy
+             since thread-safe? phase parameters components)
+  mojo?
+  (package mojo-package)
+  (name mojo-name)
+  (goal mojo-goal)
+  (description mojo-description)
+  (requires-dependency-collection mojo-requires-dependency-collection)
+  (requires-dependency-resolution mojo-requires-dependency-resolution)
+  (requires-direct-invocation? mojo-requires-direct-invocation?)
+  (requires-project? mojo-requires-project?)
+  (requires-reports? mojo-requires-reports?)
+  (aggregator? mojo-aggregator?)
+  (requires-online? mojo-requires-online?)
+  (inherited-by-default? mojo-inherited-by-default?)
+  (instantiation-strategy mojo-instantiation-strategy)
+  (execution-strategy mojo-execution-strategy)
+  (since mojo-since)
+  (thread-safe? mojo-thread-safe?)
+  (phase mojo-phase)
+  (parameters mojo-parameters)
+  (components mojo-components))
+
+(define* (update-mojo mojo
+           #:key
+           (package (mojo-package mojo))
+           (name (mojo-name mojo))
+           (goal (mojo-goal mojo))
+           (description (mojo-description mojo))
+           (requires-dependency-collection (mojo-requires-dependency-collection mojo))
+           (requires-dependency-resolution (mojo-requires-dependency-resolution mojo))
+           (requires-direct-invocation? (mojo-requires-direct-invocation? mojo))
+           (requires-project? (mojo-requires-project? mojo))
+           (requires-reports? (mojo-requires-reports? mojo))
+           (aggregator? (mojo-aggregator? mojo))
+           (requires-online? (mojo-requires-online? mojo))
+           (inherited-by-default? (mojo-inherited-by-default? mojo))
+           (instantiation-strategy (mojo-instantiation-strategy mojo))
+           (execution-strategy (mojo-execution-strategy mojo))
+           (since (mojo-since mojo))
+           (thread-safe? (mojo-thread-safe? mojo))
+           (phase (mojo-phase mojo))
+           (parameters (mojo-parameters mojo))
+           (components (mojo-components mojo)))
+  (make-mojo package name goal description requires-dependency-collection
+             requires-dependency-resolution requires-direct-invocation?
+             requires-project? requires-reports? aggregator? requires-online?
+             inherited-by-default? instantiation-strategy execution-strategy
+             since thread-safe? phase parameters components))
+
+(define-record-type mojo-parameter
+  (make-mojo-parameter name type since required editable property description
+                       configuration)
+  mojo-parameter?
+  (name          mojo-parameter-name)
+  (type          mojo-parameter-type)
+  (since         mojo-parameter-since)
+  (required      mojo-parameter-required)
+  (editable      mojo-parameter-editable)
+  (property      mojo-parameter-property)
+  (description   mojo-parameter-description)
+  (configuration mojo-parameter-configuration))
+
+(define* (update-mojo-parameter mojo-parameter
+           #:key (name (mojo-parameter-name mojo-parameter))
+                 (type (mojo-parameter-type mojo-parameter))
+                 (since (mojo-parameter-since mojo-parameter))
+                 (required (mojo-parameter-required mojo-parameter))
+                 (editable (mojo-parameter-editable mojo-parameter))
+                 (property (mojo-parameter-property mojo-parameter))
+                 (description (mojo-parameter-description mojo-parameter))
+                 (configuration (mojo-parameter-configuration mojo-parameter)))
+  (make-mojo-parameter name type since required editable property description
+                       configuration))
+
+(define-record-type <mojo-component>
+  (make-mojo-component field role hint)
+  mojo-component?
+  (field mojo-component-field)
+  (role  mojo-component-role)
+  (hint  mojo-component-hint))
+
+(define* (update-mojo-component mojo-component
+           #:key (field (mojo-component-field mojo-component))
+                 (role (mojo-component-role mojo-component))
+                 (hint (mojo-component-hint mojo-component)))
+  (make-mojo-component field role hint))
+
+(define (generate-mojo-parameter mojo-parameter)
+  `(parameter (name ,(mojo-parameter-name mojo-parameter))
+              (type ,(mojo-parameter-type mojo-parameter))
+              ,@(if (mojo-parameter-since mojo-parameter)
+                    `(since (mojo-parameter-since mojo-parameter))
+                    '())
+              (required ,(if (mojo-parameter-required mojo-parameter) "true" "false"))
+              (editable ,(if (mojo-parameter-editable mojo-parameter) "true" "false"))
+              (description ,(mojo-parameter-description mojo-parameter))))
+
+(define (generate-mojo-configuration mojo-parameter)
+  (let ((config (mojo-parameter-configuration mojo-parameter)))
+    (if (or config (mojo-parameter-property mojo-parameter))
+        `(,(string->symbol (mojo-parameter-name mojo-parameter))
+           (@ ,@(cons (list 'implementation (mojo-parameter-type mojo-parameter))
+                      (or config '())))
+          ,@(if (mojo-parameter-property mojo-parameter)
+                (list (string-append "${" (mojo-parameter-property mojo-parameter)
+                                     "}"))
+                '()))
+        #f)))
+
+(define (generate-mojo-component mojo-component)
+  (let ((role (mojo-component-role mojo-component))
+        (field (mojo-component-field mojo-component))
+        (hint (mojo-component-hint mojo-component)))
+    `(requirement
+       (role ,role)
+       ,@(if hint
+          `((role-hint ,hint))
+          '())
+       (field-name ,field))))
+
+(define (generate-mojo mojo)
+  `(mojo
+     (goal ,(mojo-goal mojo))
+     (description ,(mojo-description mojo))
+     ,@(let ((val (mojo-requires-dependency-collection mojo)))
+         (if val
+             `((requiresDependencyCollection ,val))
+             '()))
+     ,@(let ((val (mojo-requires-dependency-resolution mojo)))
+         (if val
+             `((requiresDependencyResolution ,val))
+             '()))
+     ,@(let ((val (mojo-requires-direct-invocation? mojo)))
+         (if val
+             `((requiresDirectInvocation ,val))
+             '()))
+     ,@(let ((val (mojo-requires-project? mojo)))
+         (if val
+             `((requiresProject ,val))
+             '()))
+     ,@(let ((val (mojo-requires-reports? mojo)))
+         (if val
+             `((requiresReports ,val))
+             '()))
+     ,@(let ((val (mojo-aggregator? mojo)))
+         (if val
+             `((aggregator ,val))
+             '()))
+     ,@(let ((val (mojo-requires-online? mojo)))
+         (if val
+             `((requiresOnline ,val))
+             '()))
+     ,@(let ((val (mojo-inherited-by-default? mojo)))
+         (if val
+             `((inheritedByDefault ,val))
+             '()))
+     ,@(let ((phase (mojo-phase mojo)))
+             (if phase
+                 `((phase ,phase))
+                 '()))
+     (implementation ,(string-append (mojo-package mojo) "." (mojo-name mojo)))
+     (language "java")
+     (instantiationStrategy ,(mojo-instantiation-strategy mojo))
+     (executionStrategy ,(mojo-execution-strategy mojo))
+     ,@(let ((since (mojo-since mojo)))
+             (if since
+                 `((since ,since))
+                 '()))
+     ,@(let ((val (mojo-thread-safe? mojo)))
+         (if val
+             `((threadSafe ,val))
+             '()))
+     (parameters
+       ,(map generate-mojo-parameter (mojo-parameters mojo)))
+     (configuration
+       ,@(filter (lambda (a) a) (map generate-mojo-configuration (mojo-parameters mojo))))
+     (requirements
+       ,@(map generate-mojo-component (mojo-components mojo)))))
+
+
+(define (default-convert-type type)
+  (cond
+    ((equal? type "String") "java.lang.String")
+    ((equal? type "String[]") "java.lang.String[]")
+    ((equal? type "File") "java.io.File")
+    ((equal? type "File[]") "java.io.File[]")
+    ((equal? type "List") "java.util.List")
+    ((equal? type "Boolean") "java.lang.Boolean")
+    ((equal? type "Properties") "java.util.Properties")
+    ((and (> (string-length type) 5)
+          (equal? (substring type 0 4) "Map<"))
+     "java.util.Map")
+    ((and (> (string-length type) 6)
+          (equal? (substring type 0 5) "List<"))
+     "java.util.List")
+    ((and (> (string-length type) 15)
+          (equal? (substring type 0 14) "LinkedHashSet<"))
+     "java.util.LinkedHashSet")
+    (else type)))
+
+(define (maven-convert-type type)
+  (cond
+    ((equal? type "MavenProject")
+     "org.apache.maven.project.MavenProject")
+    (else (default-convert-type type))))
+
+(define (update-mojo-from-file mojo file convert-type)
+  (define parse-tree (parse-java-file file))
+
+  (define (update-mojo-from-attrs mojo attrs)
+    (let loop ((mojo mojo) (attrs attrs))
+      (match attrs
+        ('() mojo)
+        ((attr attrs ...)
+         (match attr
+           (('annotation-attr ('attr-name name) ('attr-value value))
+            (cond
+              ((equal? name "name")
+               (loop (update-mojo mojo #:goal value) attrs))
+              ((equal? name "defaultPhase")
+               (let* ((phase (car (reverse (string-split value #\.))))
+                      (phase (string-downcase phase))
+                      (phase (string-join (string-split phase #\_) "-")))
+               (loop (update-mojo mojo #:phase phase) attrs)))
+              ((equal? name "requiresProject")
+               (loop (update-mojo mojo #:requires-project? value) attrs))
+              ((equal? name "threadSafe")
+               (loop (update-mojo mojo #:thread-safe? value) attrs))
+              ((equal? name "aggregator")
+               (loop (update-mojo mojo #:aggregator? value) attrs))
+              ((equal? name "requiresDependencyCollection")
+               (loop
+                 (update-mojo mojo #:requires-dependency-collection
+                              (match value
+                                ("ResolutionScope.COMPILE" "compile")
+                                ("ResolutionScope.COMPILE_PLUS_RUNTIME"
+                                 "compile+runtime")
+                                ("ResolutionScope.RUNTIME" "runtime")
+                                ("ResolutionScope.RUNTIME_PLUS_SYSTEM"
+                                 "runtime+system")
+                                ("ResolutionScope.TEST" "test")
+                                ("ResolutionScope.PROVIDED" "provided")
+                                ("ResolutionScope.SYSTEM" "system")
+                                ("ResolutionScope.IMPORT" "import")))
+                 attrs))
+              ((equal? name "requiresDependencyResolution")
+               (loop
+                 (update-mojo mojo #:requires-dependency-resolution
+                              (match value
+                                ("ResolutionScope.COMPILE" "compile")
+                                ("ResolutionScope.COMPILE_PLUS_RUNTIME"
+                                 "compile+runtime")
+                                ("ResolutionScope.RUNTIME" "runtime")
+                                ("ResolutionScope.RUNTIME_PLUS_SYSTEM"
+                                 "runtime+system")
+                                ("ResolutionScope.TEST" "test")
+                                ("ResolutionScope.PROVIDED" "provided")
+                                ("ResolutionScope.SYSTEM" "system")
+                                ("ResolutionScope.IMPORT" "import")))
+                 attrs))
+              (else
+                (throw 'not-found-attr name))))
+           ((attrs ...) (loop mojo attrs))
+           (_ (loop mojo attrs)))))))
+
+  (define (string->attr name)
+    (define (string-split-upper s)
+      (let ((i (string-index s char-set:upper-case)))
+        (if (and i (> i 0))
+            (cons (substring s 0 i) (string-split-upper (substring s i)))
+            (list s))))
+    (string->symbol
+      (string-join (map string-downcase (string-split-upper name)) "-")))
+
+  (define (update-mojo-parameter-from-attrs mojo-parameter attrs)
+    (match attrs
+      ('() mojo-parameter)
+      (('annotation-attr ('attr-name name) 'attr-value)
+       mojo-parameter)
+       ;(update-mojo-parameter-from-attrs mojo-parameter
+       ;  `(annotation-attr (attr-name ,name) (attr-value ""))))
+      (('annotation-attr ('attr-name name) ('attr-value value))
+       (cond
+         ((equal? name "editable")
+          (update-mojo-parameter mojo-parameter #:editable value))
+         ((equal? name "required")
+          (update-mojo-parameter mojo-parameter #:required value))
+         ((equal? name "property")
+          (update-mojo-parameter mojo-parameter #:property value))
+         (else
+           (update-mojo-parameter mojo-parameter
+                                  #:configuration
+                                  (cons
+                                    (list (string->attr name) value)
+                                    (or
+				      (mojo-parameter-configuration mojo-parameter)
+				      '()))))))
+      ((attr attrs ...)
+       (update-mojo-parameter-from-attrs
+         (update-mojo-parameter-from-attrs mojo-parameter attr)
+         attrs))))
+
+  (define (update-mojo-component-from-attrs mojo-component inverse-import attrs)
+    (match attrs
+      ('() mojo-component)
+      ((attr attrs ...)
+       (match attr
+         (('annotation-attr ('attr-name name) ('attr-value value))
+          (cond
+            ((equal? name "role")
+             (update-mojo-component-from-attrs
+               (update-mojo-component mojo-component
+                 #:role (select-import inverse-import value convert-type))
+               inverse-import
+               attrs))
+            ((equal? name "hint")
+             (update-mojo-component-from-attrs
+               (update-mojo-component mojo-component #:hint value)
+               inverse-import
+               attrs))
+            (else (throw 'not-found-attr name))))
+         ((attrss ...)
+          (update-mojo-component-from-attrs
+            mojo-component inverse-import (append attrss attrs)))))))
+
+  (define (add-mojo-parameter parameters name type last-comment attrs inverse-import)
+    (let loop ((parameters parameters))
+      (match parameters
+        ('() (list (update-mojo-parameter-from-attrs
+                     (make-mojo-parameter
+                       ;; name convert since required editable property comment config
+                       name (select-import inverse-import type convert-type)
+                       #f #f #t #f last-comment #f)
+                     attrs)))
+        ((parameter parameters ...)
+         (if (equal? (mojo-parameter-name parameter) name)
+             (cons (update-mojo-parameter-from-attrs
+                     (make-mojo-parameter
+                       name (select-import inverse-import type convert-type)
+                       #f #f #t #f last-comment #f)
+                     attrs) parameters)
+             (cons parameter (loop parameters)))))))
+
+  (define (update-mojo-from-class-content mojo inverse-import content)
+    (let loop ((content content)
+               (mojo mojo)
+               (last-comment #f))
+      (match content
+        ('() mojo)
+        ((('comment ('annotation-pat _ ...) last-comment) content ...)
+         (loop content mojo last-comment))
+        ((('comment last-comment) content ...)
+         (loop content mojo last-comment))
+        ((('param-pat ('annotation-pat annot-name attrs ...) ('type-name type)
+           ('param-name name)) content ...)
+         (cond
+           ((equal? annot-name "Parameter")
+            (loop content
+                  (update-mojo mojo
+                               #:parameters
+                               (add-mojo-parameter
+                                 (mojo-parameters mojo) name type last-comment
+                                 attrs inverse-import))
+                  #f))
+           ((equal? annot-name "Component")
+            (loop content
+                  (update-mojo mojo
+                               #:components
+                               (cons (update-mojo-component-from-attrs
+                                       (make-mojo-component
+                                         name
+                                         (select-import inverse-import type
+                                                        convert-type)
+                                         #f)
+                                       inverse-import
+                                       attrs)
+                                     (mojo-components mojo)))
+                  #f))
+           (else (throw 'not-found-annot annot-name))))
+        ((('class-pat _ ...) content ...)
+         (loop content mojo #f))
+        ((('param-pat _ ...) content ...)
+         (loop content mojo #f))
+        ((('method-pat _ ...) content ...)
+         (loop content mojo #f)))))
+
+  (define (update-inverse-import inverse-import package)
+    (let ((package-name (car (reverse (string-split package #\.)))))
+      (cons (cons package-name package) inverse-import)))
+
+  (define (select-import inverse-import package convert-type)
+    (let* ((package (car (string-split package #\<)))
+           (package (string-split package #\.))
+           (rest (reverse (cdr package)))
+           (rest (cond
+                   ((null? rest) '())
+                   ((equal? (car rest) "class") (cdr rest))
+                   (else rest)))
+           (base (or (assoc-ref inverse-import (car package)) (car package))))
+      (convert-type (string-join (cons base rest) "."))))
+
+  (let loop ((content parse-tree)
+             (mojo mojo)
+             (inverse-import '())
+             (last-comment #f))
+    (if (null? content)
+        mojo
+        (match content
+          ((tls content ...)
+           (match tls
+             (('package package)
+              (loop content (update-mojo mojo #:package package) inverse-import
+                    last-comment))
+             (('import-pat package)
+              (loop content mojo (update-inverse-import inverse-import package)
+                    last-comment))
+             (('comment last-comment)
+              (loop content mojo inverse-import last-comment))
+             (('class-pat class-tls ...)
+              (let loop2 ((class-tls class-tls) (mojo mojo))
+                (match class-tls
+                  ('() (loop content mojo inverse-import #f))
+                  (((? string? name) class-tls ...)
+                   (loop2 class-tls (update-mojo mojo #:name name)))
+                  ((('annotation-pat annot-name (attrs ...)) class-tls ...)
+                   (loop2
+                     class-tls
+                     (update-mojo-from-attrs mojo attrs)))
+                  ((('class-body class-content ...) class-tls ...)
+                   (loop2
+                     class-tls
+                     (update-mojo-from-class-content
+                       mojo inverse-import class-content)))
+                  ((_ class-tls ...)
+                   (loop2 class-tls mojo)))))
+             (_
+              (loop content mojo inverse-import last-comment))))))))
+
+(define (generate-mojo-from-files convert-type . files)
+  (let ((mojo (make-mojo #f #f #f #f #f #f #f #f #f #f #f #f "per-lookup"
+                         "once-per-session" #f #f #f '() '())))
+    (let loop ((files files) (mojo mojo))
+      (if (null? files)
+          (generate-mojo mojo)
+          (loop
+            (cdr files)
+            (update-mojo-from-file
+              (update-mojo mojo
+                #:package #f
+                #:name #f
+                #:goal #f
+                #:description #f
+                #:requires-dependency-resolution #f
+                #:requires-direct-invocation? #f
+                #:requires-project? #f
+                #:requires-reports? #f
+                #:aggregator? #f
+                #:requires-online? #f
+                #:inherited-by-default? #f
+                #:instantiation-strategy "per-lookup"
+                #:execution-strategy "once-per-session"
+                #:since #f
+                #:thread-safe? #f
+                #:phase #f)
+              (car files)
+	      convert-type))))))
diff --git a/guix/build/maven/pom.scm b/guix/build/maven/pom.scm
new file mode 100644
index 0000000000..aa60af2afa
--- /dev/null
+++ b/guix/build/maven/pom.scm
@@ -0,0 +1,422 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019, 2020 Julien Lepiller <julien@lepiller.eu>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build maven pom)
+  #:use-module (sxml simple)
+  #:use-module (system foreign)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:export (get-pom
+            pom-ref
+            pom-description
+            pom-name
+            pom-version
+            pom-artifactid
+            pom-groupid
+            pom-dependencies
+            group->dir
+            fix-pom-dependencies))
+
+(define (get-pom file)
+  "Return the content of a @file{.pom} file."
+  (let ((pom-content (call-with-input-file file xml->sxml)))
+    (match pom-content
+      (('*TOP* _ (_ ('@ _ ...) content ...))
+        content)
+      (('*TOP* (_ ('@ _ ...) content ...))
+       content)
+      (('*TOP* _ (_ content ...))
+        content)
+      (('*TOP* (_ content ...))
+       content))))
+
+(define (pom-ref content attr)
+  "Gets a value associated to @var{attr} in @var{content}, an sxml value that
+represents a @file{.pom} file content, or parts of it."
+  (or
+    (assoc-ref
+      content
+      (string->symbol
+        (string-append "http://maven.apache.org/POM/4.0.0:" attr)))
+    (assoc-ref content (string->symbol attr))))
+
+(define (get-parent content)
+  (pom-ref content "parent"))
+
+(define* (find-parent content inputs #:optional local-packages)
+  "Find the parent pom for the pom file whith @var{content} in a package's
+@var{inputs}.  When the parent pom cannot be found in @var{inputs}, but
+@var{local-packages} is defined, the parent pom is looked up in it.
+
+@var{local-packages} is an association list of groupID to an association list
+of artifactID to version number.
+
+The result is an sxml document that describes the content of the parent pom, or
+of an hypothetical parent pom if it was generated from @var{local-packages}.
+If no result is found, the result is @code{#f}."
+  (let ((parent (pom-ref content "parent")))
+    (if parent
+        (let* ((groupid (car (pom-ref parent "groupId")))
+               (artifactid (car (pom-ref parent "artifactId")))
+               (version (car (pom-ref parent "version")))
+               (pom-file (string-append "lib/m2/" (group->dir groupid)
+                                        "/" artifactid "/" version "/"
+                                        artifactid "-" version ".pom"))
+               (java-inputs (filter
+                              (lambda (input)
+                                (file-exists? (string-append input "/" pom-file)))
+                              inputs))
+               (java-inputs (map (lambda (input) (string-append input "/" pom-file))
+                                 java-inputs)))
+          (if (null? java-inputs)
+              (let ((version (assoc-ref (assoc-ref local-packages groupid) artifactid)))
+                (if version
+                    `((groupId ,groupid)
+                      (artifactId ,artifactid)
+                      (version ,version))
+                    #f))
+              (get-pom (car java-inputs))))
+        #f)))
+
+(define* (pom-groupid content inputs #:optional local-packages)
+  "Find the groupID of a pom file, potentially looking at its parent pom file.
+See @code{find-parent} for the meaning of the arguments."
+  (if content
+    (let ((res (or (pom-ref content "groupId")
+                   (pom-groupid (find-parent content inputs local-packages)
+                                inputs))))
+      (cond
+        ((string? res) res)
+        ((null? res) #f)
+        ((list? res) (car res))
+        (else #f)))
+    #f))
+
+(define (pom-artifactid content)
+  "Find the artifactID of a pom file, from its sxml @var{content}."
+  (let ((res (pom-ref content "artifactId")))
+    (if (and res (>= (length res) 1))
+      (car res)
+      #f)))
+
+(define* (pom-version content inputs #:optional local-packages)
+  "Find the version of a pom file, potentially looking at its parent pom file.
+See @code{find-parent} for the meaning of the arguments."
+  (if content
+    (let ((res (or (pom-ref content "version")
+                   (pom-version (find-parent content inputs local-packages)
+                                inputs))))
+      (cond
+        ((string? res) res)
+        ((null? res) #f)
+        ((list? res) (car res))
+        (else #f)))
+    #f))
+
+(define (pom-name content)
+  "Return the name of the package as contained in the sxml @var{content} of the
+pom file."
+  (let ((res (pom-ref content "name")))
+    (if (and res (>= (length res) 1))
+      (car res)
+      #f)))
+
+(define (pom-description content)
+  "Return the description of the package as contained in the sxml @var{content}
+of the pom file."
+  (let ((res (pom-ref content "description")))
+    (if (and res (>= (length res) 1))
+      (car res)
+      #f)))
+
+(define (pom-dependencies content)
+  "Return the list of dependencies listed in the sxml @var{content} of the pom
+file."
+  (filter
+    (lambda (a) a)
+    (map
+      (match-lambda
+        ((? string? _) #f)
+        (('http://maven.apache.org/POM/4.0.0:dependency content ...)
+         (let loop ((content content) (groupid #f) (artifactid #f) (version #f) (scope #f))
+           (match content
+             ('()
+              `(dependency
+                 (groupId ,groupid)
+                 (artifactId ,artifactid)
+                 (version ,version)
+                 ,@(if scope `((scope ,scope)) '())))
+             (((? string? _) content ...)
+              (loop content groupid artifactid version scope))
+             ((('http://maven.apache.org/POM/4.0.0:scope scope) content ...)
+              (loop content groupid artifactid version scope))
+             ((('http://maven.apache.org/POM/4.0.0:groupId groupid) content ...)
+              (loop content groupid artifactid version scope))
+             ((('http://maven.apache.org/POM/4.0.0:artifactId artifactid) content ...)
+              (loop content groupid artifactid version scope))
+             ((('http://maven.apache.org/POM/4.0.0:version version) content ...)
+              (loop content groupid artifactid version scope))
+             ((_ content ...)
+              (loop content groupid artifactid version scope))))))
+      (pom-ref content "dependencies"))))
+
+(define version-compare
+  (let ((strverscmp
+         (let ((sym (or (dynamic-func "strverscmp" (dynamic-link))
+                        (error "could not find `strverscmp' (from GNU libc)"))))
+           (pointer->procedure int sym (list '* '*)))))
+    (lambda (a b)
+      "Return '> when A denotes a newer version than B,
+'< when A denotes a older version than B,
+or '= when they denote equal versions."
+      (let ((result (strverscmp (string->pointer a) (string->pointer b))))
+        (cond ((positive? result) '>)
+              ((negative? result) '<)
+              (else '=))))))
+
+(define (version>? a b)
+  "Return #t when A denotes a version strictly newer than B."
+  (eq? '> (version-compare a b)))
+
+(define (fix-maven-xml sxml)
+  "When writing an xml file from an sxml representation, it is not possible to
+use namespaces in tag names.  This procedure takes an @var{sxml} representation
+of a pom file and removes the namespace uses.  It also adds the required bits
+to re-declare the namespaces in the top-level element."
+  (define (fix-xml sxml)
+    (match sxml
+      ((tag ('@ opts ...) rest ...)
+       (if (> (string-length (symbol->string tag))
+              (string-length "http://maven.apache.org/POM/4.0.0:"))
+         (let* ((tag (symbol->string tag))
+                (tag (substring tag (string-length
+                                      "http://maven.apache.org/POM/4.0.0:")))
+                (tag (string->symbol tag)))
+           `(,tag (@ ,@opts) ,@(map fix-xml rest)))
+         `(,tag (@ ,@opts) ,@(map fix-xml rest))))
+      ((tag (rest ...))
+       (if (> (string-length (symbol->string tag))
+              (string-length "http://maven.apache.org/POM/4.0.0:"))
+         (let* ((tag (symbol->string tag))
+                (tag (substring tag (string-length
+                                      "http://maven.apache.org/POM/4.0.0:")))
+                (tag (string->symbol tag)))
+           `(,tag ,@(map fix-xml rest)))
+         `(,tag ,@(map fix-xml rest))))
+      ((tag rest ...)
+       (if (> (string-length (symbol->string tag))
+              (string-length "http://maven.apache.org/POM/4.0.0:"))
+         (let* ((tag (symbol->string tag))
+                (tag (substring tag (string-length
+                                      "http://maven.apache.org/POM/4.0.0:")))
+                (tag (string->symbol tag)))
+           `(,tag ,@(map fix-xml rest)))
+         `(,tag ,@(map fix-xml rest))))
+      (_ sxml)))
+
+  `((*TOP* (*PI* xml "version=\"1.0\" encoding=\"UTF-8\"")
+     (project (@ (xmlns "http://maven.apache.org/POM/4.0.0")
+                 (xmlns:xsi "http://www.w3.org/2001/XMLSchema-instance")
+                 (xmlns:schemaLocation "http://maven.apache.org/POM/4.0.0
+                   http://maven.apache.org/xsd/maven-4.0.0.xsd"))
+       ,(map fix-xml sxml)))))
+
+(define (group->dir group)
+  "Convert a group ID to a directory path."
+  (string-join (string-split group #\.) "/"))
+
+(define* (fix-pom-dependencies pom-file inputs
+                               #:key with-plugins? with-build-dependencies?
+                                     (excludes '()) (local-packages '()))
+  "Open @var{pom-file}, and override its content, rewritting its dependencies
+to set their version to the latest version available in the @var{inputs}.
+
+@var{#:with-plugins?} controls whether plugins are also overiden.
+@var{#:with-build-dependencies?} controls whether build dependencies (whose
+scope is not empty) are also overiden.  By default build dependencies and
+plugins are not overiden.
+
+@var{#:excludes} is an association list of groupID to a list of artifactIDs.
+When a pair (groupID, artifactID) is present in the list, its entry is
+removed instead of being overiden.  If the entry is ignored because of the
+previous arguments, the entry is not removed.
+
+@var{#:local-packages} is an association list that contains additional version
+information for packages that are not in @var{inputs}.  If the package is
+not found in @var{inputs}, information from this list is used instead to determine
+the latest version of the package.  This is an association list of group IDs
+to another association list of artifact IDs to a version number.
+
+Returns nothing, but overides the @var{pom-file} as a side-effect."
+  (define pom (get-pom pom-file))
+
+  (define (ls dir)
+    (let ((dir (opendir dir)))
+      (let loop ((res '()))
+        (let ((entry (readdir dir)))
+          (if (eof-object? entry)
+              res
+              (loop (cons entry res)))))))
+
+  (define fix-pom
+    (match-lambda
+      ('() '())
+      ((tag rest ...)
+       (match tag
+         (('http://maven.apache.org/POM/4.0.0:dependencies deps ...)
+          `((http://maven.apache.org/POM/4.0.0:dependencies ,(fix-deps deps))
+            ,@(fix-pom rest)))
+         (('http://maven.apache.org/POM/4.0.0:dependencyManagement deps ...)
+          `((http://maven.apache.org/POM/4.0.0:dependencyManagement
+              ,(fix-dep-management deps))
+            ,@(fix-pom rest)))
+         (('http://maven.apache.org/POM/4.0.0:build build ...)
+          (if with-plugins?
+              `((http://maven.apache.org/POM/4.0.0:build ,(fix-build build))
+                ,@(fix-pom rest))
+              (cons tag (fix-pom rest))))
+         (tag (cons tag (fix-pom rest)))))))
+
+  (define fix-dep-management
+    (match-lambda
+      ('() '())
+      ((tag rest ...)
+       (match tag
+         (('http://maven.apache.org/POM/4.0.0:dependencies deps ...)
+          `((http://maven.apache.org/POM/4.0.0:dependencies ,(fix-deps deps #t))
+            ,@(fix-dep-management rest)))
+         (tag (cons tag (fix-dep-management rest)))))))
+
+  (define* (fix-deps deps #:optional optional?)
+    (match deps
+      ('() '())
+      ((tag rest ...)
+       (match tag
+         (('http://maven.apache.org/POM/4.0.0:dependency dep ...)
+          `((http://maven.apache.org/POM/4.0.0:dependency ,(fix-dep dep optional?))
+            ,@(fix-deps rest optional?)))
+         (tag (cons tag (fix-deps rest optional?)))))))
+
+  (define fix-build
+    (match-lambda
+      ('() '())
+      ((tag rest ...)
+       (match tag
+         (('http://maven.apache.org/POM/4.0.0:pluginManagement management ...)
+          `((http://maven.apache.org/POM/4.0.0:pluginManagement
+              ,(fix-management management))
+            ,@(fix-build rest)))
+         (('http://maven.apache.org/POM/4.0.0:plugins plugins ...)
+          `((http://maven.apache.org/POM/4.0.0:plugins
+              ,(fix-plugins plugins))
+            ,@(fix-build rest)))
+         (tag (cons tag (fix-build rest)))))))
+
+  (define fix-management
+    (match-lambda
+      ('() '())
+      ((tag rest ...)
+       (match tag
+         (('http://maven.apache.org/POM/4.0.0:plugins plugins ...)
+          `((http://maven.apache.org/POM/4.0.0:plugins
+              ,(fix-plugins plugins #t))
+            ,@(fix-management rest)))
+         (tag (cons tag (fix-management rest)))))))
+
+  (define* (fix-plugins plugins #:optional optional?)
+    (match plugins
+      ('() '())
+      ((tag rest ...)
+       (match tag
+         (('http://maven.apache.org/POM/4.0.0:plugin plugin ...)
+          (let ((group (or (pom-groupid plugin inputs) "org.apache.maven.plugins"))
+                (artifact (pom-artifactid plugin)))
+            (if (member artifact (or (assoc-ref excludes group) '()))
+              (fix-plugins rest optional?)
+              `((http://maven.apache.org/POM/4.0.0:plugin
+                  ,(fix-plugin plugin optional?))
+                ,@(fix-plugins rest optional?)))))
+         (tag (cons tag (fix-plugins rest optional?)))))))
+
+  (define* (fix-plugin plugin #:optional optional?)
+    (let* ((artifact (pom-artifactid plugin))
+           (group (or (pom-groupid plugin inputs) "org.apache.maven.plugins"))
+           (version (or (assoc-ref (assoc-ref local-packages group) artifact)
+                        (find-version inputs group artifact optional?)
+                        (pom-version plugin inputs))))
+      (if (pom-version plugin inputs)
+        (map
+          (lambda (tag)
+            (match tag
+              (('http://maven.apache.org/POM/4.0.0:version _)
+               `(http://maven.apache.org/POM/4.0.0:version ,version))
+              (('version _)
+               `(http://maven.apache.org/POM/4.0.0:version ,version))
+              (tag tag)))
+          plugin)
+        (cons `(http://maven.apache.org/POM/4.0.0:version ,version) plugin))))
+
+  (define* (fix-dep dep #:optional optional?)
+    (let* ((artifact (pom-artifactid dep))
+           (group (or (pom-groupid dep inputs) (pom-groupid pom inputs)))
+           (scope (pom-ref dep "scope"))
+           (is-optional? (equal? (pom-ref dep "optional") '("true"))))
+      (format (current-error-port) "maven: ~a:~a :: ~a (optional: ~a)~%"
+              group artifact scope optional?)
+      (if (or (and (not (equal? scope '("test"))) (not is-optional?))
+              with-build-dependencies?)
+          (let ((version (or (assoc-ref (assoc-ref local-packages group) artifact)
+                             (find-version inputs group artifact optional?)
+                             (pom-version dep inputs))))
+            (if (pom-version dep inputs)
+              (map
+                (lambda (tag)
+                  (match tag
+                    (('http://maven.apache.org/POM/4.0.0:version _)
+                     `(http://maven.apache.org/POM/4.0.0:version ,version))
+                    (('version _)
+                     `(http://maven.apache.org/POM/4.0.0:version ,version))
+                    (_ tag)))
+                dep)
+              (cons `(http://maven.apache.org/POM/4.0.0:version ,version) dep)))
+          dep)))
+
+  (define* (find-version inputs group artifact #:optional optional?)
+    (let* ((directory (string-append "lib/m2/" (group->dir group)
+                                     "/" artifact))
+           (java-inputs (filter
+                          (lambda (input)
+                            (file-exists? (string-append input "/" directory)))
+                          inputs))
+           (java-inputs (map (lambda (input) (string-append input "/" directory))
+                             java-inputs))
+           (versions (append-map ls java-inputs))
+           (versions (sort versions version>?)))
+      (if (null? versions)
+        (if optional?
+          #f
+          (begin
+            (format (current-error-port) "maven: ~a:~a is missing from inputs~%"
+                    group artifact)
+            (throw 'no-such-input group artifact)))
+        (car versions))))
+
+  (let ((tmpfile (string-append pom-file ".tmp")))
+    (with-output-to-file pom-file
+      (lambda _
+        (sxml->xml (fix-maven-xml (fix-pom pom)))))))