summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2020-07-03 22:45:21 +0200
committerLudovic Courtès <ludo@gnu.org>2020-07-03 23:53:31 +0200
commit00290e7365aed9b34603bfb3cd6e8a4bdc1e7259 (patch)
tree8ae5c67671bb571101eaf25c145dbe31230efed8 /guix
parent37c3e0bbaf2efe137b434f866ca431803d33e0a9 (diff)
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'.
Diffstat (limited to 'guix')
-rw-r--r--guix/import/cpan.scm26
-rw-r--r--guix/import/cran.scm28
-rw-r--r--guix/import/crate.scm12
-rw-r--r--guix/import/elpa.scm12
-rw-r--r--guix/import/gem.scm16
-rw-r--r--guix/import/hackage.scm19
-rw-r--r--guix/import/pypi.scm24
-rw-r--r--guix/upstream.scm31
8 files changed, 48 insertions, 120 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 <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/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/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 <upstream-source> 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,24 +162,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\"."