git.iko.soy/docker-hs
on master help sign in
work on switching API to conduit. Still more to do and lots to clean up
665b834James Parker
docker.cabal+4
compare with master
unifiedsplit
@@ -30,8 +30,12 @@ library
30 , conduit
30 , conduit
31 , conduit-combinators
31 , conduit-combinators
32 , conduit-extra
32 , conduit-extra
33+ , exceptions
33 , http-conduit
34 , http-conduit
35+ , monad-control
36+ , resourcet
34 , transformers
37 , transformers
38+ , transformers-base
35 , tar
39 , tar
36 , zlib
40 , zlib
37 , uuid
41 , uuid
src/Docker/Client/Api.hs+80−32
@@ -21,106 +21,154 @@ module Docker.Client.Api (
21 , getDockerVersion
21 , getDockerVersion
22 ) where
22 ) where
23
23
24−import Control.Monad.Except (ExceptT (..), runExceptT, throwError)
24+import 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
27import Data.Aeson (FromJSON, eitherDecode')
28import Data.Aeson (FromJSON, eitherDecode')
29+import qualified Data.ByteString as BS
28import qualified Data.ByteString.Lazy as BSL
30import qualified Data.ByteString.Lazy as BSL
31+import Data.Conduit (($$), Sink)
32+import qualified Data.Conduit.Binary as Conduit
29import qualified Data.Text as Text
33import qualified Data.Text as Text
30import Network.HTTP.Client (responseBody, responseStatus)
34import Network.HTTP.Client (responseBody, responseStatus)
35+import qualified Network.HTTP.Simple as NHS
31import Network.HTTP.Types (StdMethod (..))
36import Network.HTTP.Types (StdMethod (..))
32
37
33import Docker.Client.Http
38import Docker.Client.Http
34import Docker.Client.Types
39import Docker.Client.Types
35import Docker.Client.Utils
40import Docker.Client.Utils
36
41
37−requestUnit :: (Monad m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError ())
42+requestUnit :: (MonadIO m, MonadMask m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError ())
38requestUnit verb endpoint = const (Right ()) <$> requestHelper verb endpoint
43requestUnit verb endpoint = const (Right ()) <$> requestHelper verb endpoint
39
44
40−requestHelper :: (Monad m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError Response)
45+requestHelper :: (MonadIO m, MonadMask m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError BSL.ByteString)
41−requestHelper verb endpoint = runExceptT $ do
46+requestHelper verb endpoint = requestHelper' verb endpoint Conduit.sinkLbs
47+
48+requestHelper' :: (MonadIO m, MonadMask m) => HttpVerb -> Endpoint -> Sink BS.ByteString m a -> DockerT m (Either DockerError a)
49+requestHelper' verb endpoint sink = do
42− (opts, httpHandler) <- lift ask
50+ (opts, HttpHandler httpHandler) <- ask
43 case mkHttpRequest verb endpoint opts of
51 case mkHttpRequest verb endpoint opts of
44 Nothing ->
52 Nothing ->
45− throwError $ DockerInvalidRequest endpoint
53+ return $ Left $ DockerInvalidRequest endpoint
46 Just request -> do
54 Just request -> do
47− response <- ExceptT $ lift $ httpHandler request
55+ -- response <- ExceptT $ lift $ httpHandler request $ const Conduit.sinkLbs
48−
56+ -- TODO: Catch things XXX
57+
58+ -- TODO: Do we need runResourceT? XX
59+ -- lift $ NHS.httpSink request $ \response ->
60+ lift $ httpHandler request $ \response ->
49− -- Check status code.
61+ -- Check status code.
62+ let status = responseStatus response in
63+ case statusCodeToError endpoint status of
64+ Just err ->
65+ return $ Left err
66+ Nothing ->
67+ fmap Right sink -- $ Conduit.sinkLbs response
68+ -- return
69+
70+ -- lift $ runResourceT $ do
71+ -- NHS.httpSource request $$ \response -> do
72+
73+ -- -- Check status code.
50− let status = responseStatus response
74+ -- let status = responseStatus response
75+
76+ -- -- TODO
51− maybe (return ()) throwError $
77+ -- maybe (return ()) throwError $
52− statusCodeToError endpoint status
78+ -- statusCodeToError endpoint status
53−
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
54− return response
102+-- -- return response
55−
103+
56−parseResponse :: (FromJSON a, Monad m) => Either DockerError Response -> DockerT m (Either DockerError a)
104+parseResponse :: (FromJSON a, Monad m) => Either DockerError BSL.ByteString -> DockerT m (Either DockerError a)
57parseResponse (Left err) =
105parseResponse (Left err) =
58 return $ Left err
106 return $ Left err
59parseResponse (Right response) =
107parseResponse (Right response) =
60 -- Parse request body.
108 -- Parse request body.
61− case eitherDecode' $ responseBody response of
109+ case eitherDecode' response of
62 Left err ->
110 Left err ->
63 return $ Left $ DockerClientDecodeError $ Text.pack err
111 return $ Left $ DockerClientDecodeError $ Text.pack err
64 Right r ->
112 Right r ->
65 return $ Right r
113 return $ Right r
66
114
67-- | Gets the version of the docker engine remote API.
115-- | Gets the version of the docker engine remote API.
68−getDockerVersion :: forall m. Monad m => DockerT m (Either DockerError DockerVersion)
116+getDockerVersion :: forall m. (MonadIO m, MonadMask m) => DockerT m (Either DockerError DockerVersion)
69getDockerVersion = requestHelper GET VersionEndpoint >>= parseResponse
117getDockerVersion = requestHelper GET VersionEndpoint >>= parseResponse
70
118
71-- | Lists all running docker containers. Pass in @'defaultListOpts' {all
119-- | Lists all running docker containers. Pass in @'defaultListOpts' {all
72-- = True}@ to get a list of stopped containers as well.
120-- = True}@ to get a list of stopped containers as well.
73−listContainers :: forall m. Monad m => ListOpts -> DockerT m (Either DockerError [Container])
121+listContainers :: forall m. (MonadIO m, MonadMask m) => ListOpts -> DockerT m (Either DockerError [Container])
74listContainers opts = requestHelper GET (ListContainersEndpoint opts) >>= parseResponse
122listContainers opts = requestHelper GET (ListContainersEndpoint opts) >>= parseResponse
75
123
76-- | Lists all docker images.
124-- | Lists all docker images.
77−listImages :: forall m. Monad m => ListOpts -> DockerT m (Either DockerError [Image])
125+listImages :: forall m. (MonadIO m, MonadMask m) => ListOpts -> DockerT m (Either DockerError [Image])
78listImages opts = requestHelper GET (ListImagesEndpoint opts) >>= parseResponse
126listImages opts = requestHelper GET (ListImagesEndpoint opts) >>= parseResponse
79
127
80-- | Creates a docker container but does __not__ start it. See
128-- | Creates a docker container but does __not__ start it. See
81-- 'CreateOpts' for a list of options and you can use 'defaultCreateOpts'
129-- 'CreateOpts' for a list of options and you can use 'defaultCreateOpts'
82-- for some sane defaults.
130-- for some sane defaults.
83−createContainer :: forall m. Monad m => CreateOpts -> Maybe ContainerName -> DockerT m (Either DockerError ContainerID)
131+createContainer :: forall m. (MonadIO m, MonadMask m) => CreateOpts -> Maybe ContainerName -> DockerT m (Either DockerError ContainerID)
84createContainer opts cn = requestHelper POST (CreateContainerEndpoint opts cn) >>= parseResponse
132createContainer opts cn = requestHelper POST (CreateContainerEndpoint opts cn) >>= parseResponse
85
133
86-- | Start a container from a given 'ContainerID' that we get from
134-- | Start a container from a given 'ContainerID' that we get from
87-- 'createContainer'. See 'StartOpts' for a list of configuration options
135-- 'createContainer'. See 'StartOpts' for a list of configuration options
88-- for starting a container. Use 'defaultStartOpts' for sane defaults.
136-- for starting a container. Use 'defaultStartOpts' for sane defaults.
89−startContainer :: forall m. Monad m => StartOpts -> ContainerID -> DockerT m (Either DockerError ())
137+startContainer :: forall m. (MonadIO m, MonadMask m) => StartOpts -> ContainerID -> DockerT m (Either DockerError ())
90startContainer sopts cid = requestUnit POST $ StartContainerEndpoint sopts cid
138startContainer sopts cid = requestUnit POST $ StartContainerEndpoint sopts cid
91
139
92-- | Attempts to stop a container with the given 'ContainerID' gracefully
140-- | Attempts to stop a container with the given 'ContainerID' gracefully
93-- (SIGTERM).
141-- (SIGTERM).
94-- The docker daemon will wait for the given 'Timeout' and then send
142-- The docker daemon will wait for the given 'Timeout' and then send
95-- a SIGKILL killing the container.
143-- a SIGKILL killing the container.
96−stopContainer :: forall m. Monad m => Timeout -> ContainerID -> DockerT m (Either DockerError ())
144+stopContainer :: forall m. (MonadIO m, MonadMask m) => Timeout -> ContainerID -> DockerT m (Either DockerError ())
97stopContainer t cid = requestUnit POST $ StopContainerEndpoint t cid
145stopContainer t cid = requestUnit POST $ StopContainerEndpoint t cid
98
146
99-- | Sends a 'Signal' to the container with the given 'ContainerID'. Same
147-- | Sends a 'Signal' to the container with the given 'ContainerID'. Same
100-- as 'stopContainer' but you choose the signal directly.
148-- as 'stopContainer' but you choose the signal directly.
101−killContainer :: forall m. Monad m => Signal -> ContainerID -> DockerT m (Either DockerError ())
149+killContainer :: forall m. (MonadIO m, MonadMask m) => Signal -> ContainerID -> DockerT m (Either DockerError ())
102killContainer s cid = requestUnit POST $ KillContainerEndpoint s cid
150killContainer s cid = requestUnit POST $ KillContainerEndpoint s cid
103
151
104-- | Restarts a container with the given 'ContainerID'.
152-- | Restarts a container with the given 'ContainerID'.
105−restartContainer :: forall m. Monad m => Timeout -> ContainerID -> DockerT m (Either DockerError ())
153+restartContainer :: forall m. (MonadIO m, MonadMask m) => Timeout -> ContainerID -> DockerT m (Either DockerError ())
106restartContainer t cid = requestUnit POST $ RestartContainerEndpoint t cid
154restartContainer t cid = requestUnit POST $ RestartContainerEndpoint t cid
107
155
108-- | Pauses a container with the given 'ContainerID'.
156-- | Pauses a container with the given 'ContainerID'.
109−pauseContainer :: forall m. Monad m => ContainerID -> DockerT m (Either DockerError ())
157+pauseContainer :: forall m. (MonadIO m, MonadMask m) => ContainerID -> DockerT m (Either DockerError ())
110pauseContainer cid = requestUnit POST $ PauseContainerEndpoint cid
158pauseContainer cid = requestUnit POST $ PauseContainerEndpoint cid
111
159
112-- | Unpauses a container with the given 'ContainerID'.
160-- | Unpauses a container with the given 'ContainerID'.
113−unpauseContainer :: forall m. Monad m => ContainerID -> DockerT m (Either DockerError ())
161+unpauseContainer :: forall m. (MonadIO m, MonadMask m) => ContainerID -> DockerT m (Either DockerError ())
114unpauseContainer cid = requestUnit GET $ UnpauseContainerEndpoint cid
162unpauseContainer cid = requestUnit GET $ UnpauseContainerEndpoint cid
115
163
116-- | Deletes a container with the given 'ContainerID'.
164-- | Deletes a container with the given 'ContainerID'.
117-- See "DeleteOpts" for options and use 'defaultDeleteOpts' for sane
165-- See "DeleteOpts" for options and use 'defaultDeleteOpts' for sane
118-- defaults.
166-- defaults.
119−deleteContainer :: forall m. Monad m => DeleteOpts -> ContainerID -> DockerT m (Either DockerError ())
167+deleteContainer :: forall m. (MonadIO m, MonadMask m) => DeleteOpts -> ContainerID -> DockerT m (Either DockerError ())
120deleteContainer dopts cid = requestUnit DELETE $ DeleteContainerEndpoint dopts cid
168deleteContainer dopts cid = requestUnit DELETE $ DeleteContainerEndpoint dopts cid
121
169
122-- | Gets 'ContainerDetails' for a given 'ContainerID'.
170-- | Gets 'ContainerDetails' for a given 'ContainerID'.
123−inspectContainer :: forall m . Monad m => ContainerID -> DockerT m (Either DockerError ContainerDetails)
171+inspectContainer :: forall m . (MonadIO m, MonadMask m) => ContainerID -> DockerT m (Either DockerError ContainerDetails)
124inspectContainer cid = requestHelper GET (InspectContainerEndpoint cid) >>= parseResponse
172inspectContainer cid = requestHelper GET (InspectContainerEndpoint cid) >>= parseResponse
125
173
126-- | Get's container's logs for a given 'ContainerID'.
174-- | Get's container's logs for a given 'ContainerID'.
@@ -138,8 +186,8 @@ inspectContainer cid = requestHelper GET (InspectContainerEndpoint cid) >>= pars
138--
186--
139-- The recommended method is to use one of the other 'LogDriverType's available (like
187-- The recommended method is to use one of the other 'LogDriverType's available (like
140-- syslog) for creating your containers.
188-- syslog) for creating your containers.
141−getContainerLogs :: forall m. Monad m => LogOpts -> ContainerID -> DockerT m (Either DockerError BSL.ByteString)
189+getContainerLogs :: forall m. (MonadIO m, MonadMask m) => LogOpts -> ContainerID -> DockerT m (Either DockerError BSL.ByteString)
142−getContainerLogs logopts cid = fmap responseBody <$> requestHelper GET (ContainerLogsEndpoint logopts False cid)
190+getContainerLogs logopts cid = requestHelper GET (ContainerLogsEndpoint logopts False cid)
143
191
144-- TODO: Use http-conduit to output to a sink.
192-- TODO: Use http-conduit to output to a sink.
145-- getContainerLogsStream :: forall m. Monad m => Sink BSL.ByteString m b -> LogOpts -> ContainerID -> DockerT m (Either DockerError b)
193-- getContainerLogsStream :: forall m. Monad m => Sink BSL.ByteString m b -> LogOpts -> ContainerID -> DockerT m (Either DockerError b)
@@ -150,7 +198,7 @@ getContainerLogs logopts cid = fmap responseBody <$> requestHelper GET (Containe
150-- TODO: Add X-Registry-Config
198-- TODO: Add X-Registry-Config
151-- TODO: Add support for remote URLs to a Dockerfile
199-- TODO: Add support for remote URLs to a Dockerfile
152-- TODO: Clean up temp tar.gz file after the image is built
200-- TODO: Clean up temp tar.gz file after the image is built
153−buildImageFromDockerfile :: forall m. MonadIO m => BuildOpts -> FilePath -> DockerT m (Either DockerError ())
201+buildImageFromDockerfile :: forall m. (MonadIO m, MonadMask m) => BuildOpts -> FilePath -> DockerT m (Either DockerError ())
154buildImageFromDockerfile opts base = do
202buildImageFromDockerfile opts base = do
155 ctx <- makeBuildContext $ BuildContextRootDir base
203 ctx <- makeBuildContext $ BuildContextRootDir base
156 case ctx of
204 case ctx of
src/Docker/Client/Http.hs+24−8
@@ -1,11 +1,16 @@
1{-# LANGUAGE RankNTypes #-}
1{-# LANGUAGE RankNTypes #-}
2{-# LANGUAGE ScopedTypeVariables #-}
2{-# LANGUAGE ScopedTypeVariables #-}
3+{-# LANGUAGE TypeFamilies, UndecidableInstances #-}
3
4
4module Docker.Client.Http where
5module Docker.Client.Http where
5
6
7+import Control.Monad.Base (MonadBase(..), liftBaseDefault)
8+import Control.Monad.Catch (MonadMask(..), MonadCatch(..), MonadThrow(..))
6−import Control.Monad.Reader (ReaderT, runReaderT)
9+import Control.Monad.Reader (ReaderT(..), runReaderT)
10+import Control.Monad.Trans.Control (MonadBaseControl(..), ComposeSt, defaultLiftBaseWith, defaultRestoreM, MonadTransControl(..), defaultLiftWith, defaultRestoreT)
7import qualified Data.ByteString.Char8 as BSC
11import qualified Data.ByteString.Char8 as BSC
8import qualified Data.ByteString.Lazy as BL
12import qualified Data.ByteString.Lazy as BL
13+import Data.Conduit (Sink)
9import Data.Default.Class (def)
14import Data.Default.Class (def)
10import Data.Monoid ((<>))
15import Data.Monoid ((<>))
11import Data.Text.Encoding (encodeUtf8)
16import Data.Text.Encoding (encodeUtf8)
@@ -20,6 +25,7 @@ import qualified Network.HTTP.Client as HTTP
20import Network.HTTP.Client.Internal (makeConnection)
25import Network.HTTP.Client.Internal (makeConnection)
21import Network.HTTP.Types (StdMethod, status101, status200,
26import Network.HTTP.Types (StdMethod, status101, status200,
22 status201, status204)
27 status201, status204)
28+import qualified Network.HTTP.Simple as NHS
23import Network.TLS (ClientHooks (..),
29import Network.TLS (ClientHooks (..),
24 ClientParams (..), Shared (..),
30 ClientParams (..), Shared (..),
25 Supported (..),
31 Supported (..),
@@ -46,7 +52,7 @@ import Docker.Client.Types (DockerClientOpts, Endpoint (..),
46type Request = HTTP.Request
52type Request = HTTP.Request
47type Response = HTTP.Response BL.ByteString
53type Response = HTTP.Response BL.ByteString
48type HttpVerb = StdMethod
54type HttpVerb = StdMethod
49−type HttpHandler m = Request -> m (Either DockerError Response)
55+newtype HttpHandler m = HttpHandler (forall a . Request -> (HTTP.Response () -> Sink BSC.ByteString m (Either DockerError a)) -> m (Either DockerError a))
50
56
51data DockerError = DockerConnectionError
57data DockerError = DockerConnectionError
52 | DockerInvalidRequest Endpoint
58 | DockerInvalidRequest Endpoint
@@ -77,6 +83,9 @@ instance MonadTrans DockerT where
77instance MonadIO m => MonadIO (DockerT m) where
83instance MonadIO m => MonadIO (DockerT m) where
78 liftIO = lift . liftIO
84 liftIO = lift . liftIO
79
85
86+instance MonadBase IO m => MonadBase IO (DockerT m) where
87+ liftBase = liftBaseDefault
88+
80runDockerT :: Monad m => (DockerClientOpts, HttpHandler m) -> DockerT m a -> m a
89runDockerT :: Monad m => (DockerClientOpts, HttpHandler m) -> DockerT m a -> m a
81runDockerT (opts, h) r = runReaderT (unDockerT r) (opts, h)
90runDockerT (opts, h) r = runReaderT (unDockerT r) (opts, h)
82
91
@@ -98,18 +107,25 @@ mkHttpRequest verb e opts = request
98 -- Note: Do we need to set length header?
107 -- Note: Do we need to set length header?
99
108
100defaultHttpHandler :: MonadIO m => HttpHandler m
109defaultHttpHandler :: MonadIO m => HttpHandler m
101−defaultHttpHandler request = do
110+defaultHttpHandler = HttpHandler $ \request sink -> do
102 manager <- liftIO $ newManager defaultManagerSettings
111 manager <- liftIO $ newManager defaultManagerSettings
103− httpHandler manager request
112+ httpHandler manager request sink
113+
114+httpHandler = undefined
104
115
116+{-
105httpHandler :: MonadIO m => HTTP.Manager -> HttpHandler m
117httpHandler :: MonadIO m => HTTP.Manager -> HttpHandler m
106−httpHandler manager request = liftIO $ do
118+httpHandler manager request' sink = liftIO $ do -- runResourceT ..
107− try (httpLbs request manager) >>= \res -> case res of
119+ try (NHS.httpSink request sink) >>= \res -> case res of
108 Right res -> return $ Right res
120 Right res -> return $ Right res
109 Left HTTP.FailedConnectionException{} -> return $ Left DockerConnectionError
121 Left HTTP.FailedConnectionException{} -> return $ Left DockerConnectionError
110 Left HTTP.FailedConnectionException2{} -> return $ Left DockerConnectionError
122 Left HTTP.FailedConnectionException2{} -> return $ Left DockerConnectionError
111 Left e -> return $ Left $ GenericDockerError (T.pack $ show e)
123 Left e -> return $ Left $ GenericDockerError (T.pack $ show e)
112
124
125+ where
126+ request = NHS.setRequestManager request'
127+-}
128+
113-- | Connect to a unix domain socket (the default docker socket is
129-- | Connect to a unix domain socket (the default docker socket is
114-- at \/var\/run\/docker.sock)
130-- at \/var\/run\/docker.sock)
115--
131--
@@ -117,11 +133,11 @@ httpHandler manager request = liftIO $ do
117-- sockets (and the port obviously doesn't matter either)
133-- sockets (and the port obviously doesn't matter either)
118unixHttpHandler :: MonadIO m => FilePath -- ^ The socket to connect to
134unixHttpHandler :: MonadIO m => FilePath -- ^ The socket to connect to
119 -> HttpHandler m
135 -> HttpHandler m
120−unixHttpHandler fp request = do
136+unixHttpHandler fp = HttpHandler $ \request sink -> do
121 let mSettings = defaultManagerSettings
137 let mSettings = defaultManagerSettings
122 { managerRawConnection = return $ openUnixSocket fp}
138 { managerRawConnection = return $ openUnixSocket fp}
123 manager <- liftIO $ newManager mSettings
139 manager <- liftIO $ newManager mSettings
124− httpHandler manager request
140+ httpHandler manager request sink
125
141
126 where
142 where
127 openUnixSocket filePath _ _ _ = do
143 openUnixSocket filePath _ _ _ = do