diff options
Diffstat (limited to 'guix/import')
| -rw-r--r-- | guix/import/cran.scm | 296 | ||||
| -rw-r--r-- | guix/import/crate.scm | 186 | ||||
| -rw-r--r-- | guix/import/github.scm | 10 | ||||
| -rw-r--r-- | guix/import/gnome.scm | 35 | ||||
| -rw-r--r-- | guix/import/kde.scm | 190 | ||||
| -rw-r--r-- | guix/import/opam.scm | 6 | ||||
| -rw-r--r-- | guix/import/pypi.scm | 3 | ||||
| -rw-r--r-- | guix/import/stackage.scm | 2 | ||||
| -rw-r--r-- | guix/import/utils.scm | 22 |
9 files changed, 598 insertions, 152 deletions
diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 3240094444..e47aff2b12 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -24,6 +24,7 @@ #:use-module ((ice-9 rdelim) #:select (read-string read-line)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-2) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (ice-9 receive) @@ -32,11 +33,13 @@ #:use-module (guix http-client) #:use-module (gcrypt hash) #:use-module (guix store) + #:use-module ((guix serialization) #:select (write-file)) #:use-module (guix base32) #:use-module ((guix download) #:select (download-to-store)) #:use-module (guix import utils) #:use-module ((guix build utils) #:select (find-files)) #:use-module (guix utils) + #:use-module (guix git) #:use-module ((guix build-system r) #:select (cran-uri bioconductor-uri)) #:use-module (guix upstream) #:use-module (guix packages) @@ -46,6 +49,7 @@ cran-recursive-import %cran-updater %bioconductor-updater + %bioconductor-version cran-package? bioconductor-package? @@ -132,14 +136,19 @@ package definition." ;; updated together. (define %bioconductor-version "3.9") -(define %bioconductor-packages-list-url +(define* (bioconductor-packages-list-url #:optional type) (string-append "https://bioconductor.org/packages/" - %bioconductor-version "/bioc/src/contrib/PACKAGES")) - -(define (bioconductor-packages-list) + %bioconductor-version + (match type + ('annotation "/data/annotation") + ('experiment "/data/experiment") + (_ "/bioc")) + "/src/contrib/PACKAGES")) + +(define* (bioconductor-packages-list #:optional type) "Return the latest version of package NAME for the current bioconductor release." - (let ((url (string->uri %bioconductor-packages-list-url))) + (let ((url (string->uri (bioconductor-packages-list-url type)))) (guard (c ((http-get-error? c) (format (current-error-port) "error: failed to retrieve list of packages from ~s: ~a (~s)~%" @@ -153,19 +162,33 @@ release." (description->alist (string-join chunk "\n"))) (chunk-lines (read-lines (http-fetch/cached url))))))) -(define (latest-bioconductor-package-version name) +(define* (latest-bioconductor-package-version name #:optional type) "Return the version string corresponding to the latest release of the bioconductor package NAME, or #F if the package is unknown." (and=> (find (lambda (meta) (string=? (assoc-ref meta "Package") name)) - (bioconductor-packages-list)) + (bioconductor-packages-list type)) (cut assoc-ref <> "Version"))) +;; XXX taken from (guix scripts hash) +(define (vcs-file? file stat) + (case (stat:type stat) + ((directory) + (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS"))) + ((regular) + ;; Git sub-modules have a '.git' file that is a regular text file. + (string=? (basename file) ".git")) + (else + #f))) + ;; Little helper to download URLs only once. (define download (memoize - (lambda (url) - (with-store store (download-to-store store url))))) + (lambda* (url #:optional git) + (with-store store + (if git + (latest-repository-commit store url) + (download-to-store store url)))))) (define (fetch-description repository name) "Return an alist of the contents of the DESCRIPTION file for the R package @@ -187,8 +210,12 @@ from ~s: ~a (~s)~%" ;; Currently, the bioconductor project does not offer a way to access a ;; package's DESCRIPTION file over HTTP, so we determine the version, ;; download the source tarball, and then extract the DESCRIPTION file. - (and-let* ((version (latest-bioconductor-package-version name)) - (url (car (bioconductor-uri name version))) + (and-let* ((type (or + (and (latest-bioconductor-package-version name) #t) + (and (latest-bioconductor-package-version name 'annotation) 'annotation) + (and (latest-bioconductor-package-version name 'experiment) 'experiment))) + (version (latest-bioconductor-package-version name type)) + (url (car (bioconductor-uri name version type))) (tarball (download url))) (call-with-temporary-directory (lambda (dir) @@ -198,8 +225,23 @@ from ~s: ~a (~s)~%" "--strip-components=1" "-C" dir "-f" tarball "*/DESCRIPTION")) - (description->alist (with-input-from-file - (string-append dir "/DESCRIPTION") read-string)))))))))) + (and=> (description->alist (with-input-from-file + (string-append dir "/DESCRIPTION") read-string)) + (lambda (meta) + (if (boolean? type) meta + (cons `(bioconductor-type . ,type) meta)))))))))) + ((git) + (and (string-prefix? "http" name) + ;; Download the git repository at "NAME" + (call-with-values + (lambda () (download name #t)) + (lambda (dir commit) + (and=> (description->alist (with-input-from-file + (string-append dir "/DESCRIPTION") read-string)) + (lambda (meta) + (cons* `(git . ,name) + `(git-commit . ,commit) + meta))))))))) (define (listify meta field) "Look up FIELD in the alist META. If FIELD contains a comma-separated @@ -244,7 +286,7 @@ empty list when the FIELD cannot be found." (define cran-guix-name (cut guix-name "r-" <>)) -(define (needs-fortran? tarball) +(define (tarball-needs-fortran? tarball) "Check if the TARBALL contains Fortran source files." (define (check pattern) (parameterize ((current-error-port (%make-void-port "rw+")) @@ -254,65 +296,127 @@ empty list when the FIELD cannot be found." (check "*.f95") (check "*.f"))) +(define (directory-needs-fortran? dir) + "Check if the directory DIR contains Fortran source files." + (match (find-files dir "\\.f(90|95)?") + (() #f) + (_ #t))) + +(define (needs-fortran? thing tarball?) + "Check if the THING contains Fortran source files." + (if tarball? + (tarball-needs-fortran? thing) + (directory-needs-fortran? thing))) + +(define (files-match-pattern? directory regexp . file-patterns) + "Return #T if any of the files matching FILE-PATTERNS in the DIRECTORY match +the given REGEXP." + (let ((pattern (make-regexp regexp))) + (any (lambda (file) + (call-with-input-file file + (lambda (port) + (let loop () + (let ((line (read-line port))) + (cond + ((eof-object? line) #f) + ((regexp-exec pattern line) #t) + (else (loop)))))))) + (apply find-files directory file-patterns)))) + (define (tarball-files-match-pattern? tarball regexp . file-patterns) "Return #T if any of the files represented by FILE-PATTERNS in the TARBALL match the given REGEXP." (call-with-temporary-directory (lambda (dir) - (let ((pattern (make-regexp regexp))) - (parameterize ((current-error-port (%make-void-port "rw+"))) - (apply system* "tar" - "xf" tarball "-C" dir - `("--wildcards" ,@file-patterns))) - (any (lambda (file) - (call-with-input-file file - (lambda (port) - (let loop () - (let ((line (read-line port))) - (cond - ((eof-object? line) #f) - ((regexp-exec pattern line) #t) - (else (loop)))))))) - (find-files dir)))))) - -(define (needs-zlib? tarball) + (parameterize ((current-error-port (%make-void-port "rw+"))) + (apply system* "tar" + "xf" tarball "-C" dir + `("--wildcards" ,@file-patterns))) + (files-match-pattern? dir regexp)))) + +(define (directory-needs-zlib? dir) + "Return #T if any of the Makevars files in the src directory DIR contain a +zlib linker flag." + (files-match-pattern? dir "-lz" "(Makevars.*|configure.*)")) + +(define (tarball-needs-zlib? tarball) "Return #T if any of the Makevars files in the src directory of the TARBALL contain a zlib linker flag." (tarball-files-match-pattern? tarball "-lz" "*/src/Makevars*" "*/src/configure*" "*/configure*")) -(define (needs-pkg-config? tarball) +(define (needs-zlib? thing tarball?) + "Check if the THING contains files indicating a dependency on zlib." + (if tarball? + (tarball-needs-zlib? thing) + (directory-needs-zlib? thing))) + +(define (directory-needs-pkg-config? dir) + "Return #T if any of the Makevars files in the src directory DIR reference +the pkg-config tool." + (files-match-pattern? dir "pkg-config" + "(Makevars.*|configure.*)")) + +(define (tarball-needs-pkg-config? tarball) "Return #T if any of the Makevars files in the src directory of the TARBALL reference the pkg-config tool." (tarball-files-match-pattern? tarball "pkg-config" "*/src/Makevars*" "*/src/configure*" "*/configure*")) +(define (needs-pkg-config? thing tarball?) + "Check if the THING contains files indicating a dependency on pkg-config." + (if tarball? + (tarball-needs-pkg-config? thing) + (directory-needs-pkg-config? thing))) + +;; XXX adapted from (guix scripts hash) +(define (file-hash file select? recursive?) + ;; Compute the hash of FILE. + (if recursive? + (let-values (((port get-hash) (open-sha256-port))) + (write-file file port #:select? select?) + (force-output port) + (get-hash)) + (call-with-input-file file port-sha256))) + (define (description->package repository meta) "Return the `package' s-expression for an R package published on REPOSITORY from the alist META, which was derived from the R package's DESCRIPTION file." (let* ((base-url (case repository ((cran) %cran-url) - ((bioconductor) %bioconductor-url))) + ((bioconductor) %bioconductor-url) + ((git) #f))) (uri-helper (case repository ((cran) cran-uri) - ((bioconductor) bioconductor-uri))) + ((bioconductor) bioconductor-uri) + ((git) #f))) (name (assoc-ref meta "Package")) (synopsis (assoc-ref meta "Title")) (version (assoc-ref meta "Version")) (license (string->license (assoc-ref meta "License"))) ;; Some packages have multiple home pages. Some have none. - (home-page (match (listify meta "URL") - ((url rest ...) url) - (_ (string-append base-url name)))) - (source-url (match (uri-helper name version) - ((url rest ...) url) - ((? string? url) url) - (_ #f))) - (tarball (download source-url)) + (home-page (case repository + ((git) (assoc-ref meta 'git)) + (else (match (listify meta "URL") + ((url rest ...) url) + (_ (string-append base-url name)))))) + (source-url (case repository + ((git) (assoc-ref meta 'git)) + (else + (match (apply uri-helper name version + (case repository + ((bioconductor) + (list (assoc-ref meta 'bioconductor-type))) + (else '()))) + ((url rest ...) url) + ((? string? url) url) + (_ #f))))) + (git? (assoc-ref meta 'git)) + (source (download source-url git?)) (sysdepends (append - (if (needs-zlib? tarball) '("zlib") '()) + (if (needs-zlib? source (not git?)) '("zlib") '()) (filter (lambda (name) (not (member name invalid-packages))) (map string-downcase (listify meta "SystemRequirements"))))) @@ -323,37 +427,67 @@ from the alist META, which was derived from the R package's DESCRIPTION file." (listify meta "Imports") (listify meta "LinkingTo") (delete "R" - (listify meta "Depends")))))) + (listify meta "Depends"))))) + (package + `(package + (name ,(cran-guix-name name)) + (version ,(case repository + ((git) + `(git-version ,version revision commit)) + (else version))) + (source (origin + (method ,(if git? + 'git-fetch + 'url-fetch)) + (uri ,(case repository + ((git) + `(git-reference + (url ,(assoc-ref meta 'git)) + (commit commit))) + (else + `(,(procedure-name uri-helper) ,name version + ,@(or (and=> (assoc-ref meta 'bioconductor-type) + (lambda (type) + (list (list 'quote type)))) + '()))))) + ,@(if git? + '((file-name (git-file-name name version))) + '()) + (sha256 + (base32 + ,(bytevector->nix-base32-string + (case repository + ((git) + (file-hash source (negate vcs-file?) #t)) + (else (file-sha256 source)))))))) + ,@(if (not (and git? + (equal? (string-append "r-" name) + (cran-guix-name name)))) + `((properties ,`(,'quasiquote ((,'upstream-name . ,name))))) + '()) + (build-system r-build-system) + ,@(maybe-inputs sysdepends) + ,@(maybe-inputs (map cran-guix-name propagate) 'propagated-inputs) + ,@(maybe-inputs + `(,@(if (needs-fortran? source (not git?)) + '("gfortran") '()) + ,@(if (needs-pkg-config? source (not git?)) + '("pkg-config") '())) + 'native-inputs) + (home-page ,(if (string-null? home-page) + (string-append base-url name) + home-page)) + (synopsis ,synopsis) + (description ,(beautify-description (or (assoc-ref meta "Description") + ""))) + (license ,license)))) (values - `(package - (name ,(cran-guix-name name)) - (version ,version) - (source (origin - (method url-fetch) - (uri (,(procedure-name uri-helper) ,name version)) - (sha256 - (base32 - ,(bytevector->nix-base32-string (file-sha256 tarball)))))) - ,@(if (not (equal? (string-append "r-" name) - (cran-guix-name name))) - `((properties ,`(,'quasiquote ((,'upstream-name . ,name))))) - '()) - (build-system r-build-system) - ,@(maybe-inputs sysdepends) - ,@(maybe-inputs (map cran-guix-name propagate) 'propagated-inputs) - ,@(maybe-inputs - `(,@(if (needs-fortran? tarball) - '("gfortran") '()) - ,@(if (needs-pkg-config? tarball) - '("pkg-config") '())) - 'native-inputs) - (home-page ,(if (string-null? home-page) - (string-append base-url name) - home-page)) - (synopsis ,synopsis) - (description ,(beautify-description (or (assoc-ref meta "Description") - ""))) - (license ,license)) + (case repository + ((git) + `(let ((commit ,(assoc-ref meta 'git-commit)) + (revision "1")) + ,package)) + (else package)) propagate))) (define cran->guix-package @@ -362,12 +496,16 @@ from the alist META, which was derived from the R package's DESCRIPTION file." "Fetch the metadata for PACKAGE-NAME from REPO and return the `package' s-expression corresponding to that package, or #f on failure." (let ((description (fetch-description repo package-name))) - (if (and (not description) - (eq? repo 'bioconductor)) - ;; Retry import from CRAN - (cran->guix-package package-name 'cran) - (and description - (description->package repo description))))))) + (if description + (description->package repo description) + (case repo + ((git) + ;; Retry import from Bioconductor + (cran->guix-package package-name 'bioconductor)) + ((bioconductor) + ;; Retry import from CRAN + (cran->guix-package package-name 'cran)) + (else #f))))))) (define* (cran-recursive-import package-name #:optional (repo 'cran)) (recursive-import package-name repo diff --git a/guix/import/crate.scm b/guix/import/crate.scm index 52c5cb1c30..8dc014d232 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -1,5 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 David Craven <david@craven.ch> +;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2019 Martin Becze <mjbecze@riseup.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,6 +24,7 @@ #:use-module ((guix download) #:prefix download:) #:use-module (gcrypt hash) #:use-module (guix http-client) + #:use-module (guix json) #:use-module (guix import json) #:use-module (guix import utils) #:use-module ((guix licenses) #:prefix license:) @@ -30,55 +33,92 @@ #:use-module (guix upstream) #:use-module (guix utils) #:use-module (ice-9 match) - #:use-module (ice-9 pretty-print) ; recursive + #:use-module (ice-9 regex) #:use-module (json) #:use-module (srfi srfi-1) #:use-module (srfi srfi-2) #:use-module (srfi srfi-26) #:export (crate->guix-package guix-package->crate-name + crate-recursive-import %crate-updater)) -(define (crate-fetch crate-name callback) - "Fetch the metadata for CRATE-NAME from crates.io and call the callback." + +;;; +;;; Interface to https://crates.io/api/v1. +;;; - (define (crates->inputs crates) - (sort (map (cut assoc-ref <> "crate_id") crates) string-ci<?)) +;; Crates. A crate is essentially a "package". It can have several +;; "versions", each of which has its own set of dependencies, license, +;; etc.--see <crate-version> below. +(define-json-mapping <crate> make-crate crate? + json->crate + (name crate-name) ;string + (latest-version crate-latest-version "max_version") ;string + (home-page crate-home-page "homepage") ;string | #nil + (repository crate-repository) ;string + (description crate-description) ;string + (keywords crate-keywords ;list of strings + "keywords" vector->list) + (categories crate-categories ;list of strings + "categories" vector->list) + (versions crate-versions "actual_versions" ;list of <crate-version> + (lambda (vector) + (map json->crate-version + (vector->list vector)))) + (links crate-links)) ;alist - (define (string->license string) - (map spdx-string->license (string-split string #\/))) - - (define (crate-kind-predicate kind) - (lambda (dep) (string=? (assoc-ref dep "kind") kind))) - - (and-let* ((crate-json (json-fetch (string-append crate-url crate-name))) - (crate (assoc-ref crate-json "crate")) - (name (assoc-ref crate "name")) - (version (assoc-ref crate "max_version")) - (homepage (assoc-ref crate "homepage")) - (repository (assoc-ref crate "repository")) - (synopsis (assoc-ref crate "description")) - (description (assoc-ref crate "description")) - (license (or (and=> (assoc-ref crate "license") - string->license) - '())) ;missing license info - (path (string-append "/" version "/dependencies")) - (deps-json (json-fetch (string-append crate-url name path))) - (deps (vector->list (assoc-ref deps-json "dependencies"))) - (dep-crates (filter (crate-kind-predicate "normal") deps)) - (dev-dep-crates - (filter (lambda (dep) - (not ((crate-kind-predicate "normal") dep))) deps)) - (cargo-inputs (crates->inputs dep-crates)) - (cargo-development-inputs (crates->inputs dev-dep-crates)) - (home-page (match homepage - (() repository) - (_ homepage)))) - (callback #:name name #:version version - #:cargo-inputs cargo-inputs - #:cargo-development-inputs cargo-development-inputs - #:home-page home-page #:synopsis synopsis - #:description description #:license license))) +;; Crate version. +(define-json-mapping <crate-version> make-crate-version crate-version? + json->crate-version + (id crate-version-id) ;integer + (number crate-version-number "num") ;string + (download-path crate-version-download-path "dl_path") ;string + (readme-path crate-version-readme-path "readme_path") ;string + (license crate-version-license "license") ;string + (links crate-version-links)) ;alist + +;; Crate dependency. Each dependency (each edge in the graph) is annotated as +;; being a "normal" dependency or a development dependency. There also +;; information about the minimum required version, such as "^0.0.41". +(define-json-mapping <crate-dependency> make-crate-dependency + crate-dependency? + json->crate-dependency + (id crate-dependency-id "crate_id") ;string + (kind crate-dependency-kind "kind" ;'normal | 'dev + string->symbol) + (requirement crate-dependency-requirement "req")) ;string + +(define (lookup-crate name) + "Look up NAME on https://crates.io and return the corresopnding <crate> +record or #f if it was not found." + (let ((json (json-fetch (string-append (%crate-base-url) "/api/v1/crates/" + name)))) + (and=> (and json (assoc-ref json "crate")) + (lambda (alist) + ;; The "versions" field of ALIST is simply a list of version IDs + ;; (integers). Here, we squeeze in the actual version + ;; dictionaries that are not part of ALIST but are just more + ;; convenient handled this way. + (let ((versions (or (assoc-ref json "versions") '#()))) + (json->crate `(,@alist + ("actual_versions" . ,versions)))))))) + +(define (crate-version-dependencies version) + "Return the list of <crate-dependency> records of VERSION, a +<crate-version>." + (let* ((path (assoc-ref (crate-version-links version) "dependencies")) + (url (string-append (%crate-base-url) path))) + (match (assoc-ref (or (json-fetch url) '()) "dependencies") + ((? vector? vector) + (map json->crate-dependency (vector->list vector))) + (_ + '())))) + + +;;; +;;; Converting crates to Guix packages. +;;; (define (maybe-cargo-inputs package-names) (match (package-names->package-inputs package-names) @@ -138,10 +178,65 @@ and LICENSE." (close-port port) pkg)) -(define (crate->guix-package crate-name) +(define %dual-license-rx + ;; Dual licensing is represented by a string such as "MIT OR Apache-2.0". + ;; This regexp matches that. + (make-regexp "^(.*) OR (.*)$")) + +(define* (crate->guix-package crate-name #:optional version) "Fetch the metadata for CRATE-NAME from crates.io, and return the -`package' s-expression corresponding to that package, or #f on failure." - (crate-fetch crate-name make-crate-sexp)) +`package' s-expression corresponding to that package, or #f on failure. +When VERSION is specified, attempt to fetch that version; otherwise fetch the +latest version of CRATE-NAME." + (define (string->license string) + (match (regexp-exec %dual-license-rx string) + (#f (list (spdx-string->license string))) + (m (list (spdx-string->license (match:substring m 1)) + (spdx-string->license (match:substring m 2)))))) + + (define (normal-dependency? dependency) + (eq? (crate-dependency-kind dependency) 'normal)) + + (define crate + (lookup-crate crate-name)) + + (define version-number + (or version + (crate-latest-version crate))) + + (define version* + (find (lambda (version) + (string=? (crate-version-number version) + version-number)) + (crate-versions crate))) + + (and crate version* + (let* ((dependencies (crate-version-dependencies version*)) + (dep-crates (filter normal-dependency? dependencies)) + (dev-dep-crates (remove normal-dependency? dependencies)) + (cargo-inputs (sort (map crate-dependency-id dep-crates) + string-ci<?)) + (cargo-development-inputs + (sort (map crate-dependency-id dev-dep-crates) + string-ci<?))) + (values + (make-crate-sexp #:name crate-name + #:version (crate-version-number version*) + #:cargo-inputs cargo-inputs + #:cargo-development-inputs cargo-development-inputs + #:home-page (or (crate-home-page crate) + (crate-repository crate)) + #:synopsis (crate-description crate) + #:description (crate-description crate) + #:license (and=> (crate-version-license version*) + string->license)) + (append cargo-inputs cargo-development-inputs))))) + +(define (crate-recursive-import crate-name) + (recursive-import crate-name #f + #:repo->guix-package (lambda (name repo) + (crate->guix-package name)) + #:guix-name crate-name->package-name)) (define (guix-package->crate-name package) "Return the crate name of PACKAGE." @@ -157,6 +252,7 @@ and LICENSE." (define (crate-name->package-name name) (string-append "rust-" (string-join (string-split name #\_) "-"))) + ;;; ;;; Updater ;;; @@ -175,9 +271,9 @@ and LICENSE." (define (latest-release package) "Return an <upstream-source> for the latest release of PACKAGE." (let* ((crate-name (guix-package->crate-name package)) - (callback (lambda* (#:key version #:allow-other-keys) version)) - (version (crate-fetch crate-name callback)) - (url (crate-uri crate-name version))) + (crate (lookup-crate crate-name)) + (version (crate-latest-version crate)) + (url (crate-uri crate-name version))) (upstream-source (package (package-name package)) (version version) diff --git a/guix/import/github.scm b/guix/import/github.scm index fa23fa4c06..df5f6ff32f 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2017, 2018, 2019 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> ;;; ;;; This file is part of GNU Guix. ;;; @@ -49,7 +50,7 @@ false if none is recognized" (define (updated-url url) (if (string-prefix? "https://github.com/" url) (let ((ext (or (find-extension url) "")) - (name (package-name old-package)) + (name (package-upstream-name old-package)) (version (package-version old-package)) (prefix (string-append "https://github.com/" (github-user-slash-repository url))) @@ -161,7 +162,7 @@ empty list." url)) (match (json-fetch (decorate 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 (decorate tag-url) #:headers headers)) @@ -186,7 +187,12 @@ the package e.g. 'bedtools2'. Return #f if there is no releases" (substring tag 0 (+ name-length 1)))) (substring tag (+ name-length 1))) ;; some tags start with a "v" e.g. "v0.25.0" + ;; or with the word "version" e.g. "version.2.1" ;; where some are just the version number + ((string-prefix? "version" tag) + (if (char-set-contains? char-set:digit (string-ref tag 7)) + (substring tag 7) + (substring tag 8))) ((string-prefix? "v" tag) (substring tag 1)) ;; Finally, reject tags that don't start with a digit: diff --git a/guix/import/gnome.scm b/guix/import/gnome.scm index 1ade63e1af..436ec88ef9 100644 --- a/guix/import/gnome.scm +++ b/guix/import/gnome.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -46,7 +46,7 @@ source for metadata." (package name) (version version) (urls (filter-map (lambda (extension) - (match (hash-ref dictionary extension) + (match (assoc-ref dictionary extension) (#f #f) ((? string? relative-url) @@ -86,21 +86,22 @@ not be determined." (json (json->scm port))) (close-port port) (match json - ((4 (? hash-table? releases) _ ...) - (let* ((releases (hash-ref releases upstream-name)) - (latest (hash-fold (lambda (key value result) - (cond ((even-minor-version? key) - (match result - (#f - (cons key value)) - ((newest . _) - (if (version>? key newest) - (cons key value) - result)))) - (else - result))) - #f - releases))) + (#(4 releases _ ...) + (let* ((releases (assoc-ref releases upstream-name)) + (latest (fold (match-lambda* + (((key . value) result) + (cond ((even-minor-version? key) + (match result + (#f + (cons key value)) + ((newest . _) + (if (version>? key newest) + (cons key value) + result)))) + (else + result)))) + #f + releases))) (and latest (jsonish->upstream-source upstream-name latest)))))))) diff --git a/guix/import/kde.scm b/guix/import/kde.scm new file mode 100644 index 0000000000..6873418d62 --- /dev/null +++ b/guix/import/kde.scm @@ -0,0 +1,190 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 David Craven <david@craven.ch> +;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2019 Hartmut Goebel <h.goebel@crazy-compilers.com> +;;; +;;; 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 import kde) + #:use-module (guix http-client) + #:use-module (guix memoization) + #:use-module (guix gnu-maintenance) + #:use-module (guix packages) + #:use-module (guix upstream) + #:use-module (guix utils) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-11) + #:use-module (web uri) + + #:export (%kde-updater)) + +;;; Commentary: +;;; +;;; This package provides not an actual importer but simply an updater for +;;; KDE packages. It grabs available files from the 'ls-lR.bz2' file +;;; available on download.kde.org. +;;; +;;; Code: + +(define (tarball->version tarball) + "Return the version TARBALL corresponds to. TARBALL is a file name like +\"coreutils-8.23.tar.xz\"." + (let-values (((name version) + (gnu-package-name->name+version + (tarball-sans-extension tarball)))) + version)) + +(define %kde-file-list-uri + ;; URI of the file list (ls -lR format) for download.kde.org. + (string->uri "https://download.kde.org/ls-lR.bz2")) + +(define (download.kde.org-files) + ;;"Return the list of files available at download.kde.org." + + (define (ls-lR-line->filename path line) + ;; Remove mode, blocks, user, group, size, date, time and one space, + ;; then prepend PATH + (regexp-substitute + #f (string-match "^(\\S+\\s+){6}\\S+\\s" line) path 'post)) + + (define (canonicalize path) + (let* ((path (if (string-prefix? "/srv/archives/ftp/" path) + (string-drop path (string-length "/srv/archives/ftp")) + path)) + (path (if (string-suffix? ":" path) + (string-drop-right path 1) + path)) + (path (if (not (string-suffix? "/" path)) + (string-append path "/") + path))) + path)) + + (define (write-cache input cache) + "Read bzipped ls-lR from INPUT, and write it as a list of file paths to +CACHE." + (call-with-decompressed-port 'bzip2 input + (lambda (input) + (let loop_dirs ((files '())) + ;; process a new directory block + (let ((path (read-line input))) + (if + (or (eof-object? path) (string= path "")) + (write (reverse files) cache) + (let loop_entries ((path (canonicalize path)) + (files files)) + ;; process entries within the directory block + (let ((line (read-line input))) + (cond + ((eof-object? line) + (write (reverse files) cache)) + ((string-prefix? "-" line) + ;; this is a file entry: prepend to FILES, then re-enter + ;; the loop for remaining entries + (loop_entries path + (cons (ls-lR-line->filename path line) files) + )) + ((not (string= line "")) + ;; this is a non-file entry: ignore it, just re-enter the + ;; loop for remaining entries + (loop_entries path files)) + ;; empty line: directory block end, re-enter the outer + ;; loop for the next block + (#t (loop_dirs files))))))))))) + + (define (cache-miss uri) + (format (current-error-port) "fetching ~a...~%" (uri->string uri))) + + (let* ((port (http-fetch/cached %kde-file-list-uri + #:ttl 3600 + #:write-cache write-cache + #:cache-miss cache-miss)) + (files (read port))) + (close-port port) + files)) + +(define (uri->kde-path-pattern uri) + "Build a regexp from the package's URI suitable for matching the package +path version-agnostic. + +Example: +Input: + mirror://kde//stable/frameworks/5.55/portingAids/kross-5.55.0.zip +Output: + //stable/frameworks/[^/]+/portingAids/ +" + + (define version-regexp + ;; regexp for matching versions as used in the ld-lR file + (make-regexp + (string-join '("^([0-9]+\\.)+[0-9]+-?" ;; 5.12.90, 4.2.0-preview + "^[0-9]+$" ;; 20031002 + ".*-([0-9]+\\.)+[0-9]+$") ;; kdepim-4.6.1 + "|"))) + + (define (version->pattern part) + ;; If a path element might be a version, replace it by a catch-all part + (if (regexp-exec version-regexp part) + "[^/]+" + part)) + + (let* ((path (uri-path uri)) + (directory-parts (string-split (dirname path) #\/))) + (make-regexp + (string-append + (string-join (map version->pattern directory-parts) "/") + "/")))) + +(define (latest-kde-release package) + "Return the latest release of PACKAGE, a KDE package, or #f if it could +not be determined." + (let* ((uri (string->uri (origin-uri (package-source package)))) + (path-rx (uri->kde-path-pattern uri)) + (name (package-upstream-name package)) + (files (download.kde.org-files)) + (relevant (filter (lambda (file) + (and (regexp-exec path-rx file) + (release-file? name (basename file)))) + files))) + (match (sort relevant (lambda (file1 file2) + (version>? (tarball-sans-extension + (basename file1)) + (tarball-sans-extension + (basename file2))))) + ((and tarballs (reference _ ...)) + (let* ((version (tarball->version reference)) + (tarballs (filter (lambda (file) + (string=? (tarball-sans-extension + (basename file)) + (tarball-sans-extension + (basename reference)))) + tarballs))) + (upstream-source + (package name) + (version version) + (urls (map (lambda (file) + (string-append "mirror://kde/" file)) + tarballs))))) + (() + #f)))) + +(define %kde-updater + (upstream-updater + (name 'kde) + (description "Updater for KDE packages") + (pred (url-prefix-predicate "mirror://kde/")) + (latest latest-kde-release))) diff --git a/guix/import/opam.scm b/guix/import/opam.scm index 5dcc0e97a3..7f089a5cf3 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -238,7 +238,9 @@ path to the repository." (version (find-latest-version name repository)) (file (string-append repository "/packages/" name "/" name "." version "/opam"))) `(("metadata" ,@(get-metadata file)) - ("version" . ,version)))) + ("version" . ,(if (string-prefix? "v" version) + (substring version 1) + version))))) (define (opam->guix-package name) (and-let* ((opam-file (opam-fetch name)) @@ -283,7 +285,7 @@ path to the repository." 'ocaml-build-system)) ,@(if (null? inputs) '() - `((inputs ,(list 'quasiquote inputs)))) + `((propagated-inputs ,(list 'quasiquote inputs)))) ,@(if (null? native-inputs) '() `((native-inputs ,(list 'quasiquote native-inputs)))) diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index 9b3d80a02e..354cae9c4c 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -437,7 +437,8 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (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://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))) diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm index 194bea633e..14150201b5 100644 --- a/guix/import/stackage.scm +++ b/guix/import/stackage.scm @@ -95,7 +95,7 @@ (lts-info-packages (stackage-lts-info-fetch lts-version)))) "Fetch Cabal file for PACKAGE-NAME from hackage.haskell.org. The retrieved -vesion corresponds to the version of PACKAGE-NAME specified in the LTS-VERSION +version corresponds to the version of PACKAGE-NAME specified in the LTS-VERSION release at stackage.org. Return the `package' S-expression corresponding to that package, or #f on failure. PACKAGES-INFO is the alist with the packages included in the Stackage LTS release." diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 2a3b7341fb..4694b6e7ef 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -2,7 +2,7 @@ ;;; Copyright © 2012, 2013, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Jelle Licht <jlicht@fsfe.org> ;;; Copyright © 2016 David Craven <david@craven.ch> -;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2017, 2019 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> ;;; Copyright © 2019 Robert Vollmert <rob@vllmrt.net> ;;; @@ -212,10 +212,19 @@ with dashes." (define (beautify-description description) "Improve the package DESCRIPTION by turning a beginning sentence fragment into a proper sentence and by using two spaces between sentences." - (let ((cleaned (if (string-prefix? "A " description) - (string-append "This package provides a" - (substring description 1)) - description))) + (let ((cleaned (cond + ((string-prefix? "A " description) + (string-append "This package provides a" + (substring description 1))) + ((string-prefix? "Provides " description) + (string-append "This package provides" + (substring description + (string-length "Provides")))) + ((string-prefix? "Functions " description) + (string-append "This package provides functions" + (substring description + (string-length "Functions")))) + (else description)))) ;; Use double spacing between sentences (regexp-substitute/global #f "\\. \\b" cleaned 'pre ". " 'post))) @@ -252,6 +261,9 @@ package definition." (match guix-package (('package ('name (? string? name)) _ ...) `(define-public ,(string->symbol name) + ,guix-package)) + (('let anything ('package ('name (? string? name)) _ ...)) + `(define-public ,(string->symbol name) ,guix-package)))) (define (build-system-modules) |