@@ -1,12 +1,15 @@
1+{-# LANGUAGE DataKinds #-}
12{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE TypeFamilies #-}
24
35module Network.Docker where
46
57import Control.Applicative ((<$>), (<*>))
68import Control.Lens
7−import Data.Aeson (FromJSON, ToJSON, decode,
8− eitherDecode, toJSON)
9−import Data.Aeson.Lens (key, _String)
9+import Control.Monad.Free
10+import Data.Aeson (FromJSON, ToJSON, Value, decode,
11+ eitherDecode, toJSON)
12+import Data.Aeson.Lens (key, _String)
1013import Data.Aeson.TH
1114import qualified Data.ByteString.Lazy as L
1215import Data.Char
@@ -23,27 +26,46 @@ import qualified Pipes.ByteString as PB
2326import qualified Pipes.HTTP as PH
2427import Text.Printf (printf)
2528
29+emptyPost = "" :: String
2630
31+<<<<<<< b865ecd79f55927c7265efcacc45692df148aa4a
2732defaultClientOpts :: DockerClientOpts
2833defaultClientOpts = DockerClientOpts
2934 { apiVersion = "v1.12"
3035 , baseUrl = "http://127.0.0.1:3128/"
3136 , ssl = NoSSL
3237 }
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
3343
34−constructUrl :: URL -> ApiVersion -> Endpoint -> URL
44+constructUrl :: URL -> ApiVersion -> String -> URL
3545constructUrl url apiVersion endpoint = printf "%s%s%s" url apiVersion endpoint
3646
37−constructRelativeUrl url = url :: String
38−
39−decodeResponse r = decode <$> (^. responseBody) <$> r
47+-- decodeResponse :: Response L.ByteString -> a
48+decodeResponse r = decode (r ^. responseBody)
4049
41−getOutOfResponse k r = (^? responseBody . key k . _String) r
50+getElemFromResponse k r = (^? responseBody . key k . _String) r
4251
4352getResponseStatusCode r = (^. responseStatus) r
4453
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+
4567fullUrl :: DockerClientOpts -> Endpoint -> URL
46−fullUrl clientOpts endpoint = constructUrl (baseUrl clientOpts) (apiVersion clientOpts) endpoint
68+fullUrl clientOpts endpoint = constructUrl (baseUrl clientOpts) (apiVersion clientOpts) (getEndpoint endpoint)
4769
4870setupSSLCtx :: SSLOptions -> IO SSLContext
4971setupSSLCtx (SSLOptions key cert) = do
@@ -71,74 +93,65 @@ postSSL
7193 -> IO (Response L.ByteString)
7294postSSL sopts url = withOpenSSL . postWith (mkOpts $ setupSSLCtx sopts) url . toJSON
7395
74−_dockerGetQuery :: Endpoint -> DockerClientOpts -> IO(Response L.ByteString)
75−_dockerGetQuery endpoint clientOpts@DockerClientOpts{ssl = NoSSL} =
76− get (fullUrl clientOpts endpoint)
77−_dockerGetQuery endpoint clientOpts@DockerClientOpts{ssl = SSL sslOpts} =
78− getSSL sslOpts (fullUrl clientOpts endpoint)
96+_dockerGetQuery :: DockerClientOpts -> Endpoint -> HttpRequestM Endpoint
97+_dockerGetQuery clientOpts@DockerClientOpts{ssl = NoSSL} endpoint = Free (Get (fullUrl clientOpts endpoint))
98+_dockerGetQuery clientOpts@DockerClientOpts{ssl = SSL sslOpts} endpoint = Free (GetSSL sslOpts (fullUrl clientOpts endpoint))
7999
80−_dockerPostQuery :: ToJSON a => Endpoint -> DockerClientOpts -> a -> IO (Response L.ByteString)
81−_dockerPostQuery endpoint clientOpts@DockerClientOpts{ssl = NoSSL} postObject =
82− post (fullUrl clientOpts endpoint) (toJSON postObject)
83−_dockerPostQuery endpoint clientOpts@DockerClientOpts{ssl = SSL sslOpts} postObject =
84− postSSL sslOpts (fullUrl clientOpts endpoint) postObject
100+_dockerPostQuery :: ToJSON a => DockerClientOpts -> Endpoint -> a -> HttpRequestM Endpoint
101+_dockerPostQuery clientOpts@DockerClientOpts{ssl = NoSSL} endpoint postObject = Free (Post (fullUrl clientOpts endpoint) (toJSON postObject))
102+_dockerPostQuery clientOpts@DockerClientOpts{ssl = SSL sslOpts} endpoint postObject = Free (PostSSL sslOpts (fullUrl clientOpts endpoint) (toJSON postObject))
85103
86−emptyPost = "" :: String
87−_dockerEmptyPostQuery endpoint clientOpts = post (fullUrl clientOpts endpoint) (toJSON emptyPost)
104+_dockerEmptyPostQuery :: DockerClientOpts -> Endpoint -> HttpRequestM Endpoint
105+_dockerEmptyPostQuery clientOpts@DockerClientOpts{ssl = NoSSL} endpoint = Free (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
88110
89111_dockerEmptyDeleteQuery endpoint clientOpts = delete (fullUrl clientOpts endpoint)
90112
91113getDockerVersion :: DockerClientOpts -> IO (Maybe DockerVersion)
92−getDockerVersion = decodeResponse . _dockerGetQuery "/version"
114+getDockerVersion clientOpts = decodeResponse <$> run (getDockerVersionM clientOpts)
93115
94−getDockerContainers :: DockerClientOpts -> IO (Maybe [DockerContainer])
95−getDockerContainers = decodeResponse . _dockerGetQuery "/containers/json"
116+-- getDockerContainers :: DockerClientOpts -> IO (Maybe [DockerContainer])
117+-- getDockerContainers = decodeResponse . _dockerGetQuery "/containers/json"
96118
97−getAllDockerContainers :: DockerClientOpts -> IO (Maybe [DockerContainer])
98−getAllDockerContainers = decodeResponse . _dockerGetQuery "/containers/json?all=true"
119+-- getDockerImages :: DockerClientOpts -> IO (Maybe [DockerImage])
120+-- getDockerImages = decodeResponse . _dockerGetQuery "/images/json"
99121
100−getDockerImages :: DockerClientOpts -> IO (Maybe [DockerImage])
101−getDockerImages = decodeResponse . _dockerGetQuery "/images/json"
122+-- createContainer :: DockerClientOpts -> CreateContainerOpts -> IO(Maybe T.Text)
123+-- createContainer clientOpts createOpts = getElemFromResponse "Id" <$> (_dockerPostQuery "/containers/create" clientOpts createOpts)
102124
103−getAllDockerImages :: DockerClientOpts -> IO (Maybe [DockerImage])
104−getAllDockerImages = decodeResponse . _dockerGetQuery "/images/json?all=true"
125+-- startContainer :: DockerClientOpts -> String -> StartContainerOpts -> IO(Status)
126+-- startContainer clientOpts containerId startOpts = (^. responseStatus) <$> _dockerPostQuery (printf "/containers/%s/start" containerId) clientOpts startOpts
105127
106−createContainer :: DockerClientOpts -> CreateContainerOpts -> IO(Maybe T.Text)
107−createContainer clientOpts createOpts = getOutOfResponse "Id" <$> (_dockerPostQuery "/containers/create" clientOpts createOpts)
128+stopContainerM :: DockerClientOpts -> Endpoint -> HttpRequestM Endpoint
129+stopContainerM clientOpts e = _dockerEmptyPostQuery clientOpts e
108130
109−startContainer :: DockerClientOpts -> String -> StartContainerOpts -> IO(Status)
110−startContainer clientOpts containerId startOpts = (^. responseStatus) <$> _dockerPostQuery (printf "/containers/%s/start" containerId) clientOpts startOpts
111131
112132stopContainer :: DockerClientOpts -> String -> IO (Status)
113−stopContainer clientOpts containerId = (^. responseStatus) <$> _dockerEmptyPostQuery (printf "/containers/%s/stop" containerId) clientOpts
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
133+stopContainer clientOpts cid = (^. responseStatus) <$> run (stopContainerM clientOpts (StopContainerEndpoint cid))
120134
121−pauseContainer :: DockerClientOpts -> String -> IO (Status)
122−pauseContainer clientOpts containerId = (^. responseStatus) <$> _dockerEmptyPostQuery (printf "/containers/%s/pause" containerId) clientOpts
135+-- killContainer :: DockerClientOpts -> String -> IO (Status)
136+-- killContainer clientOpts containerId = (^. responseStatus) <$> _dockerEmptyPostQuery (printf "/containers/%s/kill" containerId) clientOpts
123137
124−unpauseContainer :: DockerClientOpts -> String -> IO (Status)
125−unpauseContainer clientOpts containerId = (^. responseStatus) <$> _dockerEmptyPostQuery (printf "/containers/%s/unpause" containerId) clientOpts
138+-- restartContainer :: DockerClientOpts -> String -> IO (Status)
139+-- restartContainer clientOpts containerId = (^. responseStatus) <$> _dockerEmptyPostQuery (printf "/containers/%s/restart" containerId) clientOpts
126140
127−deleteContainer :: DockerClientOpts -> String -> IO (Status)
128−deleteContainer = deleteContainerWithOpts defaultDeleteOpts
141+-- pauseContainer :: DockerClientOpts -> String -> IO (Status)
142+-- pauseContainer clientOpts containerId = (^. responseStatus) <$> _dockerEmptyPostQuery (printf "/containers/%s/pause" containerId) clientOpts
129143
130−deleteContainerWithOpts :: DeleteOpts -> DockerClientOpts -> String -> IO (Status)
131−deleteContainerWithOpts (DeleteOpts removeVolumes force) clientOpts containerId = (^. responseStatus) <$> _dockerEmptyDeleteQuery req clientOpts
132− where req = printf "/containers/%s?v=%s;force=%s" containerId (show removeVolumes) (show force)
144+-- unpauseContainer :: DockerClientOpts -> String -> IO (Status)
145+-- unpauseContainer clientOpts containerId = (^. responseStatus) <$> _dockerEmptyPostQuery (printf "/containers/%s/unpause" containerId) clientOpts
133146
134−getContainerLogsStream :: DockerClientOpts -> String -> IO ()
135−getContainerLogsStream clientOpts containerId = do
136− req <- PH.parseUrl (fullUrl clientOpts url)
137− let req' = req {PH.method = "GET"}
138− 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)
147+-- getContainerLogsStream :: DockerClientOpts -> String -> IO ()
148+-- getContainerLogsStream clientOpts containerId = do
149+-- req <- PH.parseUrl (fullUrl clientOpts url)
150+-- let req' = req {PH.method = "GET"}
151+-- PH.withManager PH.defaultManagerSettings $ \m -> PH.withHTTP req' m $ \resp -> runEffect $ PH.responseBody resp >-> PB.stdout
152+-- where url = (printf "/containers/%s/logs?stdout=1&stderr=1&follow=1" containerId)
140153
141−getContainerLogs :: DockerClientOpts -> String -> IO (L.ByteString)
142−getContainerLogs clientOpts containerId = (^. responseBody) <$> _dockerGetQuery url clientOpts
143− where url = (printf "/containers/%s/logs?stdout=1&stderr=1" containerId)
154+-- getContainerLogs :: DockerClientOpts -> String -> IO (L.ByteString)
155+-- getContainerLogs clientOpts containerId = (^. responseBody) <$> _dockerGetQuery url clientOpts
156+-- where url = (printf "/containers/%s/logs?stdout=1&stderr=1" containerId)
144157