summaryrefslogtreecommitdiff
path: root/guix/build/maven/pom.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guix/build/maven/pom.scm')
-rw-r--r--guix/build/maven/pom.scm422
1 files changed, 422 insertions, 0 deletions
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)))))))
generated by cgit v1.2.3 (git 2.44.0) at 2024-07-05 21:33:24 +0000