[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
02/05: upstream: Define 'url-predicate' and use it.
|
From: |
guix-commits |
|
Subject: |
02/05: upstream: Define 'url-predicate' and use it. |
|
Date: |
Fri, 3 Jul 2020 17:54:11 -0400 (EDT) |
civodul pushed a commit to branch master
in repository guix.
commit 00290e7365aed9b34603bfb3cd6e8a4bdc1e7259
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Fri Jul 3 22:45:21 2020 +0200
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 | 31 ++++++++++++++++++-------------
8 files changed, 48 insertions(+), 120 deletions(-)
diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm
index 6bcd2ce..085467b 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 b822fbc..a1275b4 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 e3ec11d..796a764 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 2d4487d..871b918 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 bd5d5b3..a2d99dd 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 dbc1afa..35c67ca 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 f93fa88..b20c230 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 67d0eee..ff33c53 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\"."