diff options
Diffstat (limited to 'guix')
52 files changed, 2871 insertions, 627 deletions
diff --git a/guix/build-system/ant.scm b/guix/build-system/ant.scm index b5626bd42d..1809d1f3d2 100644 --- a/guix/build-system/ant.scm +++ b/guix/build-system/ant.scm @@ -39,6 +39,9 @@ (define %ant-build-system-modules ;; Build-side modules imported by default. `((guix build ant-build-system) + (guix build maven java) + (guix build maven plugin) + (guix build maven pom) (guix build java-utils) (guix build syscalls) ,@%gnu-build-system-modules)) diff --git a/guix/build-system/maven.scm b/guix/build-system/maven.scm new file mode 100644 index 0000000000..2dceefccc1 --- /dev/null +++ b/guix/build-system/maven.scm @@ -0,0 +1,214 @@ +;;; 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-system maven) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix derivations) + #:use-module (guix search-paths) + #:use-module (guix build-system) + #:use-module (guix build-system gnu) + #:use-module (guix packages) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:export (%maven-build-system-modules + default-maven + default-maven-plugins + %default-exclude + lower + maven-build + maven-build-system)) + +;; Commentary: +;; +;; Standard build procedure for Maven packages. This is implemented as an +;; extension of `gnu-build-system'. +;; +;; Code: + +(define %maven-build-system-modules + ;; Build-side modules imported by default. + `((guix build maven-build-system) + (guix build maven pom) + ,@%gnu-build-system-modules)) + +(define (default-maven) + "Return the default maven package." + + ;; Do not use `@' to avoid introducing circular dependencies. + (let ((module (resolve-interface '(gnu packages maven)))) + (module-ref module 'maven))) + +(define (default-maven-compiler-plugin) + "Return the default maven compiler plugin package." + ;; Do not use `@' to avoid introducing circular dependencies. + (let ((module (resolve-interface '(gnu packages maven)))) + (module-ref module 'maven-compiler-plugin))) + +(define (default-maven-jar-plugin) + "Return the default maven jar plugin package." + ;; Do not use `@' to avoid introducing circular dependencies. + (let ((module (resolve-interface '(gnu packages maven)))) + (module-ref module 'maven-jar-plugin))) + +(define (default-maven-resources-plugin) + "Return the default maven resources plugin package." + ;; Do not use `@' to avoid introducing circular dependencies. + (let ((module (resolve-interface '(gnu packages maven)))) + (module-ref module 'maven-resources-plugin))) + +(define (default-maven-surefire-plugin) + "Return the default maven surefire plugin package." + ;; Do not use `@' to avoid introducing circular dependencies. + (let ((module (resolve-interface '(gnu packages maven)))) + (module-ref module 'maven-surefire-plugin))) + +(define (default-java-surefire-junit4) + "Return the default surefire junit4 provider package." + ;; Do not use `@' to avoid introducing circular dependencies. + (let ((module (resolve-interface '(gnu packages maven)))) + (module-ref module 'java-surefire-junit4))) + +(define (default-maven-install-plugin) + "Return the default maven install plugin package." + ;; Do not use `@' to avoid introducing circular dependencies. + (let ((module (resolve-interface '(gnu packages maven)))) + (module-ref module 'maven-install-plugin))) + +(define (default-jdk) + "Return the default JDK package." + ;; Lazily resolve the binding to avoid a circular dependency. + (let ((jdk-mod (resolve-interface '(gnu packages java)))) + (module-ref jdk-mod 'icedtea))) + +(define (default-maven-plugins) + `(("maven-compiler-plugin" ,(default-maven-compiler-plugin)) + ("maven-jar-plugin" ,(default-maven-jar-plugin)) + ("maven-resources-plugin" ,(default-maven-resources-plugin)) + ("maven-surefire-plugin" ,(default-maven-surefire-plugin)) + ("java-surefire-junit4" ,(default-java-surefire-junit4)) + ("maven-install-plugin" ,(default-maven-install-plugin)))) + +(define %default-exclude + `(("org.apache.maven.plugins" . + ("maven-release-plugin" "maven-site-plugin")))) + +(define* (lower name + #:key source inputs native-inputs outputs system target + (maven (default-maven)) + (jdk (default-jdk)) + (maven-plugins (default-maven-plugins)) + (local-packages '()) + (exclude %default-exclude) + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME." + (define private-keywords + '(#:source #:target #:jdk #:maven #:maven-plugins #:inputs #:native-inputs)) + + (and (not target) ;XXX: no cross-compilation + (bag + (name name) + (system system) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@inputs + + ;; Keep the standard inputs of 'gnu-build-system'. + ,@(standard-packages))) + (build-inputs `(("maven" ,maven) + ("jdk" ,jdk "jdk") + ,@maven-plugins + ,@native-inputs)) + (outputs outputs) + (build maven-build) + (arguments (strip-keyword-arguments private-keywords arguments))))) + +(define* (maven-build store name inputs + #:key (guile #f) + (outputs '("out")) + (search-paths '()) + (out-of-source? #t) + (validate-runpath? #t) + (patch-shebangs? #t) + (strip-binaries? #t) + (exclude %default-exclude) + (local-packages '()) + (tests? #t) + (strip-flags ''("--strip-debug")) + (strip-directories ''("lib" "lib64" "libexec" + "bin" "sbin")) + (phases '(@ (guix build maven-build-system) + %standard-phases)) + (system (%current-system)) + (imported-modules %maven-build-system-modules) + (modules '((guix build maven-build-system) + (guix build maven pom) + (guix build utils)))) + "Build SOURCE using PATCHELF, and with INPUTS. This assumes that SOURCE +provides its own binaries." + (define builder + `(begin + (use-modules ,@modules) + (maven-build #:source ,(match (assoc-ref inputs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) + source) + (source + source)) + #:system ,system + #:outputs %outputs + #:inputs %build-inputs + #:search-paths ',(map search-path-specification->sexp + search-paths) + #:phases ,phases + #:exclude (quote ,exclude) + #:local-packages (quote ,local-packages) + #:tests? ,tests? + #:out-of-source? ,out-of-source? + #:validate-runpath? ,validate-runpath? + #:patch-shebangs? ,patch-shebangs? + #:strip-binaries? ,strip-binaries? + #:strip-flags ,strip-flags + #:strip-directories ,strip-directories))) + + (define guile-for-build + (match guile + ((? package?) + (package-derivation store guile system #:graft? #f)) + (#f ; the default + (let* ((distro (resolve-interface '(gnu packages commencement))) + (guile (module-ref distro 'guile-final))) + (package-derivation store guile system #:graft? #f))))) + + (build-expression->derivation store name builder + #:system system + #:inputs inputs + #:modules imported-modules + #:outputs outputs + #:guile-for-build guile-for-build)) + +(define maven-build-system + (build-system + (name 'maven) + (description "The standard Maven build system") + (lower lower))) + +;;; maven.scm ends here diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm index c8ec9abd0d..5ef982d66a 100644 --- a/guix/build-system/r.scm +++ b/guix/build-system/r.scm @@ -61,7 +61,7 @@ release corresponding to NAME and VERSION." ;; TODO: use %bioconductor-version from (guix import cran) (string-append "https://bioconductor.org/packages/3.11" type-url-part - "/src/contrib/Archive/" + "/src/contrib/" name "_" version ".tar.gz")))) (define %r-build-system-modules 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))))))) diff --git a/guix/channels.scm b/guix/channels.scm index 3eec5df883..bbabf654a9 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -69,7 +69,12 @@ channel-location channel-introduction? - ;; <channel-introduction> accessors purposefully omitted for now. + make-channel-introduction + channel-introduction-first-signed-commit + channel-introduction-first-commit-signer + + openpgp-fingerprint->bytevector + openpgp-fingerprint %default-channels guix-channel? @@ -123,16 +128,36 @@ ;; Channel introductions. A "channel introduction" provides a commit/signer ;; pair that specifies the first commit of the authentication process as well -;; as its signer's fingerprint. The pair must be signed by the signer of that -;; commit so that only them may emit this introduction. Introductions are -;; used to bootstrap trust in a channel. +;; as its signer's fingerprint. Introductions are used to bootstrap trust in +;; a channel. (define-record-type <channel-introduction> - (make-channel-introduction first-signed-commit first-commit-signer - signature) + (%make-channel-introduction first-signed-commit first-commit-signer) channel-introduction? - (first-signed-commit channel-introduction-first-signed-commit) ;hex string - (first-commit-signer channel-introduction-first-commit-signer) ;bytevector - (signature channel-introduction-signature)) ;string + (first-signed-commit channel-introduction-first-signed-commit) ;hex string + (first-commit-signer channel-introduction-first-commit-signer)) ;bytevector + +(define (make-channel-introduction commit signer) + "Return a new channel introduction: COMMIT is the introductory where +authentication starts, and SIGNER is the OpenPGP fingerprint (a bytevector) of +the signer of that commit." + (%make-channel-introduction commit signer)) + +(define (openpgp-fingerprint->bytevector str) + "Convert STR, an OpenPGP fingerprint (hexadecimal string with whitespace), +to the corresponding bytevector." + (base16-string->bytevector + (string-downcase (string-filter char-set:hex-digit str)))) + +(define-syntax openpgp-fingerprint + (lambda (s) + "Convert STR, an OpenPGP fingerprint (hexadecimal string with whitespace), +to the corresponding bytevector." + (syntax-case s () + ((_ str) + (string? (syntax->datum #'str)) + (openpgp-fingerprint->bytevector (syntax->datum #'str))) + ((_ str) + #'(openpgp-fingerprint->bytevector str))))) (define %guix-channel-introduction ;; Introduction of the official 'guix channel. The chosen commit is the @@ -142,11 +167,8 @@ ;; & co. (make-channel-introduction "9edb3f66fd807b096b48283debdcddccfea34bad" ;2020-05-26 - (base16-string->bytevector - (string-downcase - (string-filter char-set:hex-digit ;mbakke - "BBB0 2DDF 2CEA F6A8 0D1D E643 A2A0 6DF2 A33A 54FA"))) - #f)) ;TODO: Add an intro signature so it can be exported. + (openpgp-fingerprint ;mbakke + "BBB0 2DDF 2CEA F6A8 0D1D E643 A2A0 6DF2 A33A 54FA"))) (define %default-channel-url ;; URL of the default 'guix' channel. @@ -201,6 +223,14 @@ introduction, add it." (#f `(branch . ,(channel-branch channel))) (commit `(commit . ,(channel-commit channel))))) +(define sexp->channel-introduction + (match-lambda + (('channel-introduction ('version 0) + ('commit commit) ('signer signer) + _ ...) + (make-channel-introduction commit (openpgp-fingerprint signer))) + (x #f))) + (define (read-channel-metadata port) "Read from PORT channel metadata in the format expected for the '.guix-channel' file. Return a <channel-metadata> record, or raise an error @@ -228,7 +258,9 @@ if valid metadata could not be read from PORT." (name name) (branch branch) (url url) - (commit (get 'commit)))))) + (commit (get 'commit)) + (introduction (and=> (get 'introduction) + sexp->channel-introduction)))))) dependencies) news-file keyring-reference @@ -283,100 +315,44 @@ result is unspecified." (define commit-short-id (compose (cut string-take <> 7) oid->string commit-id)) -(define (verify-introductory-commit repository introduction keyring) - "Raise an exception if the first commit described in INTRODUCTION doesn't -have the expected signer." - (define commit-id - (channel-introduction-first-signed-commit introduction)) - - (define actual-signer - (openpgp-public-key-fingerprint - (commit-signing-key repository (string->oid commit-id) - keyring))) - - (define expected-signer - (channel-introduction-first-commit-signer introduction)) - - (unless (bytevector=? expected-signer actual-signer) - (raise (condition - (&message - (message (format #f (G_ "initial commit ~a is signed by '~a' \ -instead of '~a'") - commit-id - (openpgp-format-fingerprint actual-signer) - (openpgp-format-fingerprint expected-signer)))))))) - (define* (authenticate-channel channel checkout commit #:key (keyring-reference-prefix "origin/")) "Authenticate the given COMMIT of CHANNEL, available at CHECKOUT, a directory containing a CHANNEL checkout. Raise an error if authentication fails." + (define intro + (channel-introduction channel)) + + (define cache-key + (string-append "channels/" (symbol->string (channel-name channel)))) + + (define keyring-reference + (channel-metadata-keyring-reference + (read-channel-metadata-from-source checkout))) + + (define (make-reporter start-commit end-commit commits) + (format (current-error-port) + (G_ "Authenticating channel '~a', commits ~a to ~a (~h new \ +commits)...~%") + (channel-name channel) + (commit-short-id start-commit) + (commit-short-id end-commit) + (length commits)) + + (progress-reporter/bar (length commits))) + ;; XXX: Too bad we need to re-open CHECKOUT. (with-repository checkout repository - (define start-commit - (commit-lookup repository - (string->oid - (channel-introduction-first-signed-commit - (channel-introduction channel))))) - - (define end-commit - (commit-lookup repository (string->oid commit))) - - (define cache-key - (string-append "channels/" (symbol->string (channel-name channel)))) - - (define keyring-reference - (channel-metadata-keyring-reference - (read-channel-metadata-from-source checkout))) - - (define keyring - (load-keyring-from-reference repository - (string-append keyring-reference-prefix - keyring-reference))) - - (define authenticated-commits - ;; Previously-authenticated commits that don't need to be checked again. - (filter-map (lambda (id) - (false-if-exception - (commit-lookup repository (string->oid id)))) - (previously-authenticated-commits cache-key))) - - (define commits - ;; Commits to authenticate, excluding the closure of - ;; AUTHENTICATED-COMMITS. - (commit-difference end-commit start-commit - authenticated-commits)) - - (define reporter - (progress-reporter/bar (length commits))) - - ;; When COMMITS is empty, it's because END-COMMIT is in the closure of - ;; START-COMMIT and/or AUTHENTICATED-COMMITS, in which case it's known to - ;; be authentic already. - (unless (null? commits) - (format (current-error-port) - (G_ "Authenticating channel '~a', \ -commits ~a to ~a (~h new commits)...~%") - (channel-name channel) - (commit-short-id start-commit) - (commit-short-id end-commit) - (length commits)) - - ;; If it's our first time, verify CHANNEL's introductory commit. - (when (null? authenticated-commits) - (verify-introductory-commit repository - (channel-introduction channel) - keyring)) - - (call-with-progress-reporter reporter - (lambda (report) - (authenticate-commits repository commits - #:keyring keyring - #:report-progress report))) - - (cache-authenticated-commit cache-key - (oid->string - (commit-id end-commit)))))) + (authenticate-repository repository + (string->oid + (channel-introduction-first-signed-commit intro)) + (channel-introduction-first-commit-signer intro) + #:end (string->oid commit) + #:keyring-reference + (string-append keyring-reference-prefix + keyring-reference) + #:make-reporter make-reporter + #:cache-key cache-key))) (define* (latest-channel-instance store channel #:key (patches %patches) @@ -406,9 +382,16 @@ their relation. When AUTHENTICATE? is false, CHANNEL is not authenticated." ;; TODO: Warn for all the channels once the authentication interface ;; is public. (when (guix-channel? channel) - (warning (G_ "channel '~a' lacks an introduction and \ -cannot be authenticated~%") - (channel-name channel)))) + (raise (condition + (&message + (message (format #f (G_ "channel '~a' lacks an \ +introduction and cannot be authenticated~%") + (channel-name channel)))) + (&fix-hint + (hint (G_ "Add the missing introduction to your +channels file to address the issue. Alternatively, you can pass +@option{--disable-authentication}, at the risk of running unauthenticated and +thus potentially malicious code."))))))) (warning (G_ "channel authentication disabled~%"))) (when (guix-channel? channel) @@ -822,8 +805,9 @@ derivation." "Return a profile manifest with entries for all of INSTANCES, a list of channel instances." (define (instance->entry instance drv) - (let ((commit (channel-instance-commit instance)) - (channel (channel-instance-channel instance))) + (let* ((commit (channel-instance-commit instance)) + (channel (channel-instance-channel instance)) + (intro (channel-introduction channel))) (manifest-entry (name (symbol->string (channel-name channel))) (version (string-take commit 7)) @@ -838,7 +822,19 @@ channel instances." (version 0) (url ,(channel-url channel)) (branch ,(channel-branch channel)) - (commit ,commit)))))))) + (commit ,commit) + ,@(if intro + `((introduction + (channel-introduction + (version 0) + (commit + ,(channel-introduction-first-signed-commit + intro)) + (signer + ,(openpgp-format-fingerprint + (channel-introduction-first-commit-signer + intro)))))) + '())))))))) (mlet* %store-monad ((derivations (channel-instance-derivations instances)) (entries -> (map instance->entry instances derivations))) @@ -912,11 +908,16 @@ PROFILE is not a profile created by 'guix pull', return the empty list." ('url url) ('branch branch) ('commit commit) - _ ...)) + rest ...)) (channel (name (string->symbol (manifest-entry-name entry))) (url url) - (commit commit))) + (commit commit) + (introduction + (match (assq 'introduction rest) + (#f #f) + (('introduction intro) + (sexp->channel-introduction intro)))))) ;; No channel information for this manifest entry. ;; XXX: Pre-0.15.0 Guix did not provide that information, diff --git a/guix/combinators.scm b/guix/combinators.scm index 4707b59363..88ad09dbe6 100644 --- a/guix/combinators.scm +++ b/guix/combinators.scm @@ -47,7 +47,7 @@ (lambda (result1 result2) (loop result1 result2 (cdr lst))))))) ((proc seed1 seed2 lst1 lst2) - "Like `fold', but with a two lists and two seeds." + "Like `fold', but with two lists and two seeds." (let loop ((result1 seed1) (result2 seed2) (lst1 lst1) diff --git a/guix/cve.scm b/guix/cve.scm index 903d94a8a6..7dd9005f09 100644 --- a/guix/cve.scm +++ b/guix/cve.scm @@ -45,7 +45,7 @@ cve-id cve-data-type cve-data-format - cvs-references + cve-references cve-reference? cve-reference-url @@ -88,7 +88,7 @@ "data_type" string->symbol) (data-format cve-data-format ;'MITRE "data_format" string->symbol) - (references cve-item-references ;list of <cve-reference> + (references cve-references ;list of <cve-reference> "references" reference-data->cve-references)) (define-json-mapping <cve-reference> cve-reference cve-reference? diff --git a/guix/discovery.scm b/guix/discovery.scm index 7c5fed7f0e..b84b9ff370 100644 --- a/guix/discovery.scm +++ b/guix/discovery.scm @@ -153,9 +153,9 @@ SUB-DIRECTORY. Modules are listed in the order they appear on the path." (reverse (fold-modules cons '() path #:warn warn))) (define (fold-module-public-variables* proc init modules) - "Call (PROC MODULE SYMBOL VARIABLE) for each variable exported by one of MODULES, -using INIT as the initial value of RESULT. It is guaranteed to never traverse -the same object twice." + "Call (PROC MODULE SYMBOL VARIABLE RESULT) for each variable exported by one +of MODULES, using INIT as the initial value of RESULT. It is guaranteed to +never traverse the same object twice." ;; Here SEEN is populated by variables; if two different variables refer to ;; the same object, we still let them through. (identity ;discard second return value diff --git a/guix/download.scm b/guix/download.scm index e5df678315..6622e252b4 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013, 2014, 2015 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch> ;;; Copyright © 2016 Alex Griffin <a@ajgrf.com> @@ -94,8 +94,9 @@ "http://mirror.yandex.ru/mirrors/ftp.gnome.org/") (hackage "http://hackage.haskell.org/") - (savannah + (savannah ; http://download0.savannah.gnu.org/mirmon/savannah/ "http://download.savannah.gnu.org/releases/" + "http://nongnu.freemirror.org/nongnu/" "http://ftp.cc.uoc.gr/mirrors/nongnu.org/" "http://ftp.twaren.net/Unix/NonGNU/" "http://mirror.csclub.uwaterloo.ca/nongnu/" @@ -140,7 +141,7 @@ (apache ; from http://www.apache.org/mirrors/dist.html "http://www.eu.apache.org/dist/" "http://www.us.apache.org/dist/" - "http://apache.belnet.be/" + "https://ftp.nluug.nl/internet/apache/" "http://apache.mirror.iweb.ca/" "http://mirrors.ircam.fr/pub/apache/" "http://apache.mirrors.ovh.net/ftp.apache.org/dist/" diff --git a/guix/git-authenticate.scm b/guix/git-authenticate.scm index 082c44ee06..6cfc7fabe1 100644 --- a/guix/git-authenticate.scm +++ b/guix/git-authenticate.scm @@ -18,14 +18,18 @@ (define-module (guix git-authenticate) #:use-module (git) + #:autoload (gcrypt hash) (sha256) #:use-module (guix base16) - #:use-module ((guix git) #:select (false-if-git-not-found)) + #:autoload (guix base64) (base64-encode) + #:use-module ((guix git) + #:select (commit-difference false-if-git-not-found)) #:use-module (guix i18n) #:use-module (guix openpgp) #:use-module ((guix utils) #:select (cache-directory with-atomic-file-output)) #:use-module ((guix build utils) #:select (mkdir-p)) + #:use-module (guix progress) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -44,6 +48,9 @@ previously-authenticated-commits cache-authenticated-commit + repository-cache-key + authenticate-repository + git-authentication-error? git-authentication-error-commit unsigned-commit-error? @@ -139,7 +146,7 @@ for commit ~a") (message (format #f (G_ "could not authenticate \ commit ~a: key ~a is missing") (oid->string commit-id) - data)))))) + (openpgp-format-fingerprint data))))))) ('good-signature data))))))) (define (read-authorizations port) @@ -339,3 +346,95 @@ authenticated (only COMMIT-ID is written to cache, though)." (display ";; List of previously-authenticated commits.\n\n" port) (pretty-print lst port)))))) + + +;;; +;;; High-level interface. +;;; + +(define (repository-cache-key repository) + "Return a unique key to store the authenticate commit cache for REPOSITORY." + (string-append "checkouts/" + (base64-encode + (sha256 (string->utf8 (repository-directory repository)))))) + +(define (verify-introductory-commit repository keyring commit expected-signer) + "Look up COMMIT in REPOSITORY, and raise an exception if it is not signed by +EXPECTED-SIGNER." + (define actual-signer + (openpgp-public-key-fingerprint + (commit-signing-key repository (commit-id commit) keyring))) + + (unless (bytevector=? expected-signer actual-signer) + (raise (condition + (&message + (message (format #f (G_ "initial commit ~a is signed by '~a' \ +instead of '~a'") + (oid->string (commit-id commit)) + (openpgp-format-fingerprint actual-signer) + (openpgp-format-fingerprint expected-signer)))))))) + +(define* (authenticate-repository repository start signer + #:key + (keyring-reference "keyring") + (cache-key (repository-cache-key repository)) + (end (reference-target + (repository-head repository))) + (historical-authorizations '()) + (make-reporter + (const progress-reporter/silent))) + "Authenticate REPOSITORY up to commit END, an OID. Authentication starts +with commit START, an OID, which must be signed by SIGNER; an exception is +raised if that is not the case. Return an alist mapping OpenPGP public keys +to the number of commits signed by that key that have been traversed. + +The OpenPGP keyring is loaded from KEYRING-REFERENCE in REPOSITORY, where +KEYRING-REFERENCE is the name of a branch. The list of authenticated commits +is cached in the authentication cache under CACHE-KEY. + +HISTORICAL-AUTHORIZATIONS must be a list of OpenPGP fingerprints (bytevectors) +denoting the authorized keys for commits whose parent lack the +'.guix-authorizations' file." + (define start-commit + (commit-lookup repository start)) + (define end-commit + (commit-lookup repository end)) + + (define keyring + (load-keyring-from-reference repository keyring-reference)) + + (define authenticated-commits + ;; Previously-authenticated commits that don't need to be checked again. + (filter-map (lambda (id) + (false-if-git-not-found + (commit-lookup repository (string->oid id)))) + (previously-authenticated-commits cache-key))) + + (define commits + ;; Commits to authenticate, excluding the closure of + ;; AUTHENTICATED-COMMITS. + (commit-difference end-commit start-commit + authenticated-commits)) + + ;; When COMMITS is empty, it's because END-COMMIT is in the closure of + ;; START-COMMIT and/or AUTHENTICATED-COMMITS, in which case it's known to + ;; be authentic already. + (if (null? commits) + '() + (let ((reporter (make-reporter start-commit end-commit commits))) + ;; If it's our first time, verify START-COMMIT's signature. + (when (null? authenticated-commits) + (verify-introductory-commit repository keyring + start-commit signer)) + + (let ((stats (call-with-progress-reporter reporter + (lambda (report) + (authenticate-commits repository commits + #:keyring keyring + #:default-authorizations + historical-authorizations + #:report-progress report))))) + (cache-authenticated-commit cache-key + (oid->string (commit-id end-commit))) + + stats)))) diff --git a/guix/git-download.scm b/guix/git-download.scm index a1c1adf760..71ea1031c5 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -140,9 +140,11 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (download-nar #$output) ;; As a last resort, attempt to download from Software Heritage. + ;; Disable X.509 certificate verification to avoid depending + ;; on nss-certs--we're authenticating the checkout anyway. ;; XXX: Currently recursive checkouts are not supported. (and (not recursive?) - (begin + (parameterize ((%verify-swh-certificate? #f)) (format (current-error-port) "Trying to download from Software Heritage...~%") (swh-download (getenv "git url") (getenv "git commit") diff --git a/guix/git.scm b/guix/git.scm index 0d8e617cc9..7f8f9addfb 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -29,6 +29,7 @@ #:use-module (guix records) #:use-module (guix gexp) #:use-module (guix sets) + #:use-module ((guix diagnostics) #:select (leave)) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) #:use-module (srfi srfi-1) @@ -39,6 +40,7 @@ honor-system-x509-certificates! with-repository + with-git-error-handling false-if-git-not-found update-cached-checkout url+commit->name @@ -148,47 +150,52 @@ of SHA1 string." (last (string-split url #\/)) ".git" "") "-" (string-take sha1 7))) +(define (resolve-reference repository ref) + "Resolve the branch, commit or tag specified by REF, and return the +corresponding Git object." + (let resolve ((ref ref)) + (match ref + (('branch . branch) + (let ((oid (reference-target + (branch-lookup repository branch BRANCH-REMOTE)))) + (object-lookup repository oid))) + (('commit . commit) + (let ((len (string-length commit))) + ;; 'object-lookup-prefix' appeared in Guile-Git in Mar. 2018, so we + ;; can't be sure it's available. Furthermore, 'string->oid' used to + ;; read out-of-bounds when passed a string shorter than 40 chars, + ;; which is why we delay calls to it below. + (if (< len 40) + (if (module-defined? (resolve-interface '(git object)) + 'object-lookup-prefix) + (object-lookup-prefix repository (string->oid commit) len) + (raise (condition + (&message + (message "long Git object ID is required"))))) + (object-lookup repository (string->oid commit))))) + (('tag-or-commit . str) + (if (or (> (string-length str) 40) + (not (string-every char-set:hex-digit str))) + (resolve `(tag . ,str)) ;definitely a tag + (catch 'git-error + (lambda () + (resolve `(tag . ,str))) + (lambda _ + ;; There's no such tag, so it must be a commit ID. + (resolve `(commit . ,str)))))) + (('tag . tag) + (let ((oid (reference-name->oid repository + (string-append "refs/tags/" tag)))) + ;; OID may point to a "tag" object, but it can also point directly + ;; to a "commit" object, as surprising as it may seem. Return that + ;; object, whatever that is. + (object-lookup repository oid)))))) + (define (switch-to-ref repository ref) "Switch to REPOSITORY's branch, commit or tag specified by REF. Return the OID (roughly the commit hash) corresponding to REF." (define obj - (let resolve ((ref ref)) - (match ref - (('branch . branch) - (let ((oid (reference-target - (branch-lookup repository branch BRANCH-REMOTE)))) - (object-lookup repository oid))) - (('commit . commit) - (let ((len (string-length commit))) - ;; 'object-lookup-prefix' appeared in Guile-Git in Mar. 2018, so we - ;; can't be sure it's available. Furthermore, 'string->oid' used to - ;; read out-of-bounds when passed a string shorter than 40 chars, - ;; which is why we delay calls to it below. - (if (< len 40) - (if (module-defined? (resolve-interface '(git object)) - 'object-lookup-prefix) - (object-lookup-prefix repository (string->oid commit) len) - (raise (condition - (&message - (message "long Git object ID is required"))))) - (object-lookup repository (string->oid commit))))) - (('tag-or-commit . str) - (if (or (> (string-length str) 40) - (not (string-every char-set:hex-digit str))) - (resolve `(tag . ,str)) ;definitely a tag - (catch 'git-error - (lambda () - (resolve `(tag . ,str))) - (lambda _ - ;; There's no such tag, so it must be a commit ID. - (resolve `(commit . ,str)))))) - (('tag . tag) - (let ((oid (reference-name->oid repository - (string-append "refs/tags/" tag)))) - ;; OID may point to a "tag" object, but it can also point directly - ;; to a "commit" object, as surprising as it may seem. Return that - ;; object, whatever that is. - (object-lookup repository oid)))))) + (resolve-reference repository ref)) (reset repository obj RESET_HARD) (object-id obj)) @@ -209,6 +216,23 @@ dynamic extent of EXP." (call-with-repository directory (lambda (repository) exp ...))) +(define (report-git-error error) + "Report the given Guile-Git error." + ;; Prior to Guile-Git commit b6b2760c2fd6dfaa5c0fedb43eeaff06166b3134, + ;; errors would be represented by integers. + (match error + ((? integer? error) ;old Guile-Git + (leave (G_ "Git error ~a~%") error)) + ((? git-error? error) ;new Guile-Git + (leave (G_ "Git error: ~a~%") (git-error-message error))))) + +(define-syntax-rule (with-git-error-handling body ...) + (catch 'git-error + (lambda () + body ...) + (lambda (key err) + (report-git-error err)))) + (define (load-git-submodules) "Attempt to load (git submodules), which was missing until Guile-Git 0.2.0. Return true on success, false on failure." @@ -268,6 +292,7 @@ definitely available in REPOSITORY, false otherwise." #:key (ref '(branch . "master")) recursive? + (check-out? #t) starting-commit (log-port (%make-void-port "w")) (cache-directory @@ -282,7 +307,10 @@ provided) as returned by 'commit-relation'. REF is pair whose key is [branch | commit | tag | tag-or-commit ] and value the associated data: [<branch name> | <sha1> | <tag name> | <string>]. -When RECURSIVE? is true, check out submodules as well, if any." +When RECURSIVE? is true, check out submodules as well, if any. + +When CHECK-OUT? is true, reset the cached working tree to REF; otherwise leave +it unchanged." (define canonical-ref ;; We used to require callers to specify "origin/" for each branch, which ;; made little sense since the cache should be transparent to them. So @@ -313,7 +341,10 @@ When RECURSIVE? is true, check out submodules as well, if any." ;; Note: call 'commit-relation' from here because it's more efficient ;; than letting users re-open the checkout later on. - (let* ((oid (switch-to-ref repository canonical-ref)) + (let* ((oid (if check-out? + (switch-to-ref repository canonical-ref) + (object-id + (resolve-reference repository canonical-ref)))) (new (and starting-commit (commit-lookup repository oid))) (old (and starting-commit diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index ef067704ad..cd7109002b 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; ;;; This file is part of GNU Guix. @@ -62,6 +62,7 @@ %gnu-updater %gnu-ftp-updater + %savannah-updater %xorg-updater %kernel.org-updater)) @@ -207,14 +208,17 @@ network to check in GNU's database." (member host '("www.gnu.org" "gnu.org")))))) (or (gnu-home-page? package) - (let ((url (and=> (package-source package) origin-uri)) - (name (package-upstream-name package))) - (case (and (string? url) (mirror-type url)) - ((gnu) #t) - ((non-gnu) #f) - (else - (and (member name (map gnu-package-name (official-gnu-packages))) - #t)))))))) + (match (package-source package) + ((? origin? origin) + (let ((url (origin-uri origin)) + (name (package-upstream-name package))) + (case (and (string? url) (mirror-type url)) + ((gnu) #t) + ((non-gnu) #f) + (else + (and (member name (map gnu-package-name (official-gnu-packages))) + #t))))) + (_ #f)))))) ;;; @@ -236,7 +240,7 @@ network to check in GNU's database." (make-regexp "^([^.]+)-([0-9]|[^-])+(-(src|gnu[0-9]))?\\.(tar\\.|zip$)")) (define %alpha-tarball-rx - (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|cvs|svn|git)-?[0-9\\.]*\\.tar\\.")) + (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|RC|cvs|svn|git)-?[0-9\\.]*\\.tar\\.")) (define (release-file? project file) "Return #f if FILE is not a release tarball of PROJECT, otherwise return @@ -494,9 +498,8 @@ return the corresponding signature URL, or #f it signatures are unavailable." (version version) (urls (list (string-append base-url directory "/" url))) (signature-urls - (list (string-append base-url directory "/" - (file-sans-extension url) - ".sign"))))))) + (list (file->signature + (string-append base-url directory "/" url)))))))) (define candidates (filter-map url->release (html-links sxml))) @@ -612,8 +615,51 @@ releases are on gnu.org." (define gnu-hosted? (url-prefix-predicate "mirror://gnu/")) +(define (url-prefix-rewrite old new) + "Return a one-argument procedure that rewrites URL prefix OLD to NEW." + (lambda (url) + (if (string-prefix? old url) + (string-append new (string-drop url (string-length old))) + url))) + +(define (adjusted-upstream-source source rewrite-url) + "Rewrite URLs in SOURCE by apply REWRITE-URL to each of them." + (upstream-source + (inherit source) + (urls (map rewrite-url (upstream-source-urls source))) + (signature-urls (and=> (upstream-source-signature-urls source) + (lambda (urls) + (map rewrite-url urls)))))) + +(define savannah-package? + (url-prefix-predicate "mirror://savannah/")) + +(define %savannah-base + ;; One of the Savannah mirrors listed at + ;; <http://download0.savannah.gnu.org/mirmon/savannah/> that serves valid + ;; HTML (unlike <https://download.savannah.nongnu.org/releases>.) + "https://nongnu.freemirror.org/nongnu") + +(define (latest-savannah-release package) + "Return the latest release of PACKAGE." + (let* ((uri (string->uri + (match (origin-uri (package-source package)) + ((? string? uri) uri) + ((uri mirrors ...) uri)))) + (package (package-upstream-name package)) + (directory (dirname (uri-path uri))) + (rewrite (url-prefix-rewrite %savannah-base + "mirror://savannah"))) + ;; Note: We use the default 'file->signature', which adds ".sig", but not + ;; all projects on Savannah follow that convention: some use ".asc" and + ;; perhaps some lack signatures altogether. + (and=> (latest-html-release package + #:base-url %savannah-base + #:directory directory) + (cut adjusted-upstream-source <> rewrite)))) + (define (latest-xorg-release package) - "Return the latest release of PACKAGE, the name of an X.org package." + "Return the latest release of PACKAGE." (let ((uri (string->uri (origin-uri (package-source package))))) (false-if-ftp-error (latest-ftp-release @@ -632,13 +678,19 @@ releases are on gnu.org." (define (file->signature file) (string-append (file-sans-extension file) ".sign")) - (let* ((uri (string->uri (origin-uri (package-source package)))) + (let* ((uri (string->uri + (match (origin-uri (package-source package)) + ((? string? uri) uri) + ((uri mirrors ...) uri)))) (package (package-upstream-name package)) - (directory (dirname (uri-path uri)))) - (latest-html-release package - #:base-url %kernel.org-base - #:directory directory - #:file->signature file->signature))) + (directory (dirname (uri-path uri))) + (rewrite (url-prefix-rewrite %kernel.org-base + "mirror://kernel.org"))) + (and=> (latest-html-release package + #:base-url %kernel.org-base + #:directory directory + #:file->signature file->signature) + (cut adjusted-upstream-source <> rewrite)))) (define %gnu-updater ;; This is for everything at ftp.gnu.org. @@ -659,6 +711,13 @@ releases are on gnu.org." (pure-gnu-package? package)))) (latest latest-release*))) +(define %savannah-updater + (upstream-updater + (name 'savannah) + (description "Updater for packages hosted on savannah.gnu.org") + (pred (url-prefix-predicate "mirror://savannah/")) + (latest latest-savannah-release))) + (define %xorg-updater (upstream-updater (name 'xorg) diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm index 6bcd2ce9eb..085467b871 100644 --- a/guix/import/cpan.scm +++ b/guix/import/cpan.scm @@ -316,25 +316,13 @@ in RELEASE, a <cpan-release> record." (let ((release (cpan-fetch (module->name module-name)))) (and=> release cpan-module->sexp))) -(define (cpan-package? package) - "Return #t if PACKAGE is a package from CPAN." - (define cpan-url? - (let ((cpan-rx (make-regexp (string-append "(" - "mirror://cpan" "|" - "https?://www.cpan.org" "|" - "https?://cpan.metacpan.org" - ")")))) - (lambda (url) - (regexp-exec cpan-rx url)))) - - (let ((source-url (and=> (package-source package) origin-uri)) - (fetch-method (and=> (package-source package) origin-method))) - (and (eq? fetch-method url-fetch) - (match source-url - ((? string?) - (cpan-url? source-url)) - ((source-url ...) - (any cpan-url? source-url)))))) +(define cpan-package? + (let ((cpan-rx (make-regexp (string-append "(" + "mirror://cpan" "|" + "https?://www.cpan.org" "|" + "https?://cpan.metacpan.org" + ")")))) + (url-predicate (cut regexp-exec cpan-rx <>)))) (define (latest-release package) "Return an <upstream-source> for the latest release of PACKAGE." diff --git a/guix/import/cran.scm b/guix/import/cran.scm index b822fbc0ae..a1275b4822 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -661,12 +661,7 @@ s-expression corresponding to that package, or #f on failure." ;; Check if the upstream name can be extracted from package uri. (package->upstream-name package) ;; Check if package uri(s) are prefixed by "mirror://cran". - (match (and=> (package-source package) origin-uri) - ((? string? uri) - (string-prefix? "mirror://cran" uri)) - ((? list? uris) - (any (cut string-prefix? "mirror://cran" <>) uris)) - (_ #f)))) + ((url-predicate (cut string-prefix? "mirror://cran" <>)) package))) (define (bioconductor-package? package) "Return true if PACKAGE is an R package from Bioconductor." @@ -680,12 +675,7 @@ s-expression corresponding to that package, or #f on failure." ;; Experiment packages are in a separate repository. (not (string-contains uri "/data/experiment/")))))) (and (string-prefix? "r-" (package-name package)) - (match (and=> (package-source package) origin-uri) - ((? string? uri) - (predicate uri)) - ((? list? uris) - (any predicate uris)) - (_ #f))))) + ((url-predicate predicate) package)))) (define (bioconductor-data-package? package) "Return true if PACKAGE is an R data package from Bioconductor." @@ -693,12 +683,7 @@ s-expression corresponding to that package, or #f on failure." (and (string-prefix? "https://bioconductor.org" uri) (string-contains uri "/data/annotation/"))))) (and (string-prefix? "r-" (package-name package)) - (match (and=> (package-source package) origin-uri) - ((? string? uri) - (predicate uri)) - ((? list? uris) - (any predicate uris)) - (_ #f))))) + ((url-predicate predicate) package)))) (define (bioconductor-experiment-package? package) "Return true if PACKAGE is an R experiment package from Bioconductor." @@ -706,12 +691,7 @@ s-expression corresponding to that package, or #f on failure." (and (string-prefix? "https://bioconductor.org" uri) (string-contains uri "/data/experiment/"))))) (and (string-prefix? "r-" (package-name package)) - (match (and=> (package-source package) origin-uri) - ((? string? uri) - (predicate uri)) - ((? list? uris) - (any predicate uris)) - (_ #f))))) + ((url-predicate predicate) package)))) (define %cran-updater (upstream-updater diff --git a/guix/import/crate.scm b/guix/import/crate.scm index e3ec11d7f8..796a7641e9 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -262,16 +262,8 @@ latest version of CRATE-NAME." ;;; Updater ;;; -(define (crate-package? package) - "Return true if PACKAGE is a Rust crate from crates.io." - (let ((source-url (and=> (package-source package) origin-uri)) - (fetch-method (and=> (package-source package) origin-method))) - (and (eq? fetch-method download:url-fetch) - (match source-url - ((? string?) - (crate-url? source-url)) - ((source-url ...) - (any crate-url? source-url)))))) +(define crate-package? + (url-predicate crate-url?)) (define (latest-release package) "Return an <upstream-source> for the latest release of PACKAGE." diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm index 2d4487dba0..871b918f88 100644 --- a/guix/import/elpa.scm +++ b/guix/import/elpa.scm @@ -281,13 +281,11 @@ type '<elpa-package>'." (urls (list url)) (signature-urls (list (string-append url ".sig")))))) -(define (package-from-gnu.org? package) - "Return true if PACKAGE is from elpa.gnu.org." - (match (and=> (package-source package) origin-uri) - ((? string? uri) - (let ((uri (string->uri uri))) - (and uri (string=? (uri-host uri) "elpa.gnu.org")))) - (_ #f))) +(define package-from-gnu.org? + (url-predicate (lambda (url) + (let ((uri (string->uri url))) + (and uri + (string=? (uri-host uri) "elpa.gnu.org")))))) (define %elpa-updater ;; The ELPA updater. We restrict it to packages hosted on elpa.gnu.org diff --git a/guix/import/gem.scm b/guix/import/gem.scm index bd5d5b3569..a2d99ddbca 100644 --- a/guix/import/gem.scm +++ b/guix/import/gem.scm @@ -166,20 +166,8 @@ package on RubyGems." ((or "Apache License, Version 2.0" "Apache 2.0") license:asl2.0) (_ #f))) -(define (gem-package? package) - "Return true if PACKAGE is a gem package from RubyGems." - - (define (rubygems-url? url) - (string-prefix? "https://rubygems.org/downloads/" url)) - - (let ((source-url (and=> (package-source package) origin-uri)) - (fetch-method (and=> (package-source package) origin-method))) - (and (eq? fetch-method download:url-fetch) - (match source-url - ((? string?) - (rubygems-url? source-url)) - ((source-url ...) - (any rubygems-url? source-url)))))) +(define gem-package? + (url-prefix-predicate "https://rubygems.org/downloads/")) (define (latest-release package) "Return an <upstream-source> for the latest release of PACKAGE." diff --git a/guix/import/github.scm b/guix/import/github.scm index 7136e7a34f..888b148ffb 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com> -;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net> ;;; Copyright © 2019 Efraim Flashner <efraim@flashner.co.il> @@ -26,10 +26,13 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (guix utils) + #:use-module (guix i18n) + #:use-module (guix diagnostics) #:use-module ((guix download) #:prefix download:) #:use-module ((guix git-download) #:prefix download:) #:use-module (guix import utils) #:use-module (guix import json) + #:use-module (json) #:use-module (guix packages) #:use-module (guix upstream) #:use-module (guix http-client) @@ -90,20 +93,23 @@ false if none is recognized" (#t #f))) ; Some URLs are not recognised. #f)) - (let ((source-uri (and=> (package-source old-package) origin-uri)) - (fetch-method (and=> (package-source old-package) origin-method))) - (cond - ((eq? fetch-method download:url-fetch) - (match source-uri - ((? string?) - (updated-url source-uri)) - ((source-uri ...) - (find updated-url source-uri)))) - ((and (eq? fetch-method download:git-fetch) - (string-prefix? "https://github.com/" - (download:git-reference-url source-uri))) - (download:git-reference-url source-uri)) - (else #f)))) + (match (package-source old-package) + ((? origin? origin) + (let ((source-uri (origin-uri origin)) + (fetch-method (origin-method origin))) + (cond + ((eq? fetch-method download:url-fetch) + (match source-uri + ((? string?) + (updated-url source-uri)) + ((source-uri ...) + (find updated-url source-uri)))) + ((and (eq? fetch-method download:git-fetch) + (string-prefix? "https://github.com/" + (download:git-reference-url source-uri))) + (download:git-reference-url source-uri)) + (else #f)))) + (_ #f))) (define (github-package? package) "Return true if PACKAGE is a package from GitHub, else false." @@ -159,12 +165,20 @@ empty list." `((Authorization . ,(string-append "token " (%github-token)))) '()))) - (match (json-fetch release-url #:headers headers) - (#() - ;; We got the empty list, presumably because the user didn't use GitHub's - ;; "release" mechanism, but hopefully they did use Git tags. - (json-fetch tag-url #:headers headers)) - (x x))) + (guard (c ((and (http-get-error? c) + (= 404 (http-get-error-code c))) + (warning (G_ "~a is unreachable (~a)~%") + release-url (http-get-error-code c)) + '#())) ;return an empty release set + (let* ((port (http-fetch release-url #:headers headers)) + (result (json->scm port))) + (close-port port) + (match result + (#() + ;; We got the empty list, presumably because the user didn't use GitHub's + ;; "release" mechanism, but hopefully they did use Git tags. + (json-fetch tag-url #:headers headers)) + (x x))))) (define (latest-released-version url package-name) "Return a string of the newest released version name given a string URL like diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index dbc1afa4a7..35c67cad8d 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -346,22 +346,9 @@ respectively." (cons name args))) #:guix-name hackage-name->package-name)) -(define (hackage-package? package) - "Return #t if PACKAGE is a Haskell package from Hackage." - - (define haskell-url? - (let ((hackage-rx (make-regexp "https?://hackage.haskell.org"))) - (lambda (url) - (regexp-exec hackage-rx url)))) - - (let ((source-url (and=> (package-source package) origin-uri)) - (fetch-method (and=> (package-source package) origin-method))) - (and (eq? fetch-method url-fetch) - (match source-url - ((? string?) - (haskell-url? source-url)) - ((source-url ...) - (any haskell-url? source-url)))))) +(define hackage-package? + (let ((hackage-rx (make-regexp "https?://hackage.haskell.org"))) + (url-predicate (cut regexp-exec hackage-rx <>)))) (define (latest-release package) "Return an <upstream-source> for the latest release of PACKAGE." diff --git a/guix/import/launchpad.scm b/guix/import/launchpad.scm index 1a15f28077..c7375837c7 100644 --- a/guix/import/launchpad.scm +++ b/guix/import/launchpad.scm @@ -57,16 +57,17 @@ false if none is recognized" "/" new-version "/+download/" repo "-" new-version ext)) (#t #f))))) ; Some URLs are not recognised. - (let ((source-uri (and=> (package-source old-package) origin-uri)) - (fetch-method (and=> (package-source old-package) origin-method))) - (cond - ((eq? fetch-method download:url-fetch) - (match source-uri - ((? string?) - (updated-url source-uri)) - ((source-uri ...) - (find updated-url source-uri)))) - (else #f)))) + (match (package-source old-package) + ((? origin? origin) + (let ((source-uri (origin-uri origin)) + (fetch-method (origin-method origin))) + (and (eq? fetch-method download:url-fetch) + (match source-uri + ((? string?) + (updated-url source-uri)) + ((source-uri ...) + (find updated-url source-uri)))))) + (_ #f))) (define (launchpad-package? package) "Return true if PACKAGE is a package from Launchpad, else false." diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index f93fa8831f..a2b5d995ef 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -7,6 +7,7 @@ ;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> ;;; Copyright © 2020 Lars-Dominik Braun <ldb@leibniz-psychology.org> +;;; Copyright © 2020 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -63,7 +64,7 @@ (match-lambda ("" #f) ((? string? str) str) - ((or #nil #f) #f))) + ((or 'null #f) #f))) ;; PyPI project. (define-json-mapping <pypi-project> make-pypi-project pypi-project? @@ -510,23 +511,13 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." ("MPL 2.0" license:mpl2.0) (_ #f))) -(define (pypi-package? package) - "Return true if PACKAGE is a Python package from PyPI." - - (define (pypi-url? url) - (or (string-prefix? "https://pypi.org/" url) - (string-prefix? "https://pypi.python.org/" url) - (string-prefix? "https://pypi.org/packages" url) - (string-prefix? "https://files.pythonhosted.org/packages" url))) - - (let ((source-url (and=> (package-source package) origin-uri)) - (fetch-method (and=> (package-source package) origin-method))) - (and (eq? fetch-method download:url-fetch) - (match source-url - ((? string?) - (pypi-url? source-url)) - ((source-url ...) - (any pypi-url? source-url)))))) +(define pypi-package? + (url-predicate + (lambda (url) + (or (string-prefix? "https://pypi.org/" url) + (string-prefix? "https://pypi.python.org/" url) + (string-prefix? "https://pypi.org/packages" url) + (string-prefix? "https://files.pythonhosted.org/packages" url))))) (define (latest-release package) "Return an <upstream-source> for the latest release of PACKAGE." diff --git a/guix/json.scm b/guix/json.scm index 20f0bd8f13..3e3a28b749 100644 --- a/guix/json.scm +++ b/guix/json.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,15 +18,33 @@ (define-module (guix json) #:use-module (json) - #:use-module (srfi srfi-9) - #:export (define-json-mapping)) + #:use-module (srfi srfi-9)) ;;; Commentary: ;;; ;;; Helpers to map JSON objects to SRFI-9 records. Taken from (guix swh). +;;; This module is superseded by 'define-json-mapping' as found since version +;;; 4.2.0 of Guile-JSON and will be removed once migration is complete. ;;; ;;; Code: +(define-syntax define-as-needed + (lambda (s) + "Define the given syntax rule unless (json) already provides it." + (syntax-case s () + ((_ (macro args ...) body ...) + (if (module-defined? (resolve-interface '(json)) + (syntax->datum #'macro)) + #'(eval-when (expand load eval) + ;; Re-export MACRO from (json). + (module-re-export! (current-module) '(macro))) + #'(begin + ;; Using Guile-JSON < 4.2.0, so provide our own MACRO. + (define-syntax-rule (macro args ...) + body ...) + (eval-when (expand load eval) + (module-export! (current-module) '(macro))))))))) + (define-syntax-rule (define-json-reader json->record ctor spec ...) "Define JSON->RECORD as a procedure that converts a JSON representation, read from a port, string, or hash table, into a record created by CTOR and @@ -48,8 +66,11 @@ following SPEC, a series of field specifications." (symbol->string 'field)))))) (ctor (extract-field table spec) ...))))) -(define-syntax-rule (define-json-mapping rtd ctor pred json->record - (field getter spec ...) ...) +;; For some reason we cannot just have colliding definitions of +;; 'define-json-mapping' (that leads to a build failure in users of this +;; module), hence the use of 'define-as-needed'. +(define-as-needed (define-json-mapping rtd ctor pred json->record + (field getter spec ...) ...) "Define RTD as a record type with the given FIELDs and GETTERs, à la SRFI-9, and define JSON->RECORD as a conversion from JSON to a record of this type." (begin diff --git a/guix/lint.scm b/guix/lint.scm index fa507546f5..e7855678ca 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -670,8 +670,9 @@ patch could not be found." (%make-warning package (condition-message c) #:field 'patch-file-names)))) (define patches - (or (and=> (package-source package) origin-patches) - '())) + (match (package-source package) + ((? origin? origin) (origin-patches origin)) + (_ '()))) (define (starts-with-package-name? file-name) (and=> (string-contains file-name (package-name package)) @@ -792,26 +793,32 @@ descriptions maintained upstream." (loop rest (cons warning warnings)))))))) (let ((origin (package-source package))) - (if (and origin - (eqv? (origin-method origin) url-fetch)) - (let* ((uris (append-map (cut maybe-expand-mirrors <> %mirrors) - (map string->uri (origin-uris origin)))) - (warnings (warnings-for-uris uris))) - - ;; Just make sure that at least one of the URIs is valid. - (if (= (length uris) (length warnings)) - ;; When everything fails, report all of WARNINGS, otherwise don't - ;; report anything. - ;; - ;; XXX: Ideally we'd still allow warnings to be raised if *some* - ;; URIs are unreachable, but distinguish that from the error case - ;; where *all* the URIs are unreachable. - (cons* - (make-warning package - (G_ "all the source URIs are unreachable:") - #:field 'source) - warnings) - '())) + (if (origin? origin) + (cond + ((eq? (origin-method origin) url-fetch) + (let* ((uris (append-map (cut maybe-expand-mirrors <> %mirrors) + (map string->uri (origin-uris origin)))) + (warnings (warnings-for-uris uris))) + + ;; Just make sure that at least one of the URIs is valid. + (if (= (length uris) (length warnings)) + ;; When everything fails, report all of WARNINGS, otherwise don't + ;; report anything. + ;; + ;; XXX: Ideally we'd still allow warnings to be raised if *some* + ;; URIs are unreachable, but distinguish that from the error case + ;; where *all* the URIs are unreachable. + (cons* + (make-warning package + (G_ "all the source URIs are unreachable:") + #:field 'source) + warnings) + '()))) + ((git-reference? (origin-uri origin)) + (warnings-for-uris + (list (string->uri (git-reference-url (origin-uri origin)))))) + (else + '())) '()))) (define (check-source-file-name package) @@ -828,7 +835,7 @@ descriptions maintained upstream." (not (string-match (string-append "^v?" version) file-name))))) (let ((origin (package-source package))) - (if (or (not origin) (origin-file-name-valid? origin)) + (if (or (not (origin? origin)) (origin-file-name-valid? origin)) '() (list (make-warning package @@ -1208,7 +1215,7 @@ Heritage") '()))) '())))) (match-lambda* - ((key url method response) + (('swh-error url method response) (response->warning url method response)) ((key . args) (if (eq? key skip-key) diff --git a/guix/packages.scm b/guix/packages.scm index 1e0ec41b76..95d7c2cc0d 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -191,7 +191,10 @@ its first argument has the right size for the chosen algorithm." (define-content-hash-constructor build-content-hash (sha256 32) - (sha512 64)) + (sha512 64) + (sha3-256 32) + (sha3-512 64) + (blake2s-256 64)) (define-syntax content-hash (lambda (s) @@ -920,22 +923,26 @@ dependencies are known to build on SYSTEM." (define (bag-transitive-inputs bag) "Same as 'package-transitive-inputs', but applied to a bag." - (parameterize ((%current-target-system #f)) + (parameterize ((%current-target-system #f) + (%current-system (bag-system bag))) (transitive-inputs (bag-direct-inputs bag)))) (define (bag-transitive-build-inputs bag) "Same as 'package-transitive-native-inputs', but applied to a bag." - (parameterize ((%current-target-system #f)) + (parameterize ((%current-target-system #f) + (%current-system (bag-system bag))) (transitive-inputs (bag-build-inputs bag)))) (define (bag-transitive-host-inputs bag) "Same as 'package-transitive-target-inputs', but applied to a bag." - (parameterize ((%current-target-system (bag-target bag))) + (parameterize ((%current-target-system (bag-target bag)) + (%current-system (bag-system bag))) (transitive-inputs (bag-host-inputs bag)))) (define (bag-transitive-target-inputs bag) "Return the \"target inputs\" of BAG, recursively." - (parameterize ((%current-target-system (bag-target bag))) + (parameterize ((%current-target-system (bag-target bag)) + (%current-system (bag-system bag))) (transitive-inputs (bag-target-inputs bag)))) (define* (package-closure packages #:key (system (%current-system))) diff --git a/guix/quirks.scm b/guix/quirks.scm index d292f4e932..1cffe971fc 100644 --- a/guix/quirks.scm +++ b/guix/quirks.scm @@ -139,18 +139,30 @@ corresponds to the given Guix COMMIT, a SHA1 hexadecimal string." (define (accesses-guile-2.2-optimization-options? source commit) (catch 'system-error (lambda () - (match (call-with-input-file - (string-append source "/guix/build/compile.scm") - read) - (('define-module ('guix 'build 'compile) - _ ... - #:use-module ('language 'tree-il 'optimize) - #:use-module ('language 'cps 'optimize) - #:export ('%default-optimizations - '%lightweight-optimizations - 'compile-files)) - #t) - (_ #f))) + (call-with-input-file (string-append source + "/guix/build/compile.scm") + (lambda (port) + (match (read port) + (('define-module ('guix 'build 'compile) + _ ... + #:use-module ('language 'tree-il 'optimize) + #:use-module ('language 'cps 'optimize) + #:export ('%default-optimizations + '%lightweight-optimizations + 'compile-files)) + #t) + (_ + ;; Before v1.0.0 (ca. Dec. 2018), the 'use-modules' form + ;; would show up in a subsequent 'cond-expand' clause. + ;; See <https://bugs.gnu.org/42519>. + (match (read port) + (('cond-expand + ('guile-2.2 ('use-modules ('language 'tree-il 'optimize) + _ ...)) + _ ...) + #t) + (_ + #f))))))) (const #f))) (define (build-with-guile-2.2 source) diff --git a/guix/remote.scm b/guix/remote.scm index c00585de74..a227540728 100644 --- a/guix/remote.scm +++ b/guix/remote.scm @@ -31,6 +31,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (ice-9 format) #:use-module (ice-9 match) #:export (remote-eval)) diff --git a/guix/scripts.scm b/guix/scripts.scm index 3e19e38957..8534948892 100644 --- a/guix/scripts.scm +++ b/guix/scripts.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Deck Pickard <deck.r.pickard@gmail.com> ;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com> +;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -49,12 +50,12 @@ ;;; ;;; Code: -(define (args-fold* options unrecognized-option-proc operand-proc . seeds) +(define (args-fold* args options unrecognized-option-proc operand-proc . seeds) "A wrapper on top of `args-fold' that does proper user-facing error reporting." (catch 'misc-error (lambda () - (apply args-fold options unrecognized-option-proc + (apply args-fold args options unrecognized-option-proc operand-proc seeds)) (lambda (key proc msg args . rest) ;; XXX: MSG is not i18n'd. diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index ea982955da..bc868ffbbf 100644 --- a/guix/scripts/describe.scm +++ b/guix/scripts/describe.scm @@ -26,9 +26,11 @@ #:use-module (guix scripts) #:use-module (guix describe) #:use-module (guix profiles) + #:autoload (guix openpgp) (openpgp-format-fingerprint) #:use-module (git) #:use-module (json) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:use-module (ice-9 format) @@ -43,7 +45,8 @@ ;;; ;;; Command-line options. ;;; -(define %available-formats '("human" "channels" "json" "recutils")) +(define %available-formats + '("human" "channels" "channels-sans-intro" "json" "recutils")) (define (list-formats) (display (G_ "The available formats are:\n")) @@ -110,21 +113,50 @@ Display information about the channels currently in use.\n")) (_ (warning (G_ "'GUIX_PACKAGE_PATH' is set but it is not captured~%"))))))) -(define (channel->sexp channel) - `(channel - (name ',(channel-name channel)) - (url ,(channel-url channel)) - (commit ,(channel-commit channel)))) +(define* (channel->sexp channel #:key (include-introduction? #t)) + (let ((intro (and include-introduction? + (channel-introduction channel)))) + `(channel + (name ',(channel-name channel)) + (url ,(channel-url channel)) + (commit ,(channel-commit channel)) + ,@(if intro + `((introduction (make-channel-introduction + ,(channel-introduction-first-signed-commit intro) + (openpgp-fingerprint + ,(openpgp-format-fingerprint + (channel-introduction-first-commit-signer + intro)))))) + '())))) (define (channel->json channel) - (scm->json-string `((name . ,(channel-name channel)) - (url . ,(channel-url channel)) - (commit . ,(channel-commit channel))))) + (scm->json-string + (let ((intro (channel-introduction channel))) + `((name . ,(channel-name channel)) + (url . ,(channel-url channel)) + (commit . ,(channel-commit channel)) + ,@(if intro + `((introduction + . ((commit . ,(channel-introduction-first-signed-commit + intro)) + (signer . ,(openpgp-format-fingerprint + (channel-introduction-first-commit-signer + intro)))))) + '()))))) (define (channel->recutils channel port) + (define intro + (channel-introduction channel)) + (format port "name: ~a~%" (channel-name channel)) (format port "url: ~a~%" (channel-url channel)) - (format port "commit: ~a~%" (channel-commit channel))) + (format port "commit: ~a~%" (channel-commit channel)) + (when intro + (format port "introductioncommit: ~a~%" + (channel-introduction-first-signed-commit intro)) + (format port "introductionsigner: ~a~%" + (openpgp-format-fingerprint + (channel-introduction-first-commit-signer intro))))) (define (display-checkout-info fmt) "Display information about the current checkout according to FMT, a symbol @@ -182,6 +214,10 @@ in the format specified by FMT." (display-profile-content profile number)) ('channels (pretty-print `(list ,@(map channel->sexp channels)))) + ('channels-sans-intro + (pretty-print `(list ,@(map (cut channel->sexp <> + #:include-introduction? #f) + channels)))) ('json (format #t "[~a]~%" (string-join (map channel->json channels) ","))) ('recutils diff --git a/guix/scripts/git.scm b/guix/scripts/git.scm new file mode 100644 index 0000000000..bc829cbe99 --- /dev/null +++ b/guix/scripts/git.scm @@ -0,0 +1,63 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org> +;;; +;;; 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 scripts git) + #:use-module (ice-9 match) + #:use-module (guix ui) + #:export (guix-git)) + +(define (show-help) + (display (G_ "Usage: guix git COMMAND ARGS... +Operate on Git repositories.\n")) + (newline) + (display (G_ "The valid values for ACTION are:\n")) + (newline) + (display (G_ "\ + authenticate verify commit signatures and authorizations\n")) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %sub-commands '("authenticate")) + +(define (resolve-sub-command name) + (let ((module (resolve-interface + `(guix scripts git ,(string->symbol name)))) + (proc (string->symbol (string-append "guix-git-" name)))) + (module-ref module proc))) + +(define (guix-git . args) + (with-error-handling + (match args + (() + (format (current-error-port) + (G_ "guix git: missing sub-command~%"))) + ((or ("-h") ("--help")) + (show-help) + (exit 0)) + ((or ("-V") ("--version")) + (show-version-and-exit "guix git")) + ((sub-command args ...) + (if (member sub-command %sub-commands) + (apply (resolve-sub-command sub-command) args) + (format (current-error-port) + (G_ "guix git: invalid sub-command~%"))))))) diff --git a/guix/scripts/git/authenticate.scm b/guix/scripts/git/authenticate.scm new file mode 100644 index 0000000000..5f5d423f28 --- /dev/null +++ b/guix/scripts/git/authenticate.scm @@ -0,0 +1,179 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org> +;;; +;;; 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 scripts git authenticate) + #:use-module (git) + #:use-module (guix ui) + #:use-module (guix scripts) + #:use-module (guix git-authenticate) + #:autoload (guix openpgp) (openpgp-format-fingerprint + openpgp-public-key-fingerprint) + #:use-module ((guix channels) #:select (openpgp-fingerprint)) + #:use-module ((guix git) #:select (with-git-error-handling)) + #:use-module (guix progress) + #:use-module (guix base64) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:export (guix-git-authenticate)) + +;;; Commentary: +;;; +;;; Authenticate a Git checkout by reading '.guix-authorizations' files and +;;; following the "authorizations invariant" also used by (guix channels). +;;; +;;; Code: + +(define %options + ;; Specifications of the command-line options. + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix git authenticate"))) + + (option '(#\r "repository") #t #f + (lambda (opt name arg result) + (alist-cons 'directory arg result))) + (option '(#\e "end") #t #f + (lambda (opt name arg result) + (alist-cons 'end-commit (string->oid arg) result))) + (option '(#\k "keyring") #t #f + (lambda (opt name arg result) + (alist-cons 'keyring-reference arg result))) + (option '("cache-key") #t #f + (lambda (opt name arg result) + (alist-cons 'cache-key arg result))) + (option '("historical-authorizations") #t #f + (lambda (opt name arg result) + (alist-cons 'historical-authorizations arg + result))) + (option '("stats") #f #f + (lambda (opt name arg result) + (alist-cons 'show-stats? #t result))))) + +(define %default-options + '((directory . ".") + (keyring-reference . "keyring"))) + +(define (show-stats stats) + "Display STATS, an alist containing commit signing stats as returned by +'authenticate-repository'." + (format #t (G_ "Signing statistics:~%")) + (for-each (match-lambda + ((signer . count) + (format #t " ~a ~10d~%" + (openpgp-format-fingerprint + (openpgp-public-key-fingerprint signer)) + count))) + (sort stats + (match-lambda* + (((_ . count1) (_ . count2)) + (> count1 count2)))))) + +(define (show-help) + (display (G_ "Usage: guix git authenticate COMMIT SIGNER [OPTIONS...] +Authenticate the given Git checkout using COMMIT/SIGNER as its introduction.\n")) + (display (G_ " + -r, --repository=DIRECTORY + open the Git repository at DIRECTORY")) + (display (G_ " + -k, --keyring=REFERENCE + load keyring from REFERENCE, a Git branch")) + (display (G_ " + --stats display commit signing statistics upon completion")) + (display (G_ " + --cache-key=KEY cache authenticated commits under KEY")) + (display (G_ " + --historical-authorizations=FILE + read historical authorizations from FILE")) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + + +;;; +;;; Entry point. +;;; + +(define (guix-git-authenticate . args) + (define options + (parse-command-line args %options (list %default-options) + #:build-options? #f)) + + (define (command-line-arguments lst) + (reverse (filter-map (match-lambda + (('argument . arg) arg) + (_ #f)) + lst))) + + (define commit-short-id + (compose (cut string-take <> 7) oid->string commit-id)) + + (define (make-reporter start-commit end-commit commits) + (format (current-error-port) + (G_ "Authenticating commits ~a to ~a (~h new \ +commits)...~%") + (commit-short-id start-commit) + (commit-short-id end-commit) + (length commits)) + + (if (isatty? (current-error-port)) + (progress-reporter/bar (length commits)) + progress-reporter/silent)) + + (with-error-handling + (with-git-error-handling + (match (command-line-arguments options) + ((commit signer) + (let* ((directory (assoc-ref options 'directory)) + (show-stats? (assoc-ref options 'show-stats?)) + (keyring (assoc-ref options 'keyring-reference)) + (repository (repository-open directory)) + (end (match (assoc-ref options 'end-commit) + (#f (reference-target + (repository-head repository))) + (oid oid))) + (history (match (assoc-ref options 'historical-authorizations) + (#f '()) + (file (call-with-input-file file + read-authorizations)))) + (cache-key (or (assoc-ref options 'cache-key) + (repository-cache-key repository)))) + (define stats + (authenticate-repository repository (string->oid commit) + (openpgp-fingerprint signer) + #:end end + #:keyring-reference keyring + #:historical-authorizations history + #:cache-key cache-key + #:make-reporter make-reporter)) + + (when (and show-stats? (not (null? stats))) + (show-stats stats)))) + (_ + (leave (G_ "wrong number of arguments; \ +expected COMMIT and SIGNER~%"))))))) diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 1d5db3b3cb..489931d5bb 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -43,6 +43,7 @@ #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) + #:use-module (ice-9 format) #:use-module (ice-9 match) #:export (%package-node-type %reverse-package-node-type diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index e0f9cc1a12..5fb6aaae0c 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -149,6 +149,11 @@ dependencies are registered." (define db-file (store-database-file #:state-directory #$output)) + ;; Make sure non-ASCII file names are properly handled. + (setenv "GUIX_LOCPATH" + #+(file-append glibc-utf8-locales "/lib/locale")) + (setlocale LC_ALL "en_US.utf8") + (sql-schema #$schema) (let ((items (append-map read-closure '#$labels))) (with-database db-file db @@ -181,6 +186,15 @@ added to the pack." (file-append (store-database (list profile)) "/db/db.sqlite"))) + (define set-utf8-locale + ;; Arrange to not depend on 'glibc-utf8-locales' when using '--bootstrap'. + (and (or (not (profile? profile)) + (profile-locales? profile)) + #~(begin + (setenv "GUIX_LOCPATH" + #+(file-append glibc-utf8-locales "/lib/locale")) + (setlocale LC_ALL "en_US.utf8")))) + (define build (with-imported-modules (source-module-closure `((guix build utils) @@ -226,6 +240,9 @@ added to the pack." "cf" "/dev/null" "--files-from=/dev/null" "--sort=name"))) + ;; Make sure non-ASCII file names are properly handled. + #+set-utf8-locale + ;; Add 'tar' to the search path. (setenv "PATH" #+(file-append archiver "/bin")) @@ -836,9 +853,10 @@ last resort for relocation." (scandir input)) (for-each build-wrapper - (append (find-files (string-append input "/bin")) - (find-files (string-append input "/sbin")) - (find-files (string-append input "/libexec"))))))) + ;; Note: Trailing slash in case these are symlinks. + (append (find-files (string-append input "/bin/")) + (find-files (string-append input "/sbin/")) + (find-files (string-append input "/libexec/"))))))) (computed-file (string-append (cond ((package? package) @@ -857,7 +875,10 @@ last resort for relocation." (item (apply wrapped-package (manifest-entry-item entry) (manifest-entry-output entry) - args)))) + args)) + (dependencies (map (lambda (entry) + (apply wrapped-manifest-entry entry args)) + (manifest-entry-dependencies entry))))) ;;; diff --git a/guix/scripts/processes.scm b/guix/scripts/processes.scm index a2ab017490..01f7213e8c 100644 --- a/guix/scripts/processes.scm +++ b/guix/scripts/processes.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -231,7 +231,8 @@ List the current Guix sessions and their processes.")) cons '())) - (for-each (lambda (session) - (daemon-session->recutils session (current-output-port)) - (newline)) - (daemon-sessions))) + (with-paginated-output-port port + (for-each (lambda (session) + (daemon-session->recutils session port) + (newline port)) + (daemon-sessions)))) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index f953957161..807daec593 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -63,7 +63,6 @@ #:re-export (display-profile-content channel-commit-hyperlink) #:export (channel-list - with-git-error-handling guix-pull)) @@ -464,23 +463,6 @@ true, display what would be built without actually building it." (unless (honor-system-x509-certificates!) (honor-lets-encrypt-certificates! store))) -(define (report-git-error error) - "Report the given Guile-Git error." - ;; Prior to Guile-Git commit b6b2760c2fd6dfaa5c0fedb43eeaff06166b3134, - ;; errors would be represented by integers. - (match error - ((? integer? error) ;old Guile-Git - (leave (G_ "Git error ~a~%") error)) - ((? git-error? error) ;new Guile-Git - (leave (G_ "Git error: ~a~%") (git-error-message error))))) - -(define-syntax-rule (with-git-error-handling body ...) - (catch 'git-error - (lambda () - body ...) - (lambda (key err) - (report-git-error err)))) - ;;; ;;; Profile. diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index d9cf45da23..79bfcd7db2 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -446,17 +446,6 @@ list of services." ;;; Generations. ;;; -(define (sexp->channel sexp) - "Return the channel corresponding to SEXP, an sexp as found in the -\"provenance\" file produced by 'provenance-service-type'." - (match sexp - (('channel ('name name) - ('url url) - ('branch branch) - ('commit commit)) - (channel (name name) (url url) - (branch branch) (commit commit))))) - (define* (display-system-generation number #:optional (profile %system-profile)) "Display a summary of system generation NUMBER in a human-readable format." @@ -480,12 +469,10 @@ list of services." (uuid->string root) root)) (kernel (boot-parameters-kernel params)) - (provenance (catch 'system-error - (lambda () - (call-with-input-file - (string-append generation "/provenance") - read)) - (const #f)))) + (multiboot-modules (boot-parameters-multiboot-modules params))) + (define-values (channels config-file) + (system-provenance generation)) + (display-generation profile number) (format #t (G_ " file name: ~a~%") generation) (format #t (G_ " canonical file name: ~a~%") (readlink* generation)) @@ -509,21 +496,22 @@ list of services." (format #t (G_ " kernel: ~a~%") kernel) - (match provenance - (#f #t) - (('provenance ('version 0) - ('channels channels ...) - ('configuration-file config-file)) - (unless (null? channels) - ;; TRANSLATORS: Here "channel" is the same terminology as used in - ;; "guix describe" and "guix pull --channels". - (format #t (G_ " channels:~%")) - (for-each display-channel (map sexp->channel channels))) - (when config-file - (format #t (G_ " configuration file: ~a~%") - (if (supports-hyperlinks?) - (file-hyperlink config-file) - config-file)))))))) + (match multiboot-modules + (() #f) + (((modules . _) ...) + (format #t (G_ " multiboot: ~a~%") + (string-join modules "\n ")))) + + (unless (null? channels) + ;; TRANSLATORS: Here "channel" is the same terminology as used in + ;; "guix describe" and "guix pull --channels". + (format #t (G_ " channels:~%")) + (for-each display-channel channels)) + (when config-file + (format #t (G_ " configuration file: ~a~%") + (if (supports-hyperlinks?) + (file-hyperlink config-file) + config-file)))))) (define* (list-generations pattern #:optional (profile %system-profile)) "Display in a human-readable format all the system generations matching @@ -748,6 +736,7 @@ and TARGET arguments." (define* (perform-action action os #:key + (validate-reconfigure ensure-forward-reconfigure) save-provenance? skip-safety-checks? install-bootloader? @@ -790,7 +779,8 @@ static checks." (operating-system-bootcfg os menu-entries))) (when (eq? action 'reconfigure) - (maybe-suggest-running-guix-pull)) + (maybe-suggest-running-guix-pull) + (check-forward-update validate-reconfigure)) ;; Check whether the declared file systems exist. This is better than ;; instantiating a broken configuration. Assume that we can only check if @@ -939,6 +929,9 @@ Some ACTIONS support additional ARGS.\n")) -e, --expression=EXPR consider the operating-system EXPR evaluates to instead of reading FILE, when applicable")) (display (G_ " + --allow-downgrades for 'reconfigure', allow downgrades to earlier + channel revisions")) + (display (G_ " --on-error=STRATEGY apply STRATEGY (one of nothing-special, backtrace, or debug) when an error occurs while reading FILE")) @@ -993,6 +986,11 @@ Some ACTIONS support additional ARGS.\n")) (option '(#\d "derivation") #f #f (lambda (opt name arg result) (alist-cons 'derivations-only? #t result))) + (option '("allow-downgrades") #f #f + (lambda (opt name arg result) + (alist-cons 'validate-reconfigure + warn-about-backward-reconfigure + result))) (option '("on-error") #t #f (lambda (opt name arg result) (alist-cons 'on-error (string->symbol arg) @@ -1065,6 +1063,7 @@ Some ACTIONS support additional ARGS.\n")) (graft? . #t) (debug . 0) (verbosity . #f) ;default + (validate-reconfigure . ,ensure-forward-reconfigure) (file-system-type . "ext4") (image-size . guess) (install-bootloader? . #t))) @@ -1150,6 +1149,8 @@ resulting from command-line parsing." #:use-substitutes? (assoc-ref opts 'substitutes?) #:skip-safety-checks? (assoc-ref opts 'skip-safety-checks?) + #:validate-reconfigure + (assoc-ref opts 'validate-reconfigure) #:file-system-type (assoc-ref opts 'file-system-type) #:image-size (assoc-ref opts 'image-size) #:full-boot? (assoc-ref opts 'full-boot?) diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm index 7885c33457..9013e035f7 100644 --- a/guix/scripts/system/reconfigure.scm +++ b/guix/scripts/system/reconfigure.scm @@ -34,9 +34,18 @@ #:use-module (guix monads) #:use-module (guix store) #:use-module ((guix self) #:select (make-config.scm)) + #:autoload (guix describe) (current-profile) + #:use-module (guix channels) + #:autoload (guix git) (update-cached-checkout) + #:use-module (guix i18n) + #:use-module (guix diagnostics) + #:use-module ((guix utils) #:select (&fix-hint)) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:use-module ((guix config) #:select (%guix-package-name)) #:export (switch-system-program switch-to-system @@ -44,7 +53,11 @@ upgrade-shepherd-services install-bootloader-program - install-bootloader)) + install-bootloader + + check-forward-update + ensure-forward-reconfigure + warn-about-backward-reconfigure)) ;;; Commentary: ;;; @@ -266,3 +279,85 @@ additional configurations specified by MENU-ENTRIES can be selected." bootcfg-file device target)))))) + + +;;; +;;; Downgrade detection. +;;; + +(define (ensure-forward-reconfigure channel start commit relation) + "Raise an error if RELATION is not 'ancestor, meaning that START is not an +ancestor of COMMIT, unless CHANNEL specifies a commit." + (match relation + ('ancestor #t) + ('self #t) + (_ + (raise (make-compound-condition + (condition + (&message (message + (format #f (G_ "\ +aborting reconfiguration because commit ~a of channel '~a' is not a descendant of ~a") + commit (channel-name channel) + start))) + (&fix-hint + (hint (G_ "Use @option{--allow-downgrades} to force +this downgrade."))))))))) + +(define (warn-about-backward-reconfigure channel start commit relation) + "Warn about non-forward updates of CHANNEL from START to COMMIT, without +aborting." + (match relation + ((or 'ancestor 'self) + #t) + ('descendant + (warning (G_ "rolling back channel '~a' from ~a to ~a~%") + (channel-name channel) start commit)) + ('unrelated + (warning (G_ "moving channel '~a' from ~a to unrelated commit ~a~%") + (channel-name channel) start commit)))) + +(define (channel-relations old new) + "Return a list of channel/relation pairs, where each relation is a symbol as +returned by 'commit-relation' denoting how commits of channels in OLD relate +to commits of channels in NEW." + (filter-map (lambda (old) + (let ((new (find (lambda (channel) + (eq? (channel-name channel) + (channel-name old))) + new))) + (and new + (let-values (((checkout commit relation) + (update-cached-checkout + (channel-url new) + #:ref + `(commit . ,(channel-commit new)) + #:starting-commit + (channel-commit old) + #:check-out? #f))) + (list new + (channel-commit old) (channel-commit new) + relation))))) + old)) + +(define* (check-forward-update #:optional + (validate-reconfigure ensure-forward-reconfigure)) + "Call VALIDATE-RECONFIGURE passing it, for each channel, the channel, the +currently-deployed commit (as returned by 'guix system describe') and the +target commit (as returned by 'guix describe')." + ;; TODO: Make that functionality available to 'guix deploy'. + (define new + (or (and=> (current-profile) profile-channels) + '())) + + (define old + (system-provenance "/run/current-system")) + + (when (null? old) + (warning (G_ "cannot determine provenance for /run/current-system~%"))) + (when (and (null? new) (not (getenv "GUIX_UNINSTALLED"))) + (warning (G_ "cannot determine provenance of ~a~%") %guix-package-name)) + + (for-each (match-lambda + ((channel old new relation) + (validate-reconfigure channel old new relation))) + (channel-relations old new))) diff --git a/guix/scripts/system/search.scm b/guix/scripts/system/search.scm index d2eac06cca..bf49ea2341 100644 --- a/guix/scripts/system/search.scm +++ b/guix/scripts/system/search.scm @@ -26,6 +26,7 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) + #:use-module (ice-9 format) #:use-module (ice-9 regex) #:use-module (ice-9 match) #:export (service-type->recutils diff --git a/guix/scripts/time-machine.scm b/guix/scripts/time-machine.scm index f9bcec651a..441673b780 100644 --- a/guix/scripts/time-machine.scm +++ b/guix/scripts/time-machine.scm @@ -24,10 +24,12 @@ #:use-module (guix channels) #:use-module (guix store) #:use-module (guix status) + #:use-module ((guix git) + #:select (with-git-error-handling)) #:use-module ((guix utils) #:select (%current-system)) #:use-module ((guix scripts pull) - #:select (with-git-error-handling channel-list)) + #:select (channel-list)) #:use-module ((guix scripts build) #:select (%standard-build-options show-build-options-help diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm index 475d989357..3035ff6ca8 100644 --- a/guix/scripts/weather.scm +++ b/guix/scripts/weather.scm @@ -190,7 +190,7 @@ Return the coverage ratio, an exact number between 0 and 1." narinfos)) (time (+ (time-second time) (/ (time-nanosecond time) 1e9)))) - (format #t (G_ " ~2,1f% substitutes available (~h out of ~h)~%") + (format #t (G_ " ~,1f% substitutes available (~h out of ~h)~%") (* 100. (/ obtained requested 1.)) obtained requested) (let ((total (/ (reduce + 0 sizes) MiB))) diff --git a/guix/self.scm b/guix/self.scm index e1350a7403..f70b1ecdd8 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -647,13 +647,13 @@ load path." ,(file-append* source "/etc/completion/zsh/_guix")) ("share/fish/vendor_completions.d/guix.fish" ,(file-append* source "/etc/completion/fish/guix.fish")) - ("share/guix/berlin.guixsd.org.pub" + ("share/guix/berlin.guix.gnu.org.pub" ,(file-append* source - "/etc/substitutes/berlin.guixsd.org.pub")) + "/etc/substitutes/berlin.guix.gnu.org.pub")) ("share/guix/ci.guix.gnu.org.pub" ;alias - ,(file-append* source "/etc/substitutes/berlin.guixsd.org.pub")) + ,(file-append* source "/etc/substitutes/berlin.guix.gnu.org.pub")) ("share/guix/ci.guix.info.pub" ;alias - ,(file-append* source "/etc/substitutes/berlin.guixsd.org.pub"))))) + ,(file-append* source "/etc/substitutes/berlin.guix.gnu.org.pub"))))) (define* (whole-package name modules dependencies #:key diff --git a/guix/ssh.scm b/guix/ssh.scm index 2d7ca7d01d..b9e6ff8564 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -129,7 +129,11 @@ Throw an error on failure." ;; We need lightweight compression when ;; exchanging full archives. #:compression compression - #:compression-level 3))) + #:compression-level 3 + + ;; Speed up RPCs by creating sockets with + ;; TCP_NODELAY. + #:nodelay #t))) ;; Honor ~/.ssh/config. (session-parse-config! session) diff --git a/guix/store/database.scm b/guix/store/database.scm index a38e4d7e52..50b66ce282 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2019 Caleb Ristvedt <caleb.ristvedt@cune.org> ;;; Copyright © 2018, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,6 +21,7 @@ (define-module (guix store database) #:use-module (sqlite3) #:use-module (guix config) + #:use-module (guix gexp) #:use-module (guix serialization) #:use-module (guix store deduplication) #:use-module (guix base16) @@ -27,6 +29,7 @@ #:use-module (guix build syscalls) #:use-module ((guix build utils) #:select (mkdir-p executable-file?)) + #:use-module (guix utils) #:use-module (guix build store-copy) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) @@ -97,17 +100,20 @@ as specified by SQL-SCHEMA." (sqlite-exec db (call-with-input-file schema get-string-all))) -(define (call-with-database file proc) +(define* (call-with-database file proc #:key (wal-mode? #t)) "Pass PROC a database record corresponding to FILE. If FILE doesn't exist, -create it and initialize it as a new database." +create it and initialize it as a new database. Unless WAL-MODE? is set to #f, +set journal_mode=WAL." (let ((new? (and (not (file-exists? file)) (begin (mkdir-p (dirname file)) #t))) (db (sqlite-open file))) - ;; Turn DB in "write-ahead log" mode, which should avoid SQLITE_LOCKED - ;; errors when we have several readers: <https://www.sqlite.org/wal.html>. - (sqlite-exec db "PRAGMA journal_mode=WAL;") + ;; Using WAL breaks for the Hurd <https://bugs.gnu.org/42151>. + (when wal-mode? + ;; Turn DB in "write-ahead log" mode, which should avoid SQLITE_LOCKED + ;; errors when we have several readers: <https://www.sqlite.org/wal.html>. + (sqlite-exec db "PRAGMA journal_mode=WAL;")) ;; Install a busy handler such that, when the database is locked, sqlite ;; retries until 30 seconds have passed, at which point it gives up and @@ -200,10 +206,15 @@ prior to returning." ;; Default location of the store database. (string-append %store-database-directory "/db.sqlite")) -(define-syntax-rule (with-database file db exp ...) - "Open DB from FILE and close it when the dynamic extent of EXP... is left. -If FILE doesn't exist, create it and initialize it as a new database." - (call-with-database file (lambda (db) exp ...))) +(define-syntax with-database + (syntax-rules () + "Open DB from FILE and close it when the dynamic extent of EXP... is left. +If FILE doesn't exist, create it and initialize it as a new database. Pass +#:wal-mode? to call-with-database." + ((_ file db #:wal-mode? wal-mode? exp ...) + (call-with-database file (lambda (db) exp ...) #:wal-mode? wal-mode?)) + ((_ file db exp ...) + (call-with-database file (lambda (db) exp ...))))) (define (sqlite-finalize stmt) ;; As of guile-sqlite3 0.1.0, cached statements aren't reset when diff --git a/guix/swh.scm b/guix/swh.scm index ec744fed2f..a343ccfdd7 100644 --- a/guix/swh.scm +++ b/guix/swh.scm @@ -35,6 +35,7 @@ #:use-module (ice-9 popen) #:use-module ((ice-9 ftw) #:select (scandir)) #:export (%swh-base-url + %verify-swh-certificate? %allow-request? request-rate-limit-reached? @@ -126,6 +127,10 @@ ;; Presumably we won't need to change it. (make-parameter "https://archive.softwareheritage.org")) +(define %verify-swh-certificate? + ;; Whether to verify the X.509 HTTPS certificate for %SWH-BASE-URL. + (make-parameter #t)) + (define (swh-url path . rest) ;; URLs returned by the API may be relative or absolute. This has changed ;; without notice before. Handle both cases by detecting whether the path @@ -143,6 +148,13 @@ url (string-append url "/"))) +;; XXX: Work around a bug in Guile 3.0.2 where #:verify-certificate? would +;; be ignored (<https://bugs.gnu.org/40486>). +(define* (http-get* uri #:rest rest) + (apply http-request uri #:method 'GET rest)) +(define* (http-post* uri #:rest rest) + (apply http-request uri #:method 'POST rest)) + (define %date-regexp ;; Match strings like "2014-11-17T22:09:38+01:00" or ;; "2018-09-30T23:20:07.815449+00:00"". @@ -174,11 +186,12 @@ Software Heritage." ;; Converts "string or #nil" coming from JSON to "string or #f". (match-lambda ((? string? str) str) - ((? null?) #f))) + ((? null?) #f) ;Guile-JSON 3.x + ('null #f))) ;Guile-JSON 4.x (define %allow-request? ;; Takes a URL and method (e.g., the 'http-get' procedure) and returns true - ;; to keep going. This can be used to disallow a requests when + ;; to keep going. This can be used to disallow requests when ;; 'request-rate-limit-reached?' returns true, for instance. (make-parameter (const #t))) @@ -194,7 +207,7 @@ Software Heritage." (string->uri url)) (define reset-time - (if (and (eq? method http-post) + (if (and (eq? method http-post*) (string-prefix? "/api/1/origin/save/" (uri-path uri))) %save-rate-limit-reset-time %general-rate-limit-reset-time)) @@ -207,21 +220,23 @@ RESPONSE." (let ((uri (string->uri url))) (match (assq-ref (response-headers response) 'x-ratelimit-reset) ((= string->number (? number? reset)) - (if (and (eq? method http-post) + (if (and (eq? method http-post*) (string-prefix? "/api/1/origin/save/" (uri-path uri))) (set! %save-rate-limit-reset-time reset) (set! %general-rate-limit-reset-time reset))) (_ #f)))) -(define* (call url decode #:optional (method http-get) +(define* (call url decode #:optional (method http-get*) #:key (false-if-404? #t)) "Invoke the endpoint at URL using METHOD. Decode the resulting JSON body using DECODE, a one-argument procedure that takes an input port. When FALSE-IF-404? is true, return #f upon 404 responses." (and ((%allow-request?) url method) (let*-values (((response port) - (method url #:streaming? #t))) + (method url #:streaming? #t + #:verify-certificate? + (%verify-swh-certificate?)))) ;; See <https://archive.softwareheritage.org/api/#rate-limiting>. (match (assq-ref (response-headers response) 'x-ratelimit-remaining) (#f #t) @@ -466,7 +481,7 @@ directory entries; if it has type 'file, return its <content> object." (define* (save-origin url #:optional (type "git")) "Request URL to be saved." (call (swh-url "/api/1/origin/save" type "url" url) json->save-reply - http-post)) + http-post*)) (define-query (save-origin-status url type) "Return the status of a /save request for URL and TYPE (e.g., \"git\")." @@ -488,7 +503,7 @@ directory entries; if it has type 'file, return its <content> object." to the vault. Return a <vault-reply>." (call (swh-url "/api/1/vault" (symbol->string kind) id) json->vault-reply - http-post)) + http-post*)) (define* (vault-fetch id kind #:key (log-port (current-error-port))) @@ -507,8 +522,10 @@ revision, it is a gzip-compressed stream for 'git fast-import'." ('done ;; Fetch the bundle. (let-values (((response port) - (http-get (swh-url (vault-reply-fetch-url reply)) - #:streaming? #t))) + (http-get* (swh-url (vault-reply-fetch-url reply)) + #:streaming? #t + #:verify-certificate? + (%verify-swh-certificate?)))) (if (= (response-code response) 200) port (begin ;shouldn't happen diff --git a/guix/ui.scm b/guix/ui.scm index 0d3620f96f..27bcade9dd 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -121,6 +121,7 @@ file-hyperlink location->hyperlink + with-paginated-output-port relevance package-relevance display-search-results @@ -651,6 +652,23 @@ or variants of @code{~a} in the same profile.") or remove one of them from the profile.") name1 name2))))) +(cond-expand + (guile-3 + ;; On Guile 3.0, in 'call-with-error-handling' we need to re-raise. To + ;; preserve useful backtraces in case of unhandled errors, we want that to + ;; happen before the stack has been unwound, hence 'guard*'. + (define-syntax-rule (guard* (var clauses ...) exp ...) + "This variant of SRFI-34 'guard' does not unwind the stack before +evaluating the tests and bodies of CLAUSES." + (with-exception-handler + (lambda (var) + (cond clauses ... (else (raise var)))) + (lambda () exp ...) + #:unwind? #f))) + (else + (define-syntax-rule (guard* (var clauses ...) exp ...) + (guard (var clauses ...) exp ...)))) + (define (call-with-error-handling thunk) "Call THUNK within a user-friendly error handler." (define (port-filename* port) @@ -659,143 +677,147 @@ or remove one of them from the profile.") (and (not (port-closed? port)) (port-filename port))) - (guard (c ((package-input-error? c) - (let* ((package (package-error-package c)) - (input (package-error-invalid-input c)) - (location (package-location package)) - (file (location-file location)) - (line (location-line location)) - (column (location-column location))) - (leave (G_ "~a:~a:~a: package `~a' has an invalid input: ~s~%") - file line column - (package-full-name package) input))) - ((package-cross-build-system-error? c) - (let* ((package (package-error-package c)) - (loc (package-location package)) - (system (package-build-system package))) - (leave (G_ "~a: ~a: build system `~a' does not support cross builds~%") - (location->string loc) - (package-full-name package) - (build-system-name system)))) - ((gexp-input-error? c) - (let ((input (package-error-invalid-input c))) - (leave (G_ "~s: invalid G-expression input~%") - (gexp-error-invalid-input c)))) - ((profile-not-found-error? c) - (leave (G_ "profile '~a' does not exist~%") - (profile-error-profile c))) - ((missing-generation-error? c) - (leave (G_ "generation ~a of profile '~a' does not exist~%") - (missing-generation-error-generation c) - (profile-error-profile c))) - ((unmatched-pattern-error? c) - (let ((pattern (unmatched-pattern-error-pattern c))) - (leave (G_ "package '~a~@[@~a~]~@[:~a~]' not found in profile~%") - (manifest-pattern-name pattern) - (manifest-pattern-version pattern) - (match (manifest-pattern-output pattern) - ("out" #f) - (output output))))) - ((profile-collision-error? c) - (let ((entry (profile-collision-error-entry c)) - (conflict (profile-collision-error-conflict c))) - (define (report-parent-entries entry) - (let ((parent (force (manifest-entry-parent entry)))) - (when (manifest-entry? parent) - (report-error (G_ " ... propagated from ~a@~a~%") - (manifest-entry-name parent) - (manifest-entry-version parent)) - (report-parent-entries parent)))) - - (define (manifest-entry-output* entry) - (match (manifest-entry-output entry) - ("out" "") - (output (string-append ":" output)))) - - (report-error (G_ "profile contains conflicting entries for ~a~a~%") - (manifest-entry-name entry) - (manifest-entry-output* entry)) - (report-error (G_ " first entry: ~a@~a~a ~a~%") - (manifest-entry-name entry) - (manifest-entry-version entry) - (manifest-entry-output* entry) - (manifest-entry-item entry)) - (report-parent-entries entry) - (report-error (G_ " second entry: ~a@~a~a ~a~%") - (manifest-entry-name conflict) - (manifest-entry-version conflict) - (manifest-entry-output* conflict) - (manifest-entry-item conflict)) - (report-parent-entries conflict) - (display-collision-resolution-hint c) - (exit 1))) - ((nar-error? c) - (let ((file (nar-error-file c)) - (port (nar-error-port c))) - (if file - (leave (G_ "corrupt input while restoring '~a' from ~s~%") - file (or (port-filename* port) port)) - (leave (G_ "corrupt input while restoring archive from ~s~%") - (or (port-filename* port) port))))) - ((store-connection-error? c) - (leave (G_ "failed to connect to `~a': ~a~%") - (store-connection-error-file c) - (strerror (store-connection-error-code c)))) - ((store-protocol-error? c) - ;; FIXME: Server-provided error messages aren't i18n'd. - (leave (G_ "~a~%") - (store-protocol-error-message c))) - ((derivation-missing-output-error? c) - (leave (G_ "reference to invalid output '~a' of derivation '~a'~%") - (derivation-missing-output c) - (derivation-file-name (derivation-error-derivation c)))) - ((file-search-error? c) - (leave (G_ "file '~a' could not be found in these \ + (guard* (c ((package-input-error? c) + (let* ((package (package-error-package c)) + (input (package-error-invalid-input c)) + (location (package-location package)) + (file (location-file location)) + (line (location-line location)) + (column (location-column location))) + (leave (G_ "~a:~a:~a: package `~a' has an invalid input: ~s~%") + file line column + (package-full-name package) input))) + ((package-cross-build-system-error? c) + (let* ((package (package-error-package c)) + (loc (package-location package)) + (system (package-build-system package))) + (leave (G_ "~a: ~a: build system `~a' does not support cross builds~%") + (location->string loc) + (package-full-name package) + (build-system-name system)))) + ((gexp-input-error? c) + (let ((input (package-error-invalid-input c))) + (leave (G_ "~s: invalid G-expression input~%") + (gexp-error-invalid-input c)))) + ((profile-not-found-error? c) + (leave (G_ "profile '~a' does not exist~%") + (profile-error-profile c))) + ((missing-generation-error? c) + (leave (G_ "generation ~a of profile '~a' does not exist~%") + (missing-generation-error-generation c) + (profile-error-profile c))) + ((unmatched-pattern-error? c) + (let ((pattern (unmatched-pattern-error-pattern c))) + (leave (G_ "package '~a~@[@~a~]~@[:~a~]' not found in profile~%") + (manifest-pattern-name pattern) + (manifest-pattern-version pattern) + (match (manifest-pattern-output pattern) + ("out" #f) + (output output))))) + ((profile-collision-error? c) + (let ((entry (profile-collision-error-entry c)) + (conflict (profile-collision-error-conflict c))) + (define (report-parent-entries entry) + (let ((parent (force (manifest-entry-parent entry)))) + (when (manifest-entry? parent) + (report-error (G_ " ... propagated from ~a@~a~%") + (manifest-entry-name parent) + (manifest-entry-version parent)) + (report-parent-entries parent)))) + + (define (manifest-entry-output* entry) + (match (manifest-entry-output entry) + ("out" "") + (output (string-append ":" output)))) + + (report-error (G_ "profile contains conflicting entries for ~a~a~%") + (manifest-entry-name entry) + (manifest-entry-output* entry)) + (report-error (G_ " first entry: ~a@~a~a ~a~%") + (manifest-entry-name entry) + (manifest-entry-version entry) + (manifest-entry-output* entry) + (manifest-entry-item entry)) + (report-parent-entries entry) + (report-error (G_ " second entry: ~a@~a~a ~a~%") + (manifest-entry-name conflict) + (manifest-entry-version conflict) + (manifest-entry-output* conflict) + (manifest-entry-item conflict)) + (report-parent-entries conflict) + (display-collision-resolution-hint c) + (exit 1))) + ((nar-error? c) + (let ((file (nar-error-file c)) + (port (nar-error-port c))) + (if file + (leave (G_ "corrupt input while restoring '~a' from ~s~%") + file (or (port-filename* port) port)) + (leave (G_ "corrupt input while restoring archive from ~s~%") + (or (port-filename* port) port))))) + ((store-connection-error? c) + (leave (G_ "failed to connect to `~a': ~a~%") + (store-connection-error-file c) + (strerror (store-connection-error-code c)))) + ((store-protocol-error? c) + ;; FIXME: Server-provided error messages aren't i18n'd. + (leave (G_ "~a~%") + (store-protocol-error-message c))) + ((derivation-missing-output-error? c) + (leave (G_ "reference to invalid output '~a' of derivation '~a'~%") + (derivation-missing-output c) + (derivation-file-name (derivation-error-derivation c)))) + ((file-search-error? c) + (leave (G_ "file '~a' could not be found in these \ directories:~{ ~a~}~%") - (file-search-error-file-name c) - (file-search-error-search-path c))) - ((invoke-error? c) - (leave (G_ "program exited\ + (file-search-error-file-name c) + (file-search-error-search-path c))) + ((invoke-error? c) + (leave (G_ "program exited\ ~@[ with non-zero exit status ~a~]\ ~@[ terminated by signal ~a~]\ ~@[ stopped by signal ~a~]: ~s~%") - (invoke-error-exit-status c) - (invoke-error-term-signal c) - (invoke-error-stop-signal c) - (cons (invoke-error-program c) - (invoke-error-arguments c)))) - ((and (error-location? c) (message-condition? c)) - (report-error (error-location c) (G_ "~a~%") - (gettext (condition-message c) %gettext-domain)) - (when (fix-hint? c) - (display-hint (condition-fix-hint c))) - (exit 1)) - ((and (message-condition? c) (fix-hint? c)) - (report-error (G_ "~a~%") - (gettext (condition-message c) %gettext-domain)) - (display-hint (condition-fix-hint c)) - (exit 1)) - - ;; On Guile 3.0.0, exceptions such as 'unbound-variable' are - ;; compound and include a '&message'. However, that message only - ;; contains the format string. Thus, special-case it here to - ;; avoid displaying a bare format string. - ((cond-expand - (guile-3 - ((exception-predicate &exception-with-kind-and-args) c)) - (else #f)) - (raise c)) - - ((message-condition? c) - ;; Normally '&message' error conditions have an i18n'd message. - (leave (G_ "~a~%") - (gettext (condition-message c) %gettext-domain)))) - ;; Catch EPIPE and the likes. - (catch 'system-error - thunk - (lambda (key proc format-string format-args . rest) - (leave (G_ "~a: ~a~%") proc - (apply format #f format-string format-args)))))) + (invoke-error-exit-status c) + (invoke-error-term-signal c) + (invoke-error-stop-signal c) + (cons (invoke-error-program c) + (invoke-error-arguments c)))) + ((and (error-location? c) (message-condition? c)) + (report-error (error-location c) (G_ "~a~%") + (gettext (condition-message c) %gettext-domain)) + (when (fix-hint? c) + (display-hint (condition-fix-hint c))) + (exit 1)) + ((and (message-condition? c) (fix-hint? c)) + (report-error (G_ "~a~%") + (gettext (condition-message c) %gettext-domain)) + (display-hint (condition-fix-hint c)) + (exit 1)) + + ;; On Guile 3.0.0, exceptions such as 'unbound-variable' are + ;; compound and include a '&message'. However, that message only + ;; contains the format string. Thus, special-case it here to + ;; avoid displaying a bare format string. + ;; + ;; Furthermore, use of 'guard*' ensures that the stack has not + ;; been unwound when we re-raise, since that would otherwise show + ;; useless backtraces. + ((cond-expand + (guile-3 + ((exception-predicate &exception-with-kind-and-args) c)) + (else #f)) + (raise c)) + + ((message-condition? c) + ;; Normally '&message' error conditions have an i18n'd message. + (leave (G_ "~a~%") + (gettext (condition-message c) %gettext-domain)))) + ;; Catch EPIPE and the likes. + (catch 'system-error + thunk + (lambda (key proc format-string format-args . rest) + (leave (G_ "~a: ~a~%") proc + (apply format #f format-string format-args)))))) (define-syntax-rule (leave-on-EPIPE exp ...) "Run EXP... in a context where EPIPE errors are caught and lead to 'exit' @@ -1470,8 +1492,12 @@ HYPERLINKS? is true, emit hyperlink escape sequences when appropriate." (string->recutils (string-trim-right (parameterize ((%text-width width*)) - (string-append "description: " - (or (package-description-string p) ""))) + ;; Call 'texi->plain-text' on the concatenated string to account + ;; for the width of "description:" in paragraph filling. + (texi->plain-text + (string-append "description: " + (or (and=> (package-description p) P_) + "")))) #\newline))) (for-each (match-lambda ((field . value) @@ -1988,4 +2014,8 @@ and signal handling have already been set up." (initialize-guix) (apply run-guix args)) +;;; Local Variables: +;;; eval: (put 'guard* 'scheme-indent-function 2) +;;; End: + ;;; ui.scm ends here diff --git a/guix/upstream.scm b/guix/upstream.scm index 67d0eeefbb..70cbfb45e8 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -26,6 +26,7 @@ #:select (download-to-store url-fetch)) #:use-module (guix gnupg) #:use-module (guix packages) + #:use-module (guix diagnostics) #:use-module (guix ui) #:use-module (guix base32) #:use-module (guix gexp) @@ -51,6 +52,7 @@ upstream-source-archive-types upstream-source-input-changes + url-predicate url-prefix-predicate coalesce-sources @@ -161,24 +163,28 @@ S-expression PACKAGE-SEXP." current-propagated new-propagated)))))) (_ '()))) -(define (url-prefix-predicate prefix) - "Return a predicate that returns true when passed a package where one of its -source URLs starts with PREFIX." +(define* (url-predicate matching-url?) + "Return a predicate that returns true when passed a package whose source is +an <origin> with the URL-FETCH method, and one of its URLs passes +MATCHING-URL?." (lambda (package) - (define matching-uri? - (match-lambda - ((? string? uri) - (string-prefix? prefix uri)) - (_ - #f))) - (match (package-source package) ((? origin? origin) - (match (origin-uri origin) - ((? matching-uri?) #t) - (_ #f))) + (and (eq? (origin-method origin) url-fetch) + (match (origin-uri origin) + ((? string? url) + (matching-url? url)) + (((? string? urls) ...) + (any matching-url? urls)) + (_ + #f)))) (_ #f)))) +(define (url-prefix-predicate prefix) + "Return a predicate that returns true when passed a package where one of its +source URLs starts with PREFIX." + (url-predicate (cut string-prefix? prefix <>))) + (define (upstream-source-archive-types release) "Return the available types of archives for RELEASE---a list of strings such as \"gz\" or \"xz\"." @@ -320,10 +326,17 @@ values: 'interactive' (default), 'always', and 'never'." (built-derivations (list drv)) (return (derivation->output-path drv)))))))) (let-values (((status data) - (gnupg-verify* sig data #:key-download key-download))) + (if sig + (gnupg-verify* sig data + #:key-download key-download) + (values 'missing-signature data)))) (match status ('valid-signature tarball) + ('missing-signature + (warning (G_ "failed to download detached signature from ~a~%") + signature-url) + #f) ('invalid-signature (warning (G_ "signature verification failed for '~a' (key: ~a)~%") url data) @@ -472,10 +485,8 @@ new version string if an update was made, and #f otherwise." (warning (G_ "~a: could not locate source file") (location-file loc)) #f))) - (begin - (format (current-error-port) - (G_ "~a: ~a: no `version' field in source; skipping~%") - (location->string (package-location package)) - name))))) + (warning (package-location package) + (G_ "~a: no `version' field in source; skipping~%") + name)))) ;;; upstream.scm ends here |