Remove http-conduit (<2.2.0) constraint
Since https://github.com/aristidb/aws/issues/206 is resolved, this constraint is no longer necessary. However, http-conduit (>=2.2.0) requires http-client (>=0.5.0) which introduces some breaking changes. This commit also implements those changes depending on the version. Fixes: https://git-annex.branchable.com/bugs/Build_with_aws_head_fails/ Signed-off-by: Alper Nebi Yasak <alpernebiyasak@gmail.com>
This commit is contained in:
parent
bbc5e4f4f3
commit
93a22a1c97
4 changed files with 33 additions and 3 deletions
|
@ -49,6 +49,12 @@ import Annex.Content
|
||||||
import Annex.Url (withUrlOptions)
|
import Annex.Url (withUrlOptions)
|
||||||
import Utility.Url (checkBoth, managerSettings, closeManager)
|
import Utility.Url (checkBoth, managerSettings, closeManager)
|
||||||
|
|
||||||
|
#if MIN_VERSION_http_client(0,5,0)
|
||||||
|
import Network.HTTP.Client (responseTimeoutNone)
|
||||||
|
#else
|
||||||
|
responseTimeoutNone = Nothing
|
||||||
|
#endif
|
||||||
|
|
||||||
type BucketName = String
|
type BucketName = String
|
||||||
|
|
||||||
remote :: RemoteType
|
remote :: RemoteType
|
||||||
|
@ -430,7 +436,7 @@ withS3HandleMaybe c gc u a = do
|
||||||
where
|
where
|
||||||
s3cfg = s3Configuration c
|
s3cfg = s3Configuration c
|
||||||
httpcfg = managerSettings
|
httpcfg = managerSettings
|
||||||
{ managerResponseTimeout = Nothing }
|
{ managerResponseTimeout = responseTimeoutNone }
|
||||||
|
|
||||||
s3Configuration :: RemoteConfig -> S3.S3Configuration AWS.NormalQuery
|
s3Configuration :: RemoteConfig -> S3.S3Configuration AWS.NormalQuery
|
||||||
s3Configuration c = cfg
|
s3Configuration c = cfg
|
||||||
|
|
|
@ -5,6 +5,7 @@
|
||||||
- Licensed under the GNU GPL version 3 or higher.
|
- Licensed under the GNU GPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
{-# LANGUAGE CPP #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
|
||||||
module Remote.WebDAV (remote, davCreds, configUrl) where
|
module Remote.WebDAV (remote, davCreds, configUrl) where
|
||||||
|
@ -34,6 +35,10 @@ import Utility.Url (URLString, matchStatusCodeException)
|
||||||
import Annex.UUID
|
import Annex.UUID
|
||||||
import Remote.WebDAV.DavLocation
|
import Remote.WebDAV.DavLocation
|
||||||
|
|
||||||
|
#if MIN_VERSION_http_client(0,5,0)
|
||||||
|
import Network.HTTP.Client (HttpExceptionContent(..), responseStatus)
|
||||||
|
#endif
|
||||||
|
|
||||||
remote :: RemoteType
|
remote :: RemoteType
|
||||||
remote = RemoteType {
|
remote = RemoteType {
|
||||||
typename = "webdav",
|
typename = "webdav",
|
||||||
|
@ -302,6 +307,17 @@ goDAV (DavHandle ctx user pass _) a = choke $ run $ prettifyExceptions $ do
|
||||||
{- Catch StatusCodeException and trim it to only the statusMessage part,
|
{- Catch StatusCodeException and trim it to only the statusMessage part,
|
||||||
- eliminating a lot of noise, which can include the whole request that
|
- eliminating a lot of noise, which can include the whole request that
|
||||||
- failed. The rethrown exception is no longer a StatusCodeException. -}
|
- failed. The rethrown exception is no longer a StatusCodeException. -}
|
||||||
|
#if MIN_VERSION_http_client(0,5,0)
|
||||||
|
prettifyExceptions :: DAVT IO a -> DAVT IO a
|
||||||
|
prettifyExceptions a = catchJust (matchStatusCodeException (const True)) a go
|
||||||
|
where
|
||||||
|
go (HttpExceptionRequest _ (StatusCodeException response message)) = error $ unwords
|
||||||
|
[ "DAV failure:"
|
||||||
|
, show (responseStatus response)
|
||||||
|
, show (message)
|
||||||
|
]
|
||||||
|
go e = throwM e
|
||||||
|
#else
|
||||||
prettifyExceptions :: DAVT IO a -> DAVT IO a
|
prettifyExceptions :: DAVT IO a -> DAVT IO a
|
||||||
prettifyExceptions a = catchJust (matchStatusCodeException (const True)) a go
|
prettifyExceptions a = catchJust (matchStatusCodeException (const True)) a go
|
||||||
where
|
where
|
||||||
|
@ -311,6 +327,7 @@ prettifyExceptions a = catchJust (matchStatusCodeException (const True)) a go
|
||||||
, show (statusMessage status)
|
, show (statusMessage status)
|
||||||
]
|
]
|
||||||
go e = throwM e
|
go e = throwM e
|
||||||
|
#endif
|
||||||
|
|
||||||
prepDAV :: DavUser -> DavPass -> DAVT IO ()
|
prepDAV :: DavUser -> DavPass -> DAVT IO ()
|
||||||
prepDAV user pass = do
|
prepDAV user pass = do
|
||||||
|
|
|
@ -350,8 +350,16 @@ hUserAgent = "User-Agent"
|
||||||
-
|
-
|
||||||
- > catchJust (matchStatusCodeException (== notFound404))
|
- > catchJust (matchStatusCodeException (== notFound404))
|
||||||
-}
|
-}
|
||||||
|
#if MIN_VERSION_http_client(0,5,0)
|
||||||
|
matchStatusCodeException :: (Status -> Bool) -> HttpException -> Maybe HttpException
|
||||||
|
matchStatusCodeException want e@(HttpExceptionRequest _ (StatusCodeException r _))
|
||||||
|
| want (responseStatus r) = Just e
|
||||||
|
| otherwise = Nothing
|
||||||
|
matchStatusCodeException _ _ = Nothing
|
||||||
|
#else
|
||||||
matchStatusCodeException :: (Status -> Bool) -> HttpException -> Maybe HttpException
|
matchStatusCodeException :: (Status -> Bool) -> HttpException -> Maybe HttpException
|
||||||
matchStatusCodeException want e@(StatusCodeException s _ _)
|
matchStatusCodeException want e@(StatusCodeException s _ _)
|
||||||
| want s = Just e
|
| want s = Just e
|
||||||
| otherwise = Nothing
|
| otherwise = Nothing
|
||||||
matchStatusCodeException _ _ = Nothing
|
matchStatusCodeException _ _ = Nothing
|
||||||
|
#endif
|
||||||
|
|
|
@ -357,8 +357,7 @@ Executable git-annex
|
||||||
resourcet,
|
resourcet,
|
||||||
http-client,
|
http-client,
|
||||||
http-types,
|
http-types,
|
||||||
-- Old version needed due to https://github.com/aristidb/aws/issues/206
|
http-conduit,
|
||||||
http-conduit (<2.2.0),
|
|
||||||
time,
|
time,
|
||||||
old-locale,
|
old-locale,
|
||||||
esqueleto,
|
esqueleto,
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue