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

avoid deprecation warnings when built with http-client >= 0.4.18

Browse source 
Since I want git-annex to keep building on debian stable, I need to still
support the old http-client, which required explicit calls to
closeManager, or use of withManager to get Managers to close at appropriate
times. This is not needed in the new version, and so they added a
deprecation warning. IMHO much too early, because look at the mess I had to
go through to avoid that deprecation warning while supporting both
versions..
This commit is contained in:
Joey Hess 2015-10-01 13:47:54 -04:00
parent cad3349001
commit 9e3ac97608
2 changed files with 25 additions and 12 deletions
Download patch file Download diff file Expand all files Collapse all files

4
Remote/S3.hs
View file

@ -21,7 +21,7 @@ import qualified Data.ByteString as S
import qualified Data.Map as M import qualified Data.Map as M
import Data.Char import Data.Char
import Network.Socket (HostName) import Network.Socket (HostName)
import Network.HTTP.Conduit (Manager, newManager, closeManager) import Network.HTTP.Conduit (Manager, newManager)
import Network.HTTP.Client (defaultManagerSettings, managerResponseTimeout, responseStatus, responseBody, RequestBody(..)) import Network.HTTP.Client (defaultManagerSettings, managerResponseTimeout, responseStatus, responseBody, RequestBody(..))
import Network.HTTP.Types import Network.HTTP.Types
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
@ -48,7 +48,7 @@ import Utility.Metered
import Utility.DataUnits import Utility.DataUnits
import Annex.Content import Annex.Content
import Annex.Url (withUrlOptions) import Annex.Url (withUrlOptions)
import Utility.Url (checkBoth) import Utility.Url (checkBoth, closeManager)
type BucketName = String type BucketName = String

33
Utility/Url.hs
View file

@ -11,6 +11,7 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
module Utility.Url ( module Utility.Url (
closeManager,
URLString, URLString,
UserAgent, UserAgent,
UrlOptions, UrlOptions,
@ -31,11 +32,21 @@ import Utility.Tmp
import qualified Build.SysConfig import qualified Build.SysConfig
import Network.URI import Network.URI
import Network.HTTP.Conduit
import Network.HTTP.Types import Network.HTTP.Types
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as B8 import qualified Data.ByteString.UTF8 as B8
import Control.Monad.Trans.Resource
import Network.HTTP.Conduit hiding (closeManager)
-- closeManager is needed with older versions of http-client,
-- but not new versions, which warn about using it. Urgh.
#if ! MIN_VERSION_http_client(0,4,18)
import Network.HTTP.Client (closeManager)
#else
closeManager :: Manager -> IO ()
closeManager _ = return ()
#endif
type URLString = String type URLString = String
@ -164,16 +175,18 @@ getUrlInfo url uo = case parseURIRelaxed url of
firstheader h = headMaybe . map snd . firstheader h = headMaybe . map snd .
filter (\p -> fst p == h) . responseHeaders filter (\p -> fst p == h) . responseHeaders
existsconduit req = withManager $ \mgr -> do existsconduit req = do
mgr <- newManager tlsManagerSettings
let req' = headRequest (applyRequest uo req) let req' = headRequest (applyRequest uo req)
resp <- http req' mgr ret <- runResourceT $ do
-- forces processing the response before the resp <- http req' mgr
-- manager is closed -- forces processing the response before the
ret <- liftIO $ if responseStatus resp == ok200 -- manager is closed
then found liftIO $ if responseStatus resp == ok200
(extractlen resp) then found
(extractfilename resp) (extractlen resp)
else dne (extractfilename resp)
else dne
liftIO $ closeManager mgr liftIO $ closeManager mgr
return ret return ret