[bug#47670] [PATCH 1/2] upstream: Add predicate for Git URLs.

[Xinglu Chen <public@yoctocell.xyz>]

* guix/upstream.scm (git-url-predicate): New procedure.
---
 guix/upstream.scm | 20 ++++++++++++++++++++
 1 file changed, 20 insertions(+)

diff --git a/guix/upstream.scm b/guix/upstream.scm
index 632e9ebc4f..47d11043dd 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
 ;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -24,6 +25,7 @@
   #:use-module (guix discovery)
   #:use-module ((guix download)
                 #:select (download-to-store url-fetch))
+  #:use-module (guix git-download)
   #:use-module (guix gnupg)
   #:use-module (guix packages)
   #:use-module (guix diagnostics)
@@ -54,6 +56,7 @@
 
             url-predicate
             url-prefix-predicate
+            git-url-predicate
             coalesce-sources
 
             upstream-updater
@@ -185,6 +188,23 @@ MATCHING-URL?."
 source URLs starts with PREFIX."
   (url-predicate (cut string-prefix? prefix <>)))
 
+(define (git-url-predicate matching-url?)
+  "Return a predicate that returns true when passed a package whose source is
+an <origin> with the GIT-FETCH method, and one of its URLs passes
+MATCHING-URL?."
+  (lambda (package)
+    (match (package-source package)
+      ((? origin? origin)
+       (and (eq? (origin-method origin) git-fetch)
+            (match (origin-uri origin)
+              ((? git-reference? git-reference)
+               (matching-url? (git-reference-url git-reference)))
+              (((? git-reference? git-reference) ...)
+               (any matching-url? (git-reference-url git-reference)))
+              (_
+               #f))))
+      (_ #f))))
+
 (define (upstream-source-archive-types release)
   "Return the available types of archives for RELEASE---a list of strings such
 as \"gz\" or \"xz\"."
-- 
2.31.1