git.iko.soy/docker-hs
on master help sign in
Updated API with streaming support
03e93eaJames Parker
src/Docker/Client/Api.hs+4−44
compare with master
unifiedsplit
@@ -24,15 +24,13 @@ module Docker.Client.Api (
24import Control.Monad.Catch (MonadMask(..))
24import Control.Monad.Catch (MonadMask(..))
25import Control.Monad.IO.Class
25import Control.Monad.IO.Class
26import Control.Monad.Reader (ask, lift)
26import Control.Monad.Reader (ask, lift)
27−import Control.Monad.Trans.Resource
28import Data.Aeson (FromJSON, eitherDecode')
27import Data.Aeson (FromJSON, eitherDecode')
29import qualified Data.ByteString as BS
28import qualified Data.ByteString as BS
30import qualified Data.ByteString.Lazy as BSL
29import qualified Data.ByteString.Lazy as BSL
31−import Data.Conduit (($$), Sink)
30+import Data.Conduit (Sink)
32import qualified Data.Conduit.Binary as Conduit
31import qualified Data.Conduit.Binary as Conduit
33import qualified Data.Text as Text
32import qualified Data.Text as Text
34−import Network.HTTP.Client (responseBody, responseStatus)
33+import Network.HTTP.Client (responseStatus)
35−import qualified Network.HTTP.Simple as NHS
36import Network.HTTP.Types (StdMethod (..))
34import Network.HTTP.Types (StdMethod (..))
37
35
38import Docker.Client.Http
36import Docker.Client.Http
@@ -52,10 +50,7 @@ requestHelper' verb endpoint sink = do
52 Nothing ->
50 Nothing ->
53 return $ Left $ DockerInvalidRequest endpoint
51 return $ Left $ DockerInvalidRequest endpoint
54 Just request -> do
52 Just request -> do
55− -- response <- ExceptT $ lift $ httpHandler request $ const Conduit.sinkLbs
56− -- TODO: Catch things XXX
57−
58− -- TODO: Do we need runResourceT? XX
53+ -- JP: Do we need runResourceT?
59 -- lift $ NHS.httpSink request $ \response ->
54 -- lift $ NHS.httpSink request $ \response ->
60 lift $ httpHandler request $ \response ->
55 lift $ httpHandler request $ \response ->
61 -- Check status code.
56 -- Check status code.
@@ -64,42 +59,7 @@ requestHelper' verb endpoint sink = do
64 Just err ->
59 Just err ->
65 return $ Left err
60 return $ Left err
66 Nothing ->
61 Nothing ->
67− fmap Right sink -- $ Conduit.sinkLbs response
62+ fmap Right sink
68− -- return
69−
70− -- lift $ runResourceT $ do
71− -- NHS.httpSource request $$ \response -> do
72−
73− -- -- Check status code.
74− -- let status = responseStatus response
75−
76− -- -- TODO
77− -- maybe (return ()) throwError $
78− -- statusCodeToError endpoint status
79−
80− -- httpHandler response
81− -- -- return response
82−
83−-- requestHelper :: (Monad m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError Response)
84−-- requestHelper verb endpoint = runExceptT $ do
85−-- (opts, HttpHandler httpHandler) <- lift ask
86−-- case mkHttpRequest verb endpoint opts of
87−-- Nothing ->
88−-- throwError $ DockerInvalidRequest endpoint
89−-- Just request -> do
90−-- -- response <- ExceptT $ lift $ httpHandler request $ const Conduit.sinkLbs
91−-- lift $ runResourceT $ do
92−-- NHS.httpSource request $$ \response -> do
93−--
94−-- -- Check status code.
95−-- let status = responseStatus response
96−--
97−-- -- TODO
98−-- maybe (return ()) throwError $
99−-- statusCodeToError endpoint status
100−--
101−-- httpHandler response
102−-- -- return response
103
63
104parseResponse :: (FromJSON a, Monad m) => Either DockerError BSL.ByteString -> DockerT m (Either DockerError a)
64parseResponse :: (FromJSON a, Monad m) => Either DockerError BSL.ByteString -> DockerT m (Either DockerError a)
105parseResponse (Left err) =
65parseResponse (Left err) =
src/Docker/Client/Http.hs+17−25
@@ -1,13 +1,11 @@
1{-# LANGUAGE RankNTypes #-}
1{-# LANGUAGE RankNTypes #-}
2{-# LANGUAGE ScopedTypeVariables #-}
2{-# LANGUAGE ScopedTypeVariables #-}
3−{-# LANGUAGE TypeFamilies, UndecidableInstances #-}
4
3
5module Docker.Client.Http where
4module Docker.Client.Http where
6
5
7−import Control.Monad.Base (MonadBase(..), liftBaseDefault)
6+-- import Control.Monad.Base (MonadBase(..), liftBaseDefault)
8−import Control.Monad.Catch (MonadMask(..), MonadCatch(..), MonadThrow(..))
7+import Control.Monad.Catch (MonadMask(..))
9import Control.Monad.Reader (ReaderT(..), runReaderT)
8import Control.Monad.Reader (ReaderT(..), runReaderT)
10−import Control.Monad.Trans.Control (MonadBaseControl(..), ComposeSt, defaultLiftBaseWith, defaultRestoreM, MonadTransControl(..), defaultLiftWith, defaultRestoreT)
11import qualified Data.ByteString.Char8 as BSC
9import qualified Data.ByteString.Char8 as BSC
12import qualified Data.ByteString.Lazy as BL
10import qualified Data.ByteString.Lazy as BL
13import Data.Conduit (Sink)
11import Data.Conduit (Sink)
@@ -17,7 +15,7 @@ import Data.Text.Encoding (encodeUtf8)
17import Data.X509 (CertificateChain (..))
15import Data.X509 (CertificateChain (..))
18import Data.X509.CertificateStore (makeCertificateStore)
16import Data.X509.CertificateStore (makeCertificateStore)
19import Data.X509.File (readKeyFile, readSignedObject)
17import Data.X509.File (readKeyFile, readSignedObject)
20−import Network.HTTP.Client (defaultManagerSettings, httpLbs,
18+import Network.HTTP.Client (defaultManagerSettings,
21 managerRawConnection, method,
19 managerRawConnection, method,
22 newManager, parseUrl,
20 newManager, parseUrl,
23 requestBody, requestHeaders)
21 requestBody, requestHeaders)
@@ -33,7 +31,7 @@ import Network.TLS (ClientHooks (..),
33import Network.TLS.Extra (ciphersuite_strong)
31import Network.TLS.Extra (ciphersuite_strong)
34import System.X509 (getSystemCertificateStore)
32import System.X509 (getSystemCertificateStore)
35
33
36−import Control.Exception (try)
34+import Control.Monad.Catch (try)
37import Control.Monad.Except
35import Control.Monad.Except
38import Control.Monad.Reader.Class
36import Control.Monad.Reader.Class
39import Data.Text as T
37import Data.Text as T
@@ -83,8 +81,8 @@ instance MonadTrans DockerT where
83instance MonadIO m => MonadIO (DockerT m) where
81instance MonadIO m => MonadIO (DockerT m) where
84 liftIO = lift . liftIO
82 liftIO = lift . liftIO
85
83
86−instance MonadBase IO m => MonadBase IO (DockerT m) where
84+-- instance MonadBase IO m => MonadBase IO (DockerT m) where
87− liftBase = liftBaseDefault
85+-- liftBase = liftBaseDefault
88
86
89runDockerT :: Monad m => (DockerClientOpts, HttpHandler m) -> DockerT m a -> m a
87runDockerT :: Monad m => (DockerClientOpts, HttpHandler m) -> DockerT m a -> m a
90runDockerT (opts, h) r = runReaderT (unDockerT r) (opts, h)
88runDockerT (opts, h) r = runReaderT (unDockerT r) (opts, h)
@@ -106,38 +104,32 @@ mkHttpRequest verb e opts = request
106 requestHeaders = [("Content-Type", "application/json; charset=utf-8")]}) $ getEndpointRequestBody e) <$> request'
104 requestHeaders = [("Content-Type", "application/json; charset=utf-8")]}) $ getEndpointRequestBody e) <$> request'
107 -- Note: Do we need to set length header?
105 -- Note: Do we need to set length header?
108
106
109−defaultHttpHandler :: MonadIO m => HttpHandler m
107+defaultHttpHandler :: (MonadIO m, MonadMask m) => m (HttpHandler m)
110−defaultHttpHandler = HttpHandler $ \request sink -> do
108+defaultHttpHandler = do
111 manager <- liftIO $ newManager defaultManagerSettings
109 manager <- liftIO $ newManager defaultManagerSettings
112− httpHandler manager request sink
110+ return $ httpHandler manager
113
111
114−httpHandler = undefined
115−
116−{-
117−httpHandler :: MonadIO m => HTTP.Manager -> HttpHandler m
112+httpHandler :: (MonadIO m, MonadMask m) => HTTP.Manager -> HttpHandler m
118−httpHandler manager request' sink = liftIO $ do -- runResourceT ..
113+httpHandler manager = HttpHandler $ \request' sink -> do -- runResourceT ..
114+ let request = NHS.setRequestManager manager request'
119 try (NHS.httpSink request sink) >>= \res -> case res of
115 try (NHS.httpSink request sink) >>= \res -> case res of
120− Right res -> return $ Right res
116+ Right res -> return res
121 Left HTTP.FailedConnectionException{} -> return $ Left DockerConnectionError
117 Left HTTP.FailedConnectionException{} -> return $ Left DockerConnectionError
122 Left HTTP.FailedConnectionException2{} -> return $ Left DockerConnectionError
118 Left HTTP.FailedConnectionException2{} -> return $ Left DockerConnectionError
123 Left e -> return $ Left $ GenericDockerError (T.pack $ show e)
119 Left e -> return $ Left $ GenericDockerError (T.pack $ show e)
124
120
125− where
126− request = NHS.setRequestManager request'
127−-}
128−
129-- | Connect to a unix domain socket (the default docker socket is
121-- | Connect to a unix domain socket (the default docker socket is
130-- at \/var\/run\/docker.sock)
122-- at \/var\/run\/docker.sock)
131--
123--
132-- Docker seems to ignore the hostname in requests sent over unix domain
124-- Docker seems to ignore the hostname in requests sent over unix domain
133-- sockets (and the port obviously doesn't matter either)
125-- sockets (and the port obviously doesn't matter either)
134−unixHttpHandler :: MonadIO m => FilePath -- ^ The socket to connect to
126+unixHttpHandler :: (MonadIO m, MonadMask m) => FilePath -- ^ The socket to connect to
135− -> HttpHandler m
127+ -> m (HttpHandler m)
136−unixHttpHandler fp = HttpHandler $ \request sink -> do
128+unixHttpHandler fp = do
137 let mSettings = defaultManagerSettings
129 let mSettings = defaultManagerSettings
138 { managerRawConnection = return $ openUnixSocket fp}
130 { managerRawConnection = return $ openUnixSocket fp}
139 manager <- liftIO $ newManager mSettings
131 manager <- liftIO $ newManager mSettings
140− httpHandler manager request sink
132+ return $ httpHandler manager
141
133
142 where
134 where
143 openUnixSocket filePath _ _ _ = do
135 openUnixSocket filePath _ _ _ = do