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'.

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\"."