From 00290e7365aed9b34603bfb3cd6e8a4bdc1e7259 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 3 Jul 2020 22:45:21 +0200 Subject: [PATCH] upstream: Define 'url-predicate' and use it. * guix/upstream.scm (url-predicate): New procedure. (url-prefix-predicate): Define in terms of 'url-predicate'. * guix/import/cpan.scm (cpan-package?): Use 'url-predicate'. * guix/import/cran.scm (cran-package?) (bioconductor-package?) (bioconductor-data-package?) (bioconductor-experiment-package?): Likewise. * guix/import/crate.scm (crate-package?): Likewise. * guix/import/elpa.scm (package-from-gnu.org?): Likewise. * guix/import/hackage.scm (hackage-package?): Likewise. * guix/import/pypi.scm (pypi-package?): Likewise. * guix/import/gem.scm (gem-package?): Use 'url-prefix-predicate'. --- guix/import/cpan.scm | 26 +++++++------------------- guix/import/cran.scm | 28 ++++------------------------ guix/import/crate.scm | 12 ++---------- guix/import/elpa.scm | 12 +++++------- guix/import/gem.scm | 16 ++-------------- guix/import/hackage.scm | 19 +++---------------- guix/import/pypi.scm | 24 +++++++----------------- guix/upstream.scm | 33 +++++++++++++++++++-------------- 8 files changed, 49 insertions(+), 121 deletions(-) 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 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 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 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 ''." (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 for the latest release of PACKAGE." 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 for the latest release of PACKAGE." diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index f93fa8831f..b20c2300f6 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -510,23 +510,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 for the latest release of PACKAGE." diff --git a/guix/upstream.scm b/guix/upstream.scm index 67d0eeefbb..ff33c534fe 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -51,6 +51,7 @@ upstream-source-archive-types upstream-source-input-changes + url-predicate url-prefix-predicate coalesce-sources @@ -161,23 +162,27 @@ S-expression PACKAGE-SEXP." current-propagated new-propagated)))))) (_ '()))) +(define* (url-predicate matching-url?) + "Return a predicate that returns true when passed a package whose source is +an with the URL-FETCH method, and one of its URLs passes +MATCHING-URL?." + (lambda (package) + (match (package-source package) + ((? origin? origin) + (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." - (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))) - (_ #f)))) + (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