From 9905ec19a76045c478dbede03501099171e48bac Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Fri, 2 Jul 2021 10:43:44 -0400
Subject: [PATCH] add pointer to annex.security.allowed-url-schemes

Sponsored-by: Kevin Mueller on Patreon
---
 Annex/Url.hs   |  1 +
 Utility/Url.hs | 13 ++++++++-----
 2 files changed, 9 insertions(+), 5 deletions(-)

diff --git a/Annex/Url.hs b/Annex/Url.hs
index f76c29516b..1171aa42d5 100644
--- a/Annex/Url.hs
+++ b/Annex/Url.hs
@@ -73,6 +73,7 @@ getUrlOptions = Annex.getState Annex.urloptions >>= \case
 			<*> pure urldownloader
 			<*> pure manager
 			<*> (annexAllowedUrlSchemes <$> Annex.getGitConfig)
+			<*> pure (Just (\u -> "Configuration of annex.security.allowed-url-schemes does not allow accessing " ++ show u))
 			<*> pure U.noBasicAuth
 	
 	headers = annexHttpHeadersCommand <$> Annex.getGitConfig >>= \case
diff --git a/Utility/Url.hs b/Utility/Url.hs
index 62663321d8..4f3a4125c2 100644
--- a/Utility/Url.hs
+++ b/Utility/Url.hs
@@ -97,6 +97,7 @@ data UrlOptions = UrlOptions
 	, applyRequest :: Request -> Request
 	, httpManager :: Manager
 	, allowedSchemes :: S.Set Scheme
+	, disallowedSchemeMessage :: Maybe (URI -> String)
 	, getBasicAuth :: GetBasicAuth
 	}
 
@@ -115,11 +116,12 @@ defUrlOptions = UrlOptions
 	<*> pure id
 	<*> newManager tlsManagerSettings
 	<*> pure (S.fromList $ map mkScheme ["http", "https", "ftp"])
+	<*> pure Nothing
 	<*> pure noBasicAuth
 
-mkUrlOptions :: Maybe UserAgent -> Headers -> UrlDownloader -> Manager -> S.Set Scheme -> GetBasicAuth -> UrlOptions
-mkUrlOptions defuseragent reqheaders urldownloader manager getbasicauth =
-	UrlOptions useragent reqheaders urldownloader applyrequest manager getbasicauth
+mkUrlOptions :: Maybe UserAgent -> Headers -> UrlDownloader -> Manager -> S.Set Scheme -> Maybe (URI -> String) -> GetBasicAuth -> UrlOptions
+mkUrlOptions defuseragent reqheaders urldownloader =
+	UrlOptions useragent reqheaders urldownloader applyrequest
   where
 	applyrequest = \r -> r { requestHeaders = requestHeaders r ++ addedheaders }
 	addedheaders = uaheader ++ otherheaders
@@ -156,8 +158,9 @@ curlParams uo ps = ps ++ uaparams ++ headerparams ++ addedparams ++ schemeparams
 checkPolicy :: UrlOptions -> URI -> IO (Either String a) -> IO (Either String a)
 checkPolicy uo u a
 	| allowedScheme uo u = a
-	| otherwise = return $ Left $
-		"Configuration does not allow accessing " ++ show u
+	| otherwise = return $ Left $ case disallowedSchemeMessage uo of
+		Nothing -> "Configuration does not allow accessing" ++ show u
+		Just f -> f u
 
 unsupportedUrlScheme :: URI -> String
 unsupportedUrlScheme u = "Unsupported url scheme " ++ show u
-- 
2.30.2