mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

remove support for old http-client version

Browse source 
git-annex already bumped to a newer version for the http security fix.

This commit was sponsored by mo on Patreon.
This commit is contained in:
Joey Hess 2018-10-03 12:00:07 -04:00
parent c88e8c8249
commit 502c5a4917
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
1 changed files with 6 additions and 19 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

25
Utility/Url.hs
View file

@ -193,7 +193,7 @@ assumeUrlExists = UrlInfo True Nothing Nothing
getUrlInfo :: URLString -> UrlOptions -> IO UrlInfo getUrlInfo :: URLString -> UrlOptions -> IO UrlInfo
getUrlInfo url uo = case parseURIRelaxed url of getUrlInfo url uo = case parseURIRelaxed url of
Just u -> checkPolicy uo u dne $ Just u -> checkPolicy uo u dne $
case (urlDownloader uo, parseUrlConduit (show u)) of case (urlDownloader uo, parseUrlRequest (show u)) of
(DownloadWithConduit, Just req) -> (DownloadWithConduit, Just req) ->
existsconduit req existsconduit req
`catchNonAsync` (const $ return dne) `catchNonAsync` (const $ return dne)
@ -300,7 +300,7 @@ download meterupdate url file uo =
where where
go = case parseURIRelaxed url of go = case parseURIRelaxed url of
Just u -> checkPolicy uo u False $ Just u -> checkPolicy uo u False $
case (urlDownloader uo, parseUrlConduit (show u)) of case (urlDownloader uo, parseUrlRequest (show u)) of
(DownloadWithConduit, Just req) -> (DownloadWithConduit, Just req) ->
downloadconduit req downloadconduit req
(DownloadWithConduit, Nothing) (DownloadWithConduit, Nothing)
@ -452,36 +452,23 @@ downloadPartial url uo n = case parseURIRelaxed url of
Nothing -> return Nothing Nothing -> return Nothing
Just u -> go u `catchNonAsync` const (return Nothing) Just u -> go u `catchNonAsync` const (return Nothing)
where where
go u = case parseUrlConduit (show u) of go u = case parseUrlRequest (show u) of
Nothing -> return Nothing Nothing -> return Nothing
Just req -> do Just req -> do
let req' = applyRequest uo req let req' = applyRequest uo req
liftIO $ debugM "url" (show req') liftIO $ debugM "url" (show req')
withResponse req' (httpManager uo) $ \resp -> withResponse req' (httpManager uo) $ \resp ->
if responseStatus resp == ok200 if responseStatus resp == ok200
then Just <$> brread n [] (responseBody resp) then Just <$> brReadSome (responseBody resp) n
else return Nothing else return Nothing
-- could use brReadSome here, needs newer http-client dependency
brread n' l rb
| n' <= 0 = return (L.fromChunks (reverse l))
| otherwise = do
bs <- brRead rb
if B.null bs
then return (L.fromChunks (reverse l))
else brread (n' - B.length bs) (bs:l) rb
{- Allows for spaces and other stuff in urls, properly escaping them. -} {- Allows for spaces and other stuff in urls, properly escaping them. -}
parseURIRelaxed :: URLString -> Maybe URI parseURIRelaxed :: URLString -> Maybe URI
parseURIRelaxed s = maybe (parseURIRelaxed' s) Just $ parseURIRelaxed s = maybe (parseURIRelaxed' s) Just $
parseURI $ escapeURIString isAllowedInURI s parseURI $ escapeURIString isAllowedInURI s
parseUrlConduit :: URLString -> Maybe Request parseUrlRequest :: URLString -> Maybe Request
#if MIN_VERSION_http_client(0,4,30) parseUrlRequest = parseUrlThrow
parseUrlConduit = parseUrlThrow
#else
parseUrlConduit = parseUrl
#endif
{- Some characters like '[' are allowed in eg, the address of {- Some characters like '[' are allowed in eg, the address of
- an uri, but cannot appear unescaped further along in the uri. - an uri, but cannot appear unescaped further along in the uri.