add pointer to annex.security.allowed-url-schemes

Sponsored-by: Kevin Mueller on Patreon

diff --git a/Annex/Url.hs b/Annex/Url.hs
index f76c29516bf4f3f05f46997e93d09866bfc10821..1171aa42d580c3add67be5c7e4aba3c2aab7c31a 100644 (file)
--- 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 62663321d800a3051c8f7c0aecea62484b5a3125..4f3a4125c2de46745c7256a62bb5528e57a2a70d 100644 (file)
--- 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