git.iko.soy/docker-hs
on master help sign in
initial attempt at introducing singleton types
9b39b7dDeni Bertovic
Network/Docker.hs+4−4
compare with master
unifiedsplit
@@ -93,10 +93,10 @@ _dockerEmptyPostQuery clientOpts@DockerClientOpts{ssl = SSL sslOpts} endpoint =
93_dockerEmptyDeleteQuery endpoint clientOpts = delete (fullUrl clientOpts endpoint)
93_dockerEmptyDeleteQuery endpoint clientOpts = delete (fullUrl clientOpts endpoint)
94
94
95getDockerVersion :: DockerClientOpts -> IO (Maybe DockerVersion)
95getDockerVersion :: DockerClientOpts -> IO (Maybe DockerVersion)
96−getDockerVersion clientOpts = decodeResponse <$> run (getDockerVersionM clientOpts)
96+getDockerVersion clientOpts = decodeResponse <$> run (getDockerVersionM clientOpts SVersionEndpoint)
97
97
98−-- getDockerContainers :: DockerClientOpts -> IO (Maybe [DockerContainer])
98+listContainers :: DockerClientOpts -> IO (Maybe [DockerContainer])
99−-- getDockerContainers = decodeResponse . _dockerGetQuery "/containers/json"
99+listContainers clientOpts = decodeResponse <$> run (listContainersM clientOpts SListContainersEndpoint)
100
100
101-- getDockerImages :: DockerClientOpts -> IO (Maybe [DockerImage])
101-- getDockerImages :: DockerClientOpts -> IO (Maybe [DockerImage])
102-- getDockerImages = decodeResponse . _dockerGetQuery "/images/json"
102-- getDockerImages = decodeResponse . _dockerGetQuery "/images/json"
@@ -108,7 +108,7 @@ getDockerVersion clientOpts = decodeResponse <$> run (getDockerVersionM clientOp
108-- startContainer clientOpts containerId startOpts = (^. responseStatus) <$> _dockerPostQuery (printf "/containers/%s/start" containerId) clientOpts startOpts
108-- startContainer clientOpts containerId startOpts = (^. responseStatus) <$> _dockerPostQuery (printf "/containers/%s/start" containerId) clientOpts startOpts
109
109
110stopContainer :: DockerClientOpts -> String -> IO (Status)
110stopContainer :: DockerClientOpts -> String -> IO (Status)
111−stopContainer clientOpts cid = (^. responseStatus) <$> run (stopContainerM clientOpts (StopContainerEndpoint cid))
111+stopContainer clientOpts cid = (^. responseStatus) <$> run (stopContainerM clientOpts (SStopContainerEndpoint cid))
112
112
113-- killContainer :: DockerClientOpts -> String -> IO (Status)
113-- killContainer :: DockerClientOpts -> String -> IO (Status)
114-- killContainer clientOpts containerId = (^. responseStatus) <$> _dockerEmptyPostQuery (printf "/containers/%s/kill" containerId) clientOpts
114-- killContainer clientOpts containerId = (^. responseStatus) <$> _dockerEmptyPostQuery (printf "/containers/%s/kill" containerId) clientOpts
Network/Docker/Internal.hs+25−20
@@ -1,3 +1,6 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE TypeFamilies #-}
3+
1module Network.Docker.Internal where
4module Network.Docker.Internal where
2
5
3import Control.Lens
6import Control.Lens
@@ -27,35 +30,37 @@ getElemFromResponse k r = (^? responseBody . key k . _String) r
27
30
28getResponseStatusCode r = (^. responseStatus) r
31getResponseStatusCode r = (^. responseStatus) r
29
32
30−getEndpoint :: Endpoint -> String
33+getEndpoint :: SEndpoint a -> String
31−getEndpoint VersionEndpoint = "/version"
34+getEndpoint SVersionEndpoint = "/version"
32−getEndpoint ListContainersEndpoint = "/containers/json"
35+getEndpoint SListContainersEndpoint = "/containers/json"
33−getEndpoint ListImagesEndpoint = "/images/json"
36+getEndpoint SListImagesEndpoint = "/images/json"
34−getEndpoint CreateContainerEndpoint = "/containers/create"
37+getEndpoint SCreateContainerEndpoint = "/containers/create"
35−getEndpoint (StartContainerEndpoint cid) = printf "/containers/%s/start" cid
38+getEndpoint (SStartContainerEndpoint cid) = printf "/containers/%s/start" cid
36−getEndpoint (StopContainerEndpoint cid) = printf "/containers/%s/stop" cid
39+getEndpoint (SStopContainerEndpoint cid) = printf "/containers/%s/stop" cid
37−getEndpoint (KillContainerEndpoint cid) = printf "/containers/%s/kill" cid
40+getEndpoint (SKillContainerEndpoint cid) = printf "/containers/%s/kill" cid
38−getEndpoint (RestartContainerEndpoint cid) = printf "/containers/%s/restart" cid
41+getEndpoint (SRestartContainerEndpoint cid) = printf "/containers/%s/restart" cid
39−getEndpoint (PauseContainerEndpoint cid) = printf "/containers/%s/pause" cid
42+getEndpoint (SPauseContainerEndpoint cid) = printf "/containers/%s/pause" cid
40−getEndpoint (UnpauseContainerEndpoint cid) = printf "/containers/%s/unpause" cid
43+getEndpoint (SUnpauseContainerEndpoint cid) = printf "/containers/%s/unpause" cid
41−getEndpoint (ContainerLogsEndpoint cid) = printf "/containers/%s/logs" cid
44+getEndpoint (SContainerLogsEndpoint cid) = printf "/containers/%s/logs" cid
42−
45+
43−fullUrl :: DockerClientOpts -> Endpoint -> URL
46+fullUrl :: DockerClientOpts -> SEndpoint a -> URL
44fullUrl clientOpts endpoint = constructUrl (baseUrl clientOpts) (apiVersion clientOpts) (getEndpoint endpoint)
47fullUrl clientOpts endpoint = constructUrl (baseUrl clientOpts) (apiVersion clientOpts) (getEndpoint endpoint)
45
48
46−_dockerGetQuery :: DockerClientOpts -> Endpoint -> HttpRequestM Endpoint
49+_dockerGetQuery :: DockerClientOpts -> SEndpoint a -> HttpRequestM (SEndpoint a)
47_dockerGetQuery clientOpts endpoint = Free (Get (fullUrl clientOpts endpoint))
50_dockerGetQuery clientOpts endpoint = Free (Get (fullUrl clientOpts endpoint))
48
51
49−_dockerPostQuery :: ToJSON a => DockerClientOpts -> Endpoint -> a -> HttpRequestM Endpoint
52+_dockerPostQuery :: ToJSON b => DockerClientOpts -> SEndpoint a -> b -> HttpRequestM (SEndpoint a)
50_dockerPostQuery clientOpts endpoint postObject = Free (Post (fullUrl clientOpts endpoint) (toJSON postObject))
53_dockerPostQuery clientOpts endpoint postObject = Free (Post (fullUrl clientOpts endpoint) (toJSON postObject))
51
54
52−_dockerEmptyPostQuery :: DockerClientOpts -> Endpoint -> HttpRequestM Endpoint
55+_dockerEmptyPostQuery :: DockerClientOpts -> SEndpoint a -> HttpRequestM (SEndpoint a)
53_dockerEmptyPostQuery clientOpts endpoint = Free (Post (fullUrl clientOpts endpoint) (toJSON emptyPost))
56_dockerEmptyPostQuery clientOpts endpoint = Free (Post (fullUrl clientOpts endpoint) (toJSON emptyPost))
54
57
55−getDockerVersionM :: DockerClientOpts -> HttpRequestM Endpoint
58+getDockerVersionM :: DockerClientOpts -> SEndpoint VersionEndpoint -> HttpRequestM (SEndpoint VersionEndpoint)
56−getDockerVersionM clientOpts = _dockerGetQuery clientOpts VersionEndpoint
59+getDockerVersionM clientOpts e = _dockerGetQuery clientOpts e
57
60
58−stopContainerM :: DockerClientOpts -> Endpoint -> HttpRequestM Endpoint
61+stopContainerM :: DockerClientOpts -> SEndpoint StopContainerEndpoint -> HttpRequestM (SEndpoint StopContainerEndpoint)
59stopContainerM clientOpts e = _dockerEmptyPostQuery clientOpts e
62stopContainerM clientOpts e = _dockerEmptyPostQuery clientOpts e
60
63
64+listContainersM :: DockerClientOpts -> SEndpoint ListContainersEndpoint -> HttpRequestM (SEndpoint ListContainersEndpoint)
65+listContainersM clientOpts e = _dockerGetQuery clientOpts e
61
66
Network/Docker/Types.hs+25−11
@@ -43,17 +43,31 @@ data DockerClientOpts = DockerClientOpts {
43 } deriving (Show)
43 } deriving (Show)
44
44
45data Endpoint =
45data Endpoint =
46− VersionEndpoint
46+ VersionEndpoint
47− | ListContainersEndpoint
47+ | ListContainersEndpoint
48− | ListImagesEndpoint
48+ | ListImagesEndpoint
49− | CreateContainerEndpoint
49+ | CreateContainerEndpoint
50− | StartContainerEndpoint String
50+ | StartContainerEndpoint
51− | StopContainerEndpoint String
51+ | StopContainerEndpoint
52− | KillContainerEndpoint String
52+ | KillContainerEndpoint
53− | RestartContainerEndpoint String
53+ | RestartContainerEndpoint
54− | PauseContainerEndpoint String
54+ | PauseContainerEndpoint
55− | UnpauseContainerEndpoint String
55+ | UnpauseContainerEndpoint
56− | ContainerLogsEndpoint String
56+ | ContainerLogsEndpoint
57+
58+
59+data SEndpoint (a :: Endpoint) where
60+ SVersionEndpoint :: SEndpoint VersionEndpoint
61+ SListContainersEndpoint :: SEndpoint ListContainersEndpoint
62+ SListImagesEndpoint :: SEndpoint ListImagesEndpoint
63+ SCreateContainerEndpoint :: SEndpoint CreateContainerEndpoint
64+ SStartContainerEndpoint :: String -> SEndpoint StartContainerEndpoint
65+ SStopContainerEndpoint :: String -> SEndpoint StopContainerEndpoint
66+ SKillContainerEndpoint :: String -> SEndpoint KillContainerEndpoint
67+ SRestartContainerEndpoint :: String -> SEndpoint RestartContainerEndpoint
68+ SPauseContainerEndpoint :: String -> SEndpoint PauseContainerEndpoint
69+ SUnpauseContainerEndpoint :: String -> SEndpoint UnpauseContainerEndpoint
70+ SContainerLogsEndpoint :: String -> SEndpoint ContainerLogsEndpoint
57
71
58defaultClientOpts :: DockerClientOpts
72defaultClientOpts :: DockerClientOpts
59defaultClientOpts = DockerClientOpts
73defaultClientOpts = DockerClientOpts