9b39b7d · docker-hs · git.iko.soy

git.iko.soy/docker-hs

initial attempt at introducing singleton types

this allows us to be sure that the exported functions are calling the exact endpoints during compile time. So if I make a typo somewhere the compiler should warn me that for instance my version function is calling the ListContainers endpoint and throw a type error.

commit9b39b7d16063c15a2d7356978e17ca9b1fea5fc1 authorDeni Bertovic <deni@denibertovic.com> dateSun 11 Jan 2015, 20:47 (12 years ago) parent89beb36

3 files changed+54−35

compare with master

unifiedsplit

Network/Docker.hs+4−4 Network/Docker/Internal.hs+25−20 Network/Docker/Types.hs+25−11

Network/Docker.hs+4−4

@@ -93,10 +93,10 @@ _dockerEmptyPostQuery clientOpts@DockerClientOpts{ssl = SSL sslOpts} endpoint =

9393_dockerEmptyDeleteQuery endpoint clientOpts = delete (fullUrl clientOpts endpoint)

9494

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

96−getDockerVersion clientOpts = decodeResponse <$> run (getDockerVersionM clientOpts)

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

9797

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

99−-- getDockerContainers = decodeResponse . _dockerGetQuery "/containers/json"

98+listContainers :: DockerClientOpts -> IO (Maybe [DockerContainer])

99+listContainers clientOpts = decodeResponse <$> run (listContainersM clientOpts SListContainersEndpoint)

100100

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

102102-- getDockerImages = decodeResponse . _dockerGetQuery "/images/json"

@@ -108,7 +108,7 @@ getDockerVersion clientOpts = decodeResponse <$> run (getDockerVersionM clientOp

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

109109

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

111−stopContainer clientOpts cid = (^. responseStatus) <$> run (stopContainerM clientOpts (StopContainerEndpoint cid))

111+stopContainer clientOpts cid = (^. responseStatus) <$> run (stopContainerM clientOpts (SStopContainerEndpoint cid))

112112

113113-- killContainer :: DockerClientOpts -> String -> IO (Status)

114114-- 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 #-}

14module Network.Docker.Internal where

36import Control.Lens

@@ -27,35 +30,37 @@ getElemFromResponse k r = (^? responseBody . key k . _String) r

2730

2831getResponseStatusCode r = (^. responseStatus) r

2932

30−getEndpoint :: Endpoint -> String

31−getEndpoint VersionEndpoint = "/version"

32−getEndpoint ListContainersEndpoint = "/containers/json"

33−getEndpoint ListImagesEndpoint = "/images/json"

34−getEndpoint CreateContainerEndpoint = "/containers/create"

35−getEndpoint (StartContainerEndpoint cid) = printf "/containers/%s/start" cid

36−getEndpoint (StopContainerEndpoint cid) = printf "/containers/%s/stop" cid

37−getEndpoint (KillContainerEndpoint cid) = printf "/containers/%s/kill" cid

38−getEndpoint (RestartContainerEndpoint cid) = printf "/containers/%s/restart" cid

39−getEndpoint (PauseContainerEndpoint cid) = printf "/containers/%s/pause" cid

40−getEndpoint (UnpauseContainerEndpoint cid) = printf "/containers/%s/unpause" cid

41−getEndpoint (ContainerLogsEndpoint cid) = printf "/containers/%s/logs" cid

42−

43−fullUrl :: DockerClientOpts -> Endpoint -> URL

33+getEndpoint :: SEndpoint a -> String

34+getEndpoint SVersionEndpoint = "/version"

35+getEndpoint SListContainersEndpoint = "/containers/json"

36+getEndpoint SListImagesEndpoint = "/images/json"

37+getEndpoint SCreateContainerEndpoint = "/containers/create"

38+getEndpoint (SStartContainerEndpoint cid) = printf "/containers/%s/start" cid

39+getEndpoint (SStopContainerEndpoint cid) = printf "/containers/%s/stop" cid

40+getEndpoint (SKillContainerEndpoint cid) = printf "/containers/%s/kill" cid

41+getEndpoint (SRestartContainerEndpoint cid) = printf "/containers/%s/restart" cid

42+getEndpoint (SPauseContainerEndpoint cid) = printf "/containers/%s/pause" cid

43+getEndpoint (SUnpauseContainerEndpoint cid) = printf "/containers/%s/unpause" cid

44+getEndpoint (SContainerLogsEndpoint cid) = printf "/containers/%s/logs" cid

45+

46+fullUrl :: DockerClientOpts -> SEndpoint a -> URL

4447fullUrl clientOpts endpoint = constructUrl (baseUrl clientOpts) (apiVersion clientOpts) (getEndpoint endpoint)

4548

46−_dockerGetQuery :: DockerClientOpts -> Endpoint -> HttpRequestM Endpoint

49+_dockerGetQuery :: DockerClientOpts -> SEndpoint a -> HttpRequestM (SEndpoint a)

4750_dockerGetQuery clientOpts endpoint = Free (Get (fullUrl clientOpts endpoint))

4851

49−_dockerPostQuery :: ToJSON a => DockerClientOpts -> Endpoint -> a -> HttpRequestM Endpoint

52+_dockerPostQuery :: ToJSON b => DockerClientOpts -> SEndpoint a -> b -> HttpRequestM (SEndpoint a)

5053_dockerPostQuery clientOpts endpoint postObject = Free (Post (fullUrl clientOpts endpoint) (toJSON postObject))

5154

52−_dockerEmptyPostQuery :: DockerClientOpts -> Endpoint -> HttpRequestM Endpoint

55+_dockerEmptyPostQuery :: DockerClientOpts -> SEndpoint a -> HttpRequestM (SEndpoint a)

5356_dockerEmptyPostQuery clientOpts endpoint = Free (Post (fullUrl clientOpts endpoint) (toJSON emptyPost))

5457

55−getDockerVersionM :: DockerClientOpts -> HttpRequestM Endpoint

56−getDockerVersionM clientOpts = _dockerGetQuery clientOpts VersionEndpoint

58+getDockerVersionM :: DockerClientOpts -> SEndpoint VersionEndpoint -> HttpRequestM (SEndpoint VersionEndpoint)

59+getDockerVersionM clientOpts e = _dockerGetQuery clientOpts e

5760

58−stopContainerM :: DockerClientOpts -> Endpoint -> HttpRequestM Endpoint

61+stopContainerM :: DockerClientOpts -> SEndpoint StopContainerEndpoint -> HttpRequestM (SEndpoint StopContainerEndpoint)

5962stopContainerM clientOpts e = _dockerEmptyPostQuery clientOpts e

6063

64+listContainersM :: DockerClientOpts -> SEndpoint ListContainersEndpoint -> HttpRequestM (SEndpoint ListContainersEndpoint)

65+listContainersM clientOpts e = _dockerGetQuery clientOpts e

6166

Network/Docker/Types.hs+25−11

@@ -43,17 +43,31 @@ data DockerClientOpts = DockerClientOpts {

4343 } deriving (Show)

4444

4545data Endpoint =

46− VersionEndpoint

47− | ListContainersEndpoint

48− | ListImagesEndpoint

49− | CreateContainerEndpoint

50− | StartContainerEndpoint String

51− | StopContainerEndpoint String

52− | KillContainerEndpoint String

53− | RestartContainerEndpoint String

54− | PauseContainerEndpoint String

55− | UnpauseContainerEndpoint String

56− | ContainerLogsEndpoint String

46+ VersionEndpoint

47+ | ListContainersEndpoint

48+ | ListImagesEndpoint

49+ | CreateContainerEndpoint

50+ | StartContainerEndpoint

51+ | StopContainerEndpoint

52+ | KillContainerEndpoint

53+ | RestartContainerEndpoint

54+ | PauseContainerEndpoint

55+ | UnpauseContainerEndpoint

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

5771

5872defaultClientOpts :: DockerClientOpts

5973defaultClientOpts = DockerClientOpts