git.iko.soy/docker-hs
on master help sign in
Generalizes types and removes ExcepT

From what I read here: https://www.schoolofhaskell.com/user/commercial/content/exceptions-best-practices wrapping IO in ExceptT is considered an antipattern. Instead we're using MonadThro. Also we generalize our functions to accept any Monad that has an instance of MonadThrow. This allows us to supply a httpHandler that runs in another Monad and not just IO.

commitb2a25e984bfd93c23b9e78e05190a1d67a6b8ed7 authorDeni Bertovic <deni@denibertovic.com> dateThu 17 Mar 2016, 13:31 (11 years ago) parent0782437
2 files changed+29−26
compare with master
unifiedsplit
src/Docker.hs+25−22 src/Docker/Types.hs+4−4
src/Docker.hs+25−22
@@ -1,6 +1,9 @@
1+{-# LANGUAGE ExplicitForAll #-}
2+
13module Docker where
24
35import Control.Applicative ((<$>), (<*>))
6+import Control.Monad.Catch
47import Control.Monad.Except (catchError, throwError)
58import Control.Monad.IO.Class (MonadIO, liftIO)
69import Control.Monad.Reader (ask)
@@ -13,85 +16,85 @@ import Network.HTTP.Types (StdMethod (..))
1316import Docker.Internal
1417import Docker.Types
1518
16−getDockerVersion :: DockerT IO DockerVersion
19+getDockerVersion :: forall m a. MonadThrow m => DockerT m DockerVersion
1720getDockerVersion = do
1821 (opts, httpHandler) <- ask
1922 let request = fromJust $ mkHttpRequest GET VersionEndpoint opts
20− response <- liftIO $ httpHandler request
23+ response <- lift $ ((httpHandler request) :: m Response)
2124 let body = responseBody response
2225 let res = decode body
2326 return $ fromJust res
2427
25−listContainers :: ListOpts -> DockerT IO [Container]
28+listContainers :: forall m a. MonadThrow m => ListOpts -> DockerT m [Container]
2629listContainers lopts = do
2730 (opts, httpHandler) <- ask
2831 let request = fromJust $ mkHttpRequest GET (ListContainersEndpoint lopts) opts
29− response <- liftIO $ httpHandler request
32+ response <- lift $ httpHandler request
3033 let body = responseBody response
3134 let res = decode body
3235 return $ fromJust res
3336
34−listImages :: ListOpts -> DockerT IO [Image]
37+listImages :: forall m a. MonadThrow m => ListOpts -> DockerT m [Image]
3538listImages lopts = do
3639 (opts, httpHandler) <- ask
3740 let request = fromJust $ mkHttpRequest GET (ListImagesEndpoint lopts) opts
38− response <- liftIO $ httpHandler request
41+ response <- lift $ ((httpHandler request) :: m Response)
3942 let body = responseBody response
4043 let res = decode body
4144 return $ fromJust res
4245
43−createContainer :: CreateOpts -> DockerT IO ContainerID
46+createContainer :: forall m a. MonadThrow m => CreateOpts -> DockerT m ContainerID
4447createContainer = undefined
4548
46−startContainer :: StartOpts -> ContainerID -> DockerT IO ContainerID
49+startContainer :: forall m a. MonadThrow m => StartOpts -> ContainerID -> DockerT m ContainerID
4750startContainer sopts cid = do
4851 (opts, httpHandler) <- ask
4952 let request = fromJust $ mkHttpRequest POST (StartContainerEndpoint sopts cid) opts
50− _ <- liftIO $ httpHandler request
53+ _ <- lift $ ((httpHandler request) :: m Response)
5154 return cid
5255
53−stopContainer :: Timeout -> ContainerID ->DockerT IO ContainerID
56+stopContainer :: forall m a. MonadThrow m => Timeout -> ContainerID ->DockerT m ContainerID
5457stopContainer t cid = do
5558 (opts, httpHandler) <- ask
5659 let request = fromJust $ mkHttpRequest POST (StopContainerEndpoint t cid) opts
57− _ <- liftIO $ httpHandler request
60+ _ <- lift $ ((httpHandler request) :: m Response)
5861 return cid
5962
60−killContainer :: Signal -> ContainerID -> DockerT IO ContainerID
63+killContainer :: forall m a. MonadThrow m => Signal -> ContainerID -> DockerT m ContainerID
6164killContainer s cid = do
6265 (opts, httpHandler) <- ask
6366 let request = fromJust $ mkHttpRequest POST (KillContainerEndpoint s cid) opts
64− _ <- liftIO $ httpHandler request
67+ _ <- lift $ ((httpHandler request) :: m Response)
6568 return cid
6669
67−restartContainer :: Timeout -> ContainerID -> DockerT IO ContainerID
70+restartContainer :: forall m a. MonadThrow m => Timeout -> ContainerID -> DockerT m ContainerID
6871restartContainer t cid = do
6972 (opts, httpHandler) <- ask
7073 let request = fromJust $ mkHttpRequest POST (RestartContainerEndpoint t cid) opts
71− _ <- liftIO $ httpHandler request
74+ _ <- lift $ ((httpHandler request) :: m Response)
7275 return cid
7376
74−pauseContainer :: ContainerID -> DockerT IO ContainerID
77+pauseContainer :: forall m a. MonadThrow m => ContainerID -> DockerT m ContainerID
7578pauseContainer cid = do
7679 (opts, httpHandler) <- ask
7780 let request = fromJust $ mkHttpRequest POST (PauseContainerEndpoint cid) opts
78− _ <- liftIO $ httpHandler request
81+ _ <- lift $ ((httpHandler request) :: m Response)
7982 return cid
8083
81−unpauseContainer :: ContainerID -> DockerT IO ContainerID
84+unpauseContainer :: forall m a. MonadThrow m => ContainerID -> DockerT m ContainerID
8285unpauseContainer cid = do
8386 (opts, httpHandler) <- ask
8487 let request = fromJust $ mkHttpRequest GET (UnpauseContainerEndpoint cid) opts
85− _ <- liftIO $ httpHandler request
88+ _ <- lift $ ((httpHandler request) :: m Response)
8689 return cid
8790
88−deleteContainer :: DeleteOpts -> ContainerID -> DockerT IO ContainerID
91+deleteContainer :: forall m a. MonadThrow m => DeleteOpts -> ContainerID -> DockerT m ContainerID
8992deleteContainer dopts cid = do
9093 (opts, httpHandler) <- ask
9194 let request = fromJust $ mkHttpRequest DELETE (DeleteContainerEndpoint dopts cid) opts
92− _ <- liftIO $ httpHandler request
95+ _ <- lift $ ((httpHandler request) :: m Response)
9396 return cid
9497
95−getContainerLogs :: LogOpts -> ContainerID -> DockerT IO ()
98+getContainerLogs :: forall m a. MonadThrow m => LogOpts -> ContainerID -> DockerT m ()
9699getContainerLogs = undefined
97100
src/Docker/Types.hs+4−4
@@ -1,6 +1,7 @@
11module Docker.Types where
22
33import Control.Monad (mzero)
4+import Control.Monad.Catch
45import Control.Monad.Except (ExceptT, runExceptT)
56import Control.Monad.Reader (ReaderT, runReaderT)
67import Data.Aeson (FromJSON, ToJSON, decode, encode,
@@ -61,11 +62,10 @@ data DockerClientOpts = DockerClientOpts {
6162
6263type HttpHandler m = Request -> m Response
6364
64−type DockerT m a = ReaderT (DockerClientOpts, HttpHandler m) (ExceptT String m) a
65+type DockerT m a = ReaderT (DockerClientOpts, HttpHandler m) m a
6566
66−runDockerT :: (Monad m) => (DockerClientOpts, HttpHandler m) -> DockerT m a -> m (Either String a)
67−runDockerT (opts, h) r = runExceptT $ runReaderT r (opts, h)
68−-- runDockerT opts a = (runExceptT .) . flip runReaderT opts a
67+runDockerT :: (MonadThrow m) => (DockerClientOpts, HttpHandler m) -> DockerT m a -> m a
68+runDockerT (opts, h) r = runReaderT r (opts, h)
6969
7070data ListOpts = ListOpts { all :: Bool } deriving (Eq, Show)
7171