@@ -1,13 +1,11 @@
11{-# LANGUAGE RankNTypes #-}
22{-# LANGUAGE ScopedTypeVariables #-}
3−{-# LANGUAGE TypeFamilies, UndecidableInstances #-}
43
54module Docker.Client.Http where
65
7−import Control.Monad.Base (MonadBase(..), liftBaseDefault)
8−import Control.Monad.Catch (MonadMask(..), MonadCatch(..), MonadThrow(..))
6+-- import Control.Monad.Base (MonadBase(..), liftBaseDefault)
7+import Control.Monad.Catch (MonadMask(..))
98import Control.Monad.Reader (ReaderT(..), runReaderT)
10−import Control.Monad.Trans.Control (MonadBaseControl(..), ComposeSt, defaultLiftBaseWith, defaultRestoreM, MonadTransControl(..), defaultLiftWith, defaultRestoreT)
119import qualified Data.ByteString.Char8 as BSC
1210import qualified Data.ByteString.Lazy as BL
1311import Data.Conduit (Sink)
@@ -17,7 +15,7 @@ import Data.Text.Encoding (encodeUtf8)
1715import Data.X509 (CertificateChain (..))
1816import Data.X509.CertificateStore (makeCertificateStore)
1917import Data.X509.File (readKeyFile, readSignedObject)
20−import Network.HTTP.Client (defaultManagerSettings, httpLbs,
18+import Network.HTTP.Client (defaultManagerSettings,
2119 managerRawConnection, method,
2220 newManager, parseUrl,
2321 requestBody, requestHeaders)
@@ -33,7 +31,7 @@ import Network.TLS (ClientHooks (..),
3331import Network.TLS.Extra (ciphersuite_strong)
3432import System.X509 (getSystemCertificateStore)
3533
36−import Control.Exception (try)
34+import Control.Monad.Catch (try)
3735import Control.Monad.Except
3836import Control.Monad.Reader.Class
3937import Data.Text as T
@@ -83,8 +81,8 @@ instance MonadTrans DockerT where
8381instance MonadIO m => MonadIO (DockerT m) where
8482 liftIO = lift . liftIO
8583
86−instance MonadBase IO m => MonadBase IO (DockerT m) where
87− liftBase = liftBaseDefault
84+-- instance MonadBase IO m => MonadBase IO (DockerT m) where
85+-- liftBase = liftBaseDefault
8886
8987runDockerT :: Monad m => (DockerClientOpts, HttpHandler m) -> DockerT m a -> m a
9088runDockerT (opts, h) r = runReaderT (unDockerT r) (opts, h)
@@ -106,38 +104,32 @@ mkHttpRequest verb e opts = request
106104 requestHeaders = [("Content-Type", "application/json; charset=utf-8")]}) $ getEndpointRequestBody e) <$> request'
107105 -- Note: Do we need to set length header?
108106
109−defaultHttpHandler :: MonadIO m => HttpHandler m
110−defaultHttpHandler = HttpHandler $ \request sink -> do
107+defaultHttpHandler :: (MonadIO m, MonadMask m) => m (HttpHandler m)
108+defaultHttpHandler = do
111109 manager <- liftIO $ newManager defaultManagerSettings
112− httpHandler manager request sink
110+ return $ httpHandler manager
113111
114−httpHandler = undefined
115−
116−{-
117−httpHandler :: MonadIO m => HTTP.Manager -> HttpHandler m
118−httpHandler manager request' sink = liftIO $ do -- runResourceT ..
112+httpHandler :: (MonadIO m, MonadMask m) => HTTP.Manager -> HttpHandler m
113+httpHandler manager = HttpHandler $ \request' sink -> do -- runResourceT ..
114+ let request = NHS.setRequestManager manager request'
119115 try (NHS.httpSink request sink) >>= \res -> case res of
120− Right res -> return $ Right res
116+ Right res -> return res
121117 Left HTTP.FailedConnectionException{} -> return $ Left DockerConnectionError
122118 Left HTTP.FailedConnectionException2{} -> return $ Left DockerConnectionError
123119 Left e -> return $ Left $ GenericDockerError (T.pack $ show e)
124120
125− where
126− request = NHS.setRequestManager request'
127−-}
128−
129121-- | Connect to a unix domain socket (the default docker socket is
130122-- at \/var\/run\/docker.sock)
131123--
132124-- Docker seems to ignore the hostname in requests sent over unix domain
133125-- sockets (and the port obviously doesn't matter either)
134−unixHttpHandler :: MonadIO m => FilePath -- ^ The socket to connect to
135− -> HttpHandler m
136−unixHttpHandler fp = HttpHandler $ \request sink -> do
126+unixHttpHandler :: (MonadIO m, MonadMask m) => FilePath -- ^ The socket to connect to
127+ -> m (HttpHandler m)
128+unixHttpHandler fp = do
137129 let mSettings = defaultManagerSettings
138130 { managerRawConnection = return $ openUnixSocket fp}
139131 manager <- liftIO $ newManager mSettings
140− httpHandler manager request sink
132+ return $ httpHandler manager
141133
142134 where
143135 openUnixSocket filePath _ _ _ = do