fada835 · docker-hs · git.iko.soy

git.iko.soy/docker-hs

on master help sign in

firt attempt at writing an interpreter for https actions

fada835Deni Bertovic12 years ago

Network/Docker.hs+72−59

compare with master

unifiedsplit

@@ -1,12 +1,15 @@

1+{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE TypeFamilies #-}

3module Network.Docker where

5module Network.Docker where

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

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

6import Control.Lens

8import Control.Lens

9+import Control.Monad.Free

7−import Data.Aeson (FromJSON, ToJSON, decode,

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

8− eitherDecode, toJSON)

11+ eitherDecode, toJSON)

9−import Data.Aeson.Lens (key, _String)

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

10import Data.Aeson.TH

13import Data.Aeson.TH

11import qualified Data.ByteString.Lazy as L

14import qualified Data.ByteString.Lazy as L

12import Data.Char

15import Data.Char

@@ -23,27 +26,46 @@ import qualified Pipes.ByteString as PB

23import qualified Pipes.HTTP as PH

26import qualified Pipes.HTTP as PH

24import Text.Printf (printf)

27import Text.Printf (printf)

29+emptyPost = "" :: String

31+<<<<<<< b865ecd79f55927c7265efcacc45692df148aa4a

27defaultClientOpts :: DockerClientOpts

32defaultClientOpts :: DockerClientOpts

28defaultClientOpts = DockerClientOpts

33defaultClientOpts = DockerClientOpts

29 { apiVersion = "v1.12"

34 { apiVersion = "v1.12"

30 , baseUrl = "http://127.0.0.1:3128/"

35 , baseUrl = "http://127.0.0.1:3128/"

31 , ssl = NoSSL

36 , ssl = NoSSL

32 }

37 }

38+run :: HttpRequestM r -> IO (Response L.ByteString)

39+run (Free (Get url)) = get url

40+run (Free (GetSSL sslOpts url)) = getSSL sslOpts url

41+run (Free (Post url body)) = post url body

42+run (Free (PostSSL sslOpts url body)) = postSSL sslOpts url body

34−constructUrl :: URL -> ApiVersion -> Endpoint -> URL

44+constructUrl :: URL -> ApiVersion -> String -> URL

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

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

37−constructRelativeUrl url = url :: String

47+-- decodeResponse :: Response L.ByteString -> a

38−

39−decodeResponse r = decode <$> (^. responseBody) <$> r

48+decodeResponse r = decode (r ^. responseBody)

41−getOutOfResponse k r = (^? responseBody . key k . _String) r

50+getElemFromResponse k r = (^? responseBody . key k . _String) r

43getResponseStatusCode r = (^. responseStatus) r

52getResponseStatusCode r = (^. responseStatus) r

54+getEndpoint :: Endpoint -> String

55+getEndpoint VersionEndpoint = "/version"

56+getEndpoint ListContainersEndpoint = "/containers/json"

57+getEndpoint ListImagesEndpoint = "/images/json"

58+getEndpoint CreateContainerEndpoint = "/containers/create"

59+getEndpoint (StartContainerEndpoint cid) = printf "/containers/%s/start" cid

60+getEndpoint (StopContainerEndpoint cid) = printf "/containers/%s/stop" cid

61+getEndpoint (KillContainerEndpoint cid) = printf "/containers/%s/kill" cid

62+getEndpoint (RestartContainerEndpoint cid) = printf "/containers/%s/restart" cid

63+getEndpoint (PauseContainerEndpoint cid) = printf "/containers/%s/pause" cid

64+getEndpoint (UnpauseContainerEndpoint cid) = printf "/containers/%s/unpause" cid

65+getEndpoint (ContainerLogsEndpoint cid) = printf "/containers/%s/logs" cid

66+

45fullUrl :: DockerClientOpts -> Endpoint -> URL

67fullUrl :: DockerClientOpts -> Endpoint -> URL

46−fullUrl clientOpts endpoint = constructUrl (baseUrl clientOpts) (apiVersion clientOpts) endpoint

68+fullUrl clientOpts endpoint = constructUrl (baseUrl clientOpts) (apiVersion clientOpts) (getEndpoint endpoint)

48setupSSLCtx :: SSLOptions -> IO SSLContext

70setupSSLCtx :: SSLOptions -> IO SSLContext

49setupSSLCtx (SSLOptions key cert) = do

71setupSSLCtx (SSLOptions key cert) = do

@@ -71,74 +93,65 @@ postSSL

71 -> IO (Response L.ByteString)

93 -> IO (Response L.ByteString)

72postSSL sopts url = withOpenSSL . postWith (mkOpts $ setupSSLCtx sopts) url . toJSON

94postSSL sopts url = withOpenSSL . postWith (mkOpts $ setupSSLCtx sopts) url . toJSON

74−_dockerGetQuery :: Endpoint -> DockerClientOpts -> IO(Response L.ByteString)

96+_dockerGetQuery :: DockerClientOpts -> Endpoint -> HttpRequestM Endpoint

75−_dockerGetQuery endpoint clientOpts@DockerClientOpts{ssl = NoSSL} =

97+_dockerGetQuery clientOpts@DockerClientOpts{ssl = NoSSL} endpoint = Free (Get (fullUrl clientOpts endpoint))

76− get (fullUrl clientOpts endpoint)

77−_dockerGetQuery endpoint clientOpts@DockerClientOpts{ssl = SSL sslOpts} =

98+_dockerGetQuery clientOpts@DockerClientOpts{ssl = SSL sslOpts} endpoint = Free (GetSSL sslOpts (fullUrl clientOpts endpoint))

78− getSSL sslOpts (fullUrl clientOpts endpoint)

80−_dockerPostQuery :: ToJSON a => Endpoint -> DockerClientOpts -> a -> IO (Response L.ByteString)

100+_dockerPostQuery :: ToJSON a => DockerClientOpts -> Endpoint -> a -> HttpRequestM Endpoint

81−_dockerPostQuery endpoint clientOpts@DockerClientOpts{ssl = NoSSL} postObject =

101+_dockerPostQuery clientOpts@DockerClientOpts{ssl = NoSSL} endpoint postObject = Free (Post (fullUrl clientOpts endpoint) (toJSON postObject))

82− post (fullUrl clientOpts endpoint) (toJSON postObject)

83−_dockerPostQuery endpoint clientOpts@DockerClientOpts{ssl = SSL sslOpts} postObject =

102+_dockerPostQuery clientOpts@DockerClientOpts{ssl = SSL sslOpts} endpoint postObject = Free (PostSSL sslOpts (fullUrl clientOpts endpoint) (toJSON postObject))

84− postSSL sslOpts (fullUrl clientOpts endpoint) postObject

103

86−emptyPost = "" :: String

104+_dockerEmptyPostQuery :: DockerClientOpts -> Endpoint -> HttpRequestM Endpoint

105+_dockerEmptyPostQuery clientOpts@DockerClientOpts{ssl = NoSSL} endpoint = Free (Post (fullUrl clientOpts endpoint) (toJSON emptyPost))

87−_dockerEmptyPostQuery endpoint clientOpts = post (fullUrl clientOpts endpoint) (toJSON emptyPost)

106+_dockerEmptyPostQuery clientOpts@DockerClientOpts{ssl = SSL sslOpts} endpoint = Free (PostSSL sslOpts (fullUrl clientOpts endpoint) (toJSON emptyPost))

107+

108+getDockerVersionM :: DockerClientOpts -> HttpRequestM Endpoint

109+getDockerVersionM clientOpts = _dockerGetQuery clientOpts VersionEndpoint

110

89_dockerEmptyDeleteQuery endpoint clientOpts = delete (fullUrl clientOpts endpoint)

111_dockerEmptyDeleteQuery endpoint clientOpts = delete (fullUrl clientOpts endpoint)

112

91getDockerVersion :: DockerClientOpts -> IO (Maybe DockerVersion)

113getDockerVersion :: DockerClientOpts -> IO (Maybe DockerVersion)

92−getDockerVersion = decodeResponse . _dockerGetQuery "/version"

114+getDockerVersion clientOpts = decodeResponse <$> run (getDockerVersionM clientOpts)

115

94−getDockerContainers :: DockerClientOpts -> IO (Maybe [DockerContainer])

116+-- getDockerContainers :: DockerClientOpts -> IO (Maybe [DockerContainer])

95−getDockerContainers = decodeResponse . _dockerGetQuery "/containers/json"

117+-- getDockerContainers = decodeResponse . _dockerGetQuery "/containers/json"

118

97−getAllDockerContainers :: DockerClientOpts -> IO (Maybe [DockerContainer])

119+-- getDockerImages :: DockerClientOpts -> IO (Maybe [DockerImage])

98−getAllDockerContainers = decodeResponse . _dockerGetQuery "/containers/json?all=true"

120+-- getDockerImages = decodeResponse . _dockerGetQuery "/images/json"

121

100−getDockerImages :: DockerClientOpts -> IO (Maybe [DockerImage])

122+-- createContainer :: DockerClientOpts -> CreateContainerOpts -> IO(Maybe T.Text)

101−getDockerImages = decodeResponse . _dockerGetQuery "/images/json"

123+-- createContainer clientOpts createOpts = getElemFromResponse "Id" <$> (_dockerPostQuery "/containers/create" clientOpts createOpts)

102

124

103−getAllDockerImages :: DockerClientOpts -> IO (Maybe [DockerImage])

125+-- startContainer :: DockerClientOpts -> String -> StartContainerOpts -> IO(Status)

104−getAllDockerImages = decodeResponse . _dockerGetQuery "/images/json?all=true"

126+-- startContainer clientOpts containerId startOpts = (^. responseStatus) <$> _dockerPostQuery (printf "/containers/%s/start" containerId) clientOpts startOpts

105

127

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

128+stopContainerM :: DockerClientOpts -> Endpoint -> HttpRequestM Endpoint

107−createContainer clientOpts createOpts = getOutOfResponse "Id" <$> (_dockerPostQuery "/containers/create" clientOpts createOpts)

129+stopContainerM clientOpts e = _dockerEmptyPostQuery clientOpts e

108

130

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

110−startContainer clientOpts containerId startOpts = (^. responseStatus) <$> _dockerPostQuery (printf "/containers/%s/start" containerId) clientOpts startOpts

111

131

112stopContainer :: DockerClientOpts -> String -> IO (Status)

132stopContainer :: DockerClientOpts -> String -> IO (Status)

113−stopContainer clientOpts containerId = (^. responseStatus) <$> _dockerEmptyPostQuery (printf "/containers/%s/stop" containerId) clientOpts

133+stopContainer clientOpts cid = (^. responseStatus) <$> run (stopContainerM clientOpts (StopContainerEndpoint cid))

114−

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

116−killContainer clientOpts containerId = (^. responseStatus) <$> _dockerEmptyPostQuery (printf "/containers/%s/kill" containerId) clientOpts

117−

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

119−restartContainer clientOpts containerId = (^. responseStatus) <$> _dockerEmptyPostQuery (printf "/containers/%s/restart" containerId) clientOpts

120

134

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

135+-- killContainer :: DockerClientOpts -> String -> IO (Status)

122−pauseContainer clientOpts containerId = (^. responseStatus) <$> _dockerEmptyPostQuery (printf "/containers/%s/pause" containerId) clientOpts

136+-- killContainer clientOpts containerId = (^. responseStatus) <$> _dockerEmptyPostQuery (printf "/containers/%s/kill" containerId) clientOpts

123

137

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

138+-- restartContainer :: DockerClientOpts -> String -> IO (Status)

125−unpauseContainer clientOpts containerId = (^. responseStatus) <$> _dockerEmptyPostQuery (printf "/containers/%s/unpause" containerId) clientOpts

139+-- restartContainer clientOpts containerId = (^. responseStatus) <$> _dockerEmptyPostQuery (printf "/containers/%s/restart" containerId) clientOpts

126

140

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

141+-- pauseContainer :: DockerClientOpts -> String -> IO (Status)

128−deleteContainer = deleteContainerWithOpts defaultDeleteOpts

142+-- pauseContainer clientOpts containerId = (^. responseStatus) <$> _dockerEmptyPostQuery (printf "/containers/%s/pause" containerId) clientOpts

129

143

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

144+-- unpauseContainer :: DockerClientOpts -> String -> IO (Status)

131−deleteContainerWithOpts (DeleteOpts removeVolumes force) clientOpts containerId = (^. responseStatus) <$> _dockerEmptyDeleteQuery req clientOpts

145+-- unpauseContainer clientOpts containerId = (^. responseStatus) <$> _dockerEmptyPostQuery (printf "/containers/%s/unpause" containerId) clientOpts

132− where req = printf "/containers/%s?v=%s;force=%s" containerId (show removeVolumes) (show force)

133

146

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

147+-- getContainerLogsStream :: DockerClientOpts -> String -> IO ()

135−getContainerLogsStream clientOpts containerId = do

148+-- getContainerLogsStream clientOpts containerId = do

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

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

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

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

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

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

139− where url = (printf "/containers/%s/logs?stdout=1&stderr=1&follow=1" containerId)

152+-- where url = (printf "/containers/%s/logs?stdout=1&stderr=1&follow=1" containerId)

140

153

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

154+-- getContainerLogs :: DockerClientOpts -> String -> IO (L.ByteString)

142−getContainerLogs clientOpts containerId = (^. responseBody) <$> _dockerGetQuery url clientOpts

155+-- getContainerLogs clientOpts containerId = (^. responseBody) <$> _dockerGetQuery url clientOpts

143− where url = (printf "/containers/%s/logs?stdout=1&stderr=1" containerId)

156+-- where url = (printf "/containers/%s/logs?stdout=1&stderr=1" containerId)

144

157