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'.
2020-07-03 22:45:21 +02:00 · 2020-07-03 22:45:21 +02:00 · 00290e7365
parent 37c3e0bbaf
commit 00290e7365
8 changed files with 49 additions and 121 deletions
--- 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."
--- 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
--- 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."
--- 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
--- 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."
--- 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."
--- 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."
--- 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 <origin> 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