9891900 · docker-hs · git.iko.soy

git.iko.soy/docker-hs

on master help sign in

Puts everything in ReaderT

9891900Deni Bertovic11 years ago

Network/Docker.hs+79−61

compare with master

unifiedsplit

@@ -1,4 +1,5 @@

1{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE TypeFamilies #-}

4{-# LANGUAGE TypeFamilies #-}

@@ -7,6 +8,7 @@ module Network.Docker where

7import Control.Applicative ((<$>), (<*>))

8import Control.Applicative ((<$>), (<*>))

8import Control.Lens

9import Control.Lens

9import Control.Monad.Free

10import Control.Monad.Free

11+import Control.Monad.Reader (ask)

10import Data.Aeson (FromJSON, ToJSON, Value, decode,

12import Data.Aeson (FromJSON, ToJSON, Value, decode,

11 eitherDecode, toJSON)

13 eitherDecode, toJSON)

12import Data.Aeson.Lens (key, _String)

14import Data.Aeson.Lens (key, _String)

@@ -23,65 +25,81 @@ import Text.Printf (printf)

23import Network.Docker.Internal

25import Network.Docker.Internal

24import Network.Docker.Types

26import Network.Docker.Types

26−getDockerVersion :: DockerClientOpts -> IO (Maybe DockerVersion)

28+getDockerVersion :: DockerM IO (Maybe DockerVersion)

27−getDockerVersion clientOpts = decodeResponse <$>

29+getDockerVersion = do

30+ clientOpts <- ask

28− runDocker (getDockerVersionM clientOpts SVersionEndpoint)

31+ decodeResponse <$> runDocker (getDockerVersionM clientOpts SVersionEndpoint)

29−

32+

30−listContainers :: DockerClientOpts -> IO (Maybe [DockerContainer])

33+listContainers :: DockerM IO (Maybe [DockerContainer])

31−listContainers clientOpts = decodeResponse <$>

34+listContainers = do

35+ clientOpts <- ask

32− runDocker (listContainersM clientOpts SListContainersEndpoint)

36+ decodeResponse <$> runDocker (listContainersM clientOpts SListContainersEndpoint)

33−

37+

34−listImages :: DockerClientOpts -> IO (Maybe [DockerImage])

38+listImages :: DockerM IO (Maybe [DockerImage])

35−listImages clientOpts = decodeResponse <$>

39+listImages = do

40+ clientOpts <- ask

36− runDocker (listImagesM clientOpts SListImagesEndpoint)

41+ decodeResponse <$> runDocker (listImagesM clientOpts SListImagesEndpoint)

37−

42+

38−createContainer :: DockerClientOpts -> CreateContainerOpts -> IO(Maybe T.Text)

43+createContainer :: CreateContainerOpts -> DockerM IO (Maybe T.Text)

39−createContainer clientOpts createOpts = getElemFromResponse "Id" <$>

44+createContainer createOpts = do

45+ clientOpts <- ask

40− runDocker (createContainerM clientOpts (SCreateContainerEndpoint) createOpts)

46+ getElemFromResponse "Id" <$> runDocker (createContainerM clientOpts (SCreateContainerEndpoint) createOpts)

41−

47+

42−startContainer :: DockerClientOpts -> String -> StartContainerOpts -> IO(Status)

48+startContainer :: String -> StartContainerOpts -> DockerM IO (Status)

43−startContainer clientOpts cid startOpts = (^. responseStatus) <$>

49+startContainer cid startOpts = do

50+ clientOpts <- ask

44− runDocker (startContainerM clientOpts (SStartContainerEndpoint cid) startOpts)

51+ (^. responseStatus) <$> runDocker (startContainerM clientOpts (SStartContainerEndpoint cid) startOpts)

45−

52+

46−stopContainer :: DockerClientOpts -> String -> IO (Status)

53+stopContainer :: String -> DockerM IO (Status)

47−stopContainer clientOpts cid = (^. responseStatus) <$>

54+stopContainer cid = do

55+ clientOpts <- ask

48− runDocker (stopContainerM clientOpts (SStopContainerEndpoint cid))

56+ (^. responseStatus) <$> runDocker (stopContainerM clientOpts (SStopContainerEndpoint cid))

49−

57+

50−killContainer :: DockerClientOpts -> String -> IO (Status)

58+killContainer :: String -> DockerM IO (Status)

51−killContainer clientOpts cid = (^. responseStatus) <$>

59+killContainer cid = do

60+ clientOpts <- ask

52− runDocker (killContainerM clientOpts (SKillContainerEndpoint cid))

61+ (^. responseStatus) <$> runDocker (killContainerM clientOpts (SKillContainerEndpoint cid))

53−

62+

54−restartContainer :: DockerClientOpts -> String -> IO (Status)

63+restartContainer :: String -> DockerM IO (Status)

55−restartContainer clientOpts cid = (^. responseStatus) <$>

64+restartContainer cid = do

65+ clientOpts <- ask

56− runDocker (restartContainerM clientOpts (SRestartContainerEndpoint cid))

66+ (^. responseStatus) <$> runDocker (restartContainerM clientOpts (SRestartContainerEndpoint cid))

57−

67+

58−pauseContainer :: DockerClientOpts -> String -> IO (Status)

68+pauseContainer :: String -> DockerM IO (Status)

59−pauseContainer clientOpts cid = (^. responseStatus) <$>

69+pauseContainer cid = do

70+ clientOpts <- ask

60− runDocker (pauseContainerM clientOpts (SPauseContainerEndpoint cid))

71+ (^. responseStatus) <$> runDocker (pauseContainerM clientOpts (SPauseContainerEndpoint cid))

61−

72+

62−unpauseContainer :: DockerClientOpts -> String -> IO (Status)

73+unpauseContainer :: String -> DockerM IO (Status)

63−unpauseContainer clientOpts cid = (^. responseStatus) <$>

74+unpauseContainer cid = do

75+ clientOpts <- ask

64− runDocker (unpauseContainerM clientOpts (SUnpauseContainerEndpoint cid))

76+ (^. responseStatus) <$> runDocker (unpauseContainerM clientOpts (SUnpauseContainerEndpoint cid))

65−

77+

66−deleteContainer :: DockerClientOpts -> String -> IO (Status)

78+deleteContainer :: String -> DockerM IO (Status)

79+deleteContainer cid = do

80+ c <- ask

67−deleteContainer c cid = deleteContainerWithOpts c defaultDeleteOpts cid

81+ deleteContainerWithOpts defaultDeleteOpts cid

68−

82+

69−deleteContainerWithOpts :: DockerClientOpts -> DeleteOpts -> String -> IO (Status)

83+deleteContainerWithOpts :: DeleteOpts -> String -> DockerM IO (Status)

70−deleteContainerWithOpts clientOpts deleteOpts cid = (^. responseStatus) <$>

84+deleteContainerWithOpts deleteOpts cid = do

85+ clientOpts <- ask

71− runDocker (deleteContainerM clientOpts (SDeleteContainerEndpoint cid deleteOpts))

86+ (^. responseStatus) <$> runDocker (deleteContainerM clientOpts (SDeleteContainerEndpoint cid deleteOpts))

72−

87+

73−getContainerLogsWithOpts :: DockerClientOpts -> LogOpts -> String -> IO (L.ByteString)

88+getContainerLogsWithOpts :: LogOpts -> String -> DockerM IO (L.ByteString)

74−getContainerLogsWithOpts clientOpts l cid = (^. responseBody) <$>

89+getContainerLogsWithOpts l cid = do

90+ clientOpts <- ask

75− runDocker (getContainerLogsM clientOpts (SContainerLogsEndpoint cid l))

91+ (^. responseBody) <$> runDocker (getContainerLogsM clientOpts (SContainerLogsEndpoint cid l))

76−

92+

77−getContainerLogs :: DockerClientOpts -> String -> IO (L.ByteString)

93+getContainerLogs :: String -> DockerM IO (L.ByteString)

78−getContainerLogs clientOpts cid = (^. responseBody) <$>

94+getContainerLogs cid = do

95+ clientOpts <- ask

79− runDocker (getContainerLogsM clientOpts (SContainerLogsEndpoint cid defaultLogOpts))

96+ (^. responseBody) <$> runDocker (getContainerLogsM clientOpts (SContainerLogsEndpoint cid defaultLogOpts))

80−

97+

81−getContainerLogsStream :: DockerClientOpts -> String -> IO ()

98+getContainerLogsStream :: String -> DockerM IO ()

82−getContainerLogsStream clientOpts cid = do

99+getContainerLogsStream cid = do

100+ clientOpts <- ask

83− req <- PH.parseUrl (fullUrl clientOpts url)

101+ req <- PH.parseUrl (fullUrl clientOpts url)

84− let req' = req {PH.method = "GET"}

102+ let req' = req {PH.method = "GET"}

85− PH.withManager PH.defaultManagerSettings $ \m -> PH.withHTTP req' m $ \resp -> runEffect $ PH.responseBody resp >-> PB.stdout

103+ liftIO $ PH.withManager PH.defaultManagerSettings $ \m -> PH.withHTTP req' m $ \resp -> runEffect $ PH.responseBody resp >-> PB.stdout

86− where url = SContainerLogsEndpoint cid defaultLogOpts{follow=True}

104+ where url = SContainerLogsEndpoint cid defaultLogOpts{follow=True}

105

Network/Docker/Internal.hs+8−7

@@ -5,6 +5,7 @@ module Network.Docker.Internal where

6import Control.Lens

7import Control.Monad.Free

8+import Control.Monad.Reader (liftIO)

8import Data.Aeson (FromJSON, ToJSON, Value, decode,

9import Data.Aeson (FromJSON, ToJSON, Value, decode,

9 eitherDecode, toJSON)

10 eitherDecode, toJSON)

10import Data.Aeson.Lens (key, _String)

11import Data.Aeson.Lens (key, _String)

@@ -20,13 +21,13 @@ import Network.Docker.Types

21emptyPost = "" :: String

22emptyPost = "" :: String

23−runDocker :: HttpRequestM r -> IO (Response L.ByteString)

24+runDocker :: HttpRequestM r -> DockerM IO (Response L.ByteString)

24−runDocker (Free (Get url)) = get url

25+runDocker (Free (Get url)) = liftIO $ get url

25−runDocker (Free (GetSSL sslOpts url)) = getSSL sslOpts url

26+runDocker (Free (GetSSL sslOpts url)) = liftIO $ getSSL sslOpts url

26−runDocker (Free (Post url body)) = post url body

27+runDocker (Free (Post url body)) = liftIO $ post url body

27−runDocker (Free (PostSSL sslOpts url body)) = postSSL sslOpts url body

28+runDocker (Free (PostSSL sslOpts url body)) = liftIO $ postSSL sslOpts url body

28−runDocker (Free (Delete url)) = delete url

29+runDocker (Free (Delete url)) = liftIO $ delete url

29−runDocker (Free (DeleteSSL sslOpts url)) = deleteSSL sslOpts url

30+runDocker (Free (DeleteSSL sslOpts url)) = liftIO $ deleteSSL sslOpts url

31constructUrl :: URL -> ApiVersion -> String -> URL

32constructUrl :: URL -> ApiVersion -> String -> URL

32constructUrl url apiVersion endpoint = printf "%s%s%s" url apiVersion endpoint

33constructUrl url apiVersion endpoint = printf "%s%s%s" url apiVersion endpoint

Network/Docker/Types.hs+4

@@ -4,6 +4,7 @@

4{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE GADTs #-}

6{-# LANGUAGE OverloadedStrings #-}

7+{-# LANGUAGE RankNTypes #-}

7{-# LANGUAGE RecordWildCards #-}

8{-# LANGUAGE RecordWildCards #-}

8{-# LANGUAGE TypeFamilies #-}

9{-# LANGUAGE TypeFamilies #-}

@@ -11,6 +12,7 @@ module Network.Docker.Types where

12import Control.Applicative

13import Control.Applicative

13import Control.Monad.Free

14import Control.Monad.Free

15+import Control.Monad.Reader (ReaderT)

14import Data.Aeson

16import Data.Aeson

15import Data.Aeson.Types

17import Data.Aeson.Types

16import Data.Bool

18import Data.Bool

@@ -23,6 +25,8 @@ import Network.Wreq.Types (Postable)

23import OpenSSL.Session (SSLContext)

25import OpenSSL.Session (SSLContext)

24import Prelude hiding (id)

26import Prelude hiding (id)

28+type DockerM m a = ReaderT DockerClientOpts m a

29+

26type URL = String

30type URL = String

27type ApiVersion = String

31type ApiVersion = String

docker.cabal+1

@@ -38,6 +38,7 @@ library

38 , HsOpenSSL

39 , http-client-openssl

40 , free >= 4.9

41+ , mtl

41 -- hs-source-dirs:

42 -- hs-source-dirs:

42 default-language: Haskell2010

43 default-language: Haskell2010