@@ -21,106 +21,154 @@ module Docker.Client.Api (
2121 , getDockerVersion
2222 ) where
2323
24−import Control.Monad.Except (ExceptT (..), runExceptT, throwError)
24+import Control.Monad.Catch (MonadMask(..))
2525import Control.Monad.IO.Class
2626import Control.Monad.Reader (ask, lift)
27+import Control.Monad.Trans.Resource
2728import Data.Aeson (FromJSON, eitherDecode')
29+import qualified Data.ByteString as BS
2830import qualified Data.ByteString.Lazy as BSL
31+import Data.Conduit (($$), Sink)
32+import qualified Data.Conduit.Binary as Conduit
2933import qualified Data.Text as Text
3034import Network.HTTP.Client (responseBody, responseStatus)
35+import qualified Network.HTTP.Simple as NHS
3136import Network.HTTP.Types (StdMethod (..))
3237
3338import Docker.Client.Http
3439import Docker.Client.Types
3540import Docker.Client.Utils
3641
37−requestUnit :: (Monad m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError ())
42+requestUnit :: (MonadIO m, MonadMask m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError ())
3843requestUnit verb endpoint = const (Right ()) <$> requestHelper verb endpoint
3944
40−requestHelper :: (Monad m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError Response)
41−requestHelper verb endpoint = runExceptT $ do
42− (opts, httpHandler) <- lift ask
45+requestHelper :: (MonadIO m, MonadMask m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError BSL.ByteString)
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
50+ (opts, HttpHandler httpHandler) <- ask
4351 case mkHttpRequest verb endpoint opts of
4452 Nothing ->
45− throwError $ DockerInvalidRequest endpoint
53+ return $ Left $ DockerInvalidRequest endpoint
4654 Just request -> do
47− response <- ExceptT $ lift $ httpHandler request
48−
49− -- Check status code.
50− let status = responseStatus response
51− maybe (return ()) throwError $
52− statusCodeToError endpoint status
53−
54− return response
55−
56−parseResponse :: (FromJSON a, Monad m) => Either DockerError Response -> DockerT m (Either DockerError a)
55+ -- response <- ExceptT $ lift $ httpHandler request $ const Conduit.sinkLbs
56+ -- TODO: Catch things XXX
57+
58+ -- TODO: Do we need runResourceT? XX
59+ -- lift $ NHS.httpSink request $ \response ->
60+ lift $ httpHandler request $ \response ->
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.
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+
104+parseResponse :: (FromJSON a, Monad m) => Either DockerError BSL.ByteString -> DockerT m (Either DockerError a)
57105parseResponse (Left err) =
58106 return $ Left err
59107parseResponse (Right response) =
60108 -- Parse request body.
61− case eitherDecode' $ responseBody response of
109+ case eitherDecode' response of
62110 Left err ->
63111 return $ Left $ DockerClientDecodeError $ Text.pack err
64112 Right r ->
65113 return $ Right r
66114
67115-- | 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)
69117getDockerVersion = requestHelper GET VersionEndpoint >>= parseResponse
70118
71119-- | Lists all running docker containers. Pass in @'defaultListOpts' {all
72120-- = 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])
74122listContainers opts = requestHelper GET (ListContainersEndpoint opts) >>= parseResponse
75123
76124-- | 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])
78126listImages opts = requestHelper GET (ListImagesEndpoint opts) >>= parseResponse
79127
80128-- | Creates a docker container but does __not__ start it. See
81129-- 'CreateOpts' for a list of options and you can use 'defaultCreateOpts'
82130-- 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)
84132createContainer opts cn = requestHelper POST (CreateContainerEndpoint opts cn) >>= parseResponse
85133
86134-- | Start a container from a given 'ContainerID' that we get from
87135-- 'createContainer'. See 'StartOpts' for a list of configuration options
88136-- 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 ())
90138startContainer sopts cid = requestUnit POST $ StartContainerEndpoint sopts cid
91139
92140-- | Attempts to stop a container with the given 'ContainerID' gracefully
93141-- (SIGTERM).
94142-- The docker daemon will wait for the given 'Timeout' and then send
95143-- 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 ())
97145stopContainer t cid = requestUnit POST $ StopContainerEndpoint t cid
98146
99147-- | Sends a 'Signal' to the container with the given 'ContainerID'. Same
100148-- 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 ())
102150killContainer s cid = requestUnit POST $ KillContainerEndpoint s cid
103151
104152-- | 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 ())
106154restartContainer t cid = requestUnit POST $ RestartContainerEndpoint t cid
107155
108156-- | 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 ())
110158pauseContainer cid = requestUnit POST $ PauseContainerEndpoint cid
111159
112160-- | 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 ())
114162unpauseContainer cid = requestUnit GET $ UnpauseContainerEndpoint cid
115163
116164-- | Deletes a container with the given 'ContainerID'.
117165-- See "DeleteOpts" for options and use 'defaultDeleteOpts' for sane
118166-- 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 ())
120168deleteContainer dopts cid = requestUnit DELETE $ DeleteContainerEndpoint dopts cid
121169
122170-- | 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)
124172inspectContainer cid = requestHelper GET (InspectContainerEndpoint cid) >>= parseResponse
125173
126174-- | Get's container's logs for a given 'ContainerID'.
@@ -138,8 +186,8 @@ inspectContainer cid = requestHelper GET (InspectContainerEndpoint cid) >>= pars
138186--
139187-- The recommended method is to use one of the other 'LogDriverType's available (like
140188-- syslog) for creating your containers.
141−getContainerLogs :: forall m. Monad m => LogOpts -> ContainerID -> DockerT m (Either DockerError BSL.ByteString)
142−getContainerLogs logopts cid = fmap responseBody <$> requestHelper GET (ContainerLogsEndpoint logopts False cid)
189+getContainerLogs :: forall m. (MonadIO m, MonadMask m) => LogOpts -> ContainerID -> DockerT m (Either DockerError BSL.ByteString)
190+getContainerLogs logopts cid = requestHelper GET (ContainerLogsEndpoint logopts False cid)
143191
144192-- TODO: Use http-conduit to output to a sink.
145193-- 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
150198-- TODO: Add X-Registry-Config
151199-- TODO: Add support for remote URLs to a Dockerfile
152200-- 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 ())
154202buildImageFromDockerfile opts base = do
155203 ctx <- makeBuildContext $ BuildContextRootDir base
156204 case ctx of