f5f0395 · docker-hs · git.iko.soy

git.iko.soy/docker-hs

Adds more endpoints

Needs factoring out of common parts. But first things first... Let's get them all working and then refactor.

commitf5f0395466af3f2924f05b019e9dd232ca1ae01c authorDeni Bertovic <deni@denibertovic.com> dateMon 14 Mar 2016, 15:48 (11 years ago) parentb9fcd6c

3 files changed+154−26

compare with master

unifiedsplit

src/Docker.hs+71−9 src/Docker/Internal.hs+23−8 src/Docker/Types.hs+60−9

src/Docker.hs+71−9

@@ -23,34 +23,96 @@ getDockerVersion = do

2323 return $ fromJust res

2424

2525listContainers :: ListOpts -> DockerT IO ([Container])

26−listContainers = undefined

26+listContainers lopts = do

27+ (opts, httpHandler) <- ask

28+ let request = fromJust $ mkHttpRequest GET (ListContainersEndpoint lopts) opts

29+ response <- liftIO $ httpHandler request

30+ let body = responseBody response

31+ let res = decode body

32+ return $ fromJust res

33+

2734

2835listImages :: ListOpts -> DockerT IO ([Image])

29−listImages = undefined

36+listImages lopts = do

37+ (opts, httpHandler) <- ask

38+ let request = fromJust $ mkHttpRequest GET (ListImagesEndpoint lopts) opts

39+ response <- liftIO $ httpHandler request

40+ let body = responseBody response

41+ let res = decode body

42+ return $ fromJust res

43+

3044

3145createContainer :: CreateOpts -> DockerT IO (ContainerID)

3246createContainer = undefined

3347

3448startContainer :: StartOpts -> ContainerID -> DockerT IO (ContainerID)

35−startContainer = undefined

49+startContainer sopts cid = do

50+ (opts, httpHandler) <- ask

51+ let request = fromJust $ mkHttpRequest GET (StartContainerEndpoint sopts cid) opts

52+ response <- liftIO $ httpHandler request

53+ let body = responseBody response

54+ let res = decode body

55+ return $ fromJust res

56+

3657

3758stopContainer :: Timeout -> ContainerID ->DockerT IO ()

38−stopContainer = undefined

59+stopContainer t cid = do

60+ (opts, httpHandler) <- ask

61+ let request = fromJust $ mkHttpRequest GET (StopContainerEndpoint t cid) opts

62+ response <- liftIO $ httpHandler request

63+ let body = responseBody response

64+ let res = decode body

65+ return $ fromJust res

66+

3967

4068killContainer :: Signal -> ContainerID -> DockerT IO ()

41−killContainer = undefined

69+killContainer s cid = do

70+ (opts, httpHandler) <- ask

71+ let request = fromJust $ mkHttpRequest GET (KillContainerEndpoint s cid) opts

72+ response <- liftIO $ httpHandler request

73+ let body = responseBody response

74+ let res = decode body

75+ return $ fromJust res

76+

4277

4378restartContainer :: Timeout -> ContainerID -> DockerT IO ()

44−restartContainer = undefined

79+restartContainer t cid = do

80+ (opts, httpHandler) <- ask

81+ let request = fromJust $ mkHttpRequest GET (RestartContainerEndpoint t cid) opts

82+ response <- liftIO $ httpHandler request

83+ let body = responseBody response

84+ let res = decode body

85+ return $ fromJust res

86+

4587

4688pauseContainer :: ContainerID -> DockerT IO ()

47−pauseContainer = undefined

89+pauseContainer cid = do

90+ (opts, httpHandler) <- ask

91+ let request = fromJust $ mkHttpRequest GET (PauseContainerEndpoint cid) opts

92+ response <- liftIO $ httpHandler request

93+ let body = responseBody response

94+ let res = decode body

95+ return $ fromJust res

96+

4897

4998unpauseContainer :: ContainerID -> DockerT IO ()

50−unpauseContainer = undefined

99+unpauseContainer cid = do

100+ (opts, httpHandler) <- ask

101+ let request = fromJust $ mkHttpRequest GET (UnpauseContainerEndpoint cid) opts

102+ response <- liftIO $ httpHandler request

103+ let body = responseBody response

104+ let res = decode body

105+ return $ fromJust res

106+

51107

52108deleteContainer :: DeleteOpts -> ContainerID -> DockerT IO ()

53−deleteContainer = undefined

109+deleteContainer dopts cid = do

110+ (opts, httpHandler) <- ask

111+ let request = fromJust $ mkHttpRequest GET (DeleteContainerEndpoint dopts cid) opts

112+ response <- liftIO $ httpHandler request

113+ let body = responseBody response

114+ let res = decode body

115+ return $ fromJust res

54116

55117getContainerLogs :: LogOpts -> ContainerID -> DockerT IO ()

56118getContainerLogs = undefined

src/Docker/Internal.hs+23−8

@@ -42,23 +42,38 @@ encodeURL ps = decodeUtf8 $ toByteString $ encodePathSegments ps

4242encodeURLWithQuery :: [Text] -> Query -> Text

4343encodeURLWithQuery ps q = decodeUtf8 $ toByteString $ encodePath ps q

4444

45−encodeQ = encodeUtf8 . T.pack . show

45+encodeQ = encodeUtf8 . T.pack

4646

4747getEndpoint :: Endpoint -> Text

4848getEndpoint VersionEndpoint = encodeURL ["version"]

4949getEndpoint (ListContainersEndpoint lsOpts) = encodeURL ["containers", "json"]

5050getEndpoint (ListImagesEndpoint lsOpts) = encodeURL ["images", "json"]

5151getEndpoint CreateContainerEndpoint = encodeURL ["containers", "create"]

52−getEndpoint (StartContainerEndpoint cid) = encodeURL ["containers", cid, "start"]

53−getEndpoint (StopContainerEndpoint cid) = encodeURL ["containers", cid, "stop"]

54−getEndpoint (KillContainerEndpoint cid) = encodeURL ["containers", cid, "kill"]

55−getEndpoint (RestartContainerEndpoint cid) = encodeURL ["containers", cid, "restart"]

52+getEndpoint (StartContainerEndpoint startOpts cid) = encodeURLWithQuery ["containers", cid, "start"] query

53+ where query = case (detachKeys startOpts) of

54+ WithCtrl c -> [("detachKeys", Just (encodeQ $ ctrl ++ [c]))]

55+ WithoutCtrl c -> [("detachKeys", Just (encodeQ [c]))]

56+ DefaultDetachKey -> []

57+ ctrl = ['c', 't', 'r', 'l', '-']

58+getEndpoint (StopContainerEndpoint t cid) = encodeURLWithQuery ["containers", cid, "stop"] query

59+ where query = case t of

60+ Timeout x -> [("t", Just (encodeQ $ show x))]

61+ DefaultTimeout -> []

62+getEndpoint (KillContainerEndpoint s cid) = encodeURLWithQuery ["containers", cid, "kill"] query

63+ where query = case s of

64+ SIG x -> [("signal", Just (encodeQ $ show x))]

65+ otherwise -> [("signal", Just (encodeQ $ show s))]

66+getEndpoint (RestartContainerEndpoint t cid) = encodeURLWithQuery ["containers", cid, "restart"] query

67+ where query = case t of

68+ Timeout x -> [("t", Just (encodeQ $ show x))]

69+ DefaultTimeout -> []

70+

5671getEndpoint (PauseContainerEndpoint cid) = encodeURL ["containers", cid, "pause"]

5772getEndpoint (UnpauseContainerEndpoint cid) = encodeURL ["containers", cid, "unpause"]

5873getEndpoint (ContainerLogsEndpoint cid (LogOpts follow stdout stderr since timestamps tail)) =

5974 encodeURLWithQuery ["containers", cid, "logs"] query

60− where query = [("stdout", Just (encodeQ stdout)), ("stderr", Just (encodeQ stderr)), ("follow", Just (encodeQ follow))]

61−getEndpoint (DeleteContainerEndpoint cid (DeleteOpts removeVolumes force)) =

75+ where query = [("stdout", Just (encodeQ $ show stdout)), ("stderr", Just (encodeQ $ show stderr)), ("follow", Just (encodeQ $ show follow))]

76+getEndpoint (DeleteContainerEndpoint (DeleteOpts removeVolumes force) cid) =

6277 encodeURLWithQuery ["containers", cid] query

63− where query = [("v", Just (encodeQ removeVolumes)), ("force", Just (encodeQ force))]

78+ where query = [("v", Just (encodeQ $ show removeVolumes)), ("force", Just (encodeQ $ show force))]

6479

src/Docker/Types.hs+60−9

@@ -16,6 +16,7 @@ import qualified Data.Text as T

1616import GHC.Generics (Generic)

1717import qualified Network.HTTP.Client as HTTP

1818import Network.HTTP.Types (StdMethod)

19+import Prelude hiding (all)

1920

2021type HttpVerb = StdMethod

2122

@@ -24,25 +25,33 @@ data Endpoint =

2425 | ListContainersEndpoint ListOpts

2526 | ListImagesEndpoint ListOpts

2627 | CreateContainerEndpoint

27− | StartContainerEndpoint ContainerID

28− | StopContainerEndpoint ContainerID

29− | KillContainerEndpoint ContainerID

30− | RestartContainerEndpoint ContainerID

31− | PauseContainerEndpoint ContainerName

28+ | StartContainerEndpoint StartOpts ContainerID

29+ | StopContainerEndpoint Timeout ContainerID

30+ | KillContainerEndpoint Signal ContainerID

31+ | RestartContainerEndpoint Timeout ContainerID

32+ | PauseContainerEndpoint ContainerID

3233 | UnpauseContainerEndpoint ContainerID

3334 | ContainerLogsEndpoint ContainerID LogOpts

34− | DeleteContainerEndpoint ContainerID DeleteOpts

35+ | DeleteContainerEndpoint DeleteOpts ContainerID

3536

3637type URL = Text

3738type ApiVersion = Text

3839type ContainerID = Text

3940type ImageID = Text

40−type Timeout = Integer

41+

42+data Timeout = Timeout Integer | DefaultTimeout deriving (Eq, Show)

4143

4244type Request = HTTP.Request

4345type Response = HTTP.Response BL.ByteString

4446

45−data Signal = SIGINT | SIGKILL deriving (Eq, Show)

47+data Signal = SIGHUP

48+ | SIGINT

49+ | SIGQUIT

50+ | SIGSTOP

51+ | SIGTERM

52+ | SIGUSR1

53+ | SIG Integer

54+ | SIGKILL deriving (Eq, Show)

4655

4756data DockerClientOpts = DockerClientOpts {

4857 apiVer :: ApiVersion

@@ -59,6 +68,8 @@ runDockerT (opts, h) r = runExceptT $ runReaderT r (opts, h)

5968

6069data ListOpts = ListOpts { all :: Bool } deriving (Eq, Show)

6170

71+defaultListOpts = ListOpts { all=False }

72+

6273defaultClientOpts :: DockerClientOpts

6374defaultClientOpts = DockerClientOpts {

6475 apiVer = "v1.22"

@@ -85,7 +96,40 @@ instance FromJSON DockerVersion where

8596 parseJSON = genericParseJSON defaultOptions {

8697 fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}

8798

99+-- TODO: Add NetworkSettings

100+-- TODO: Add PortBindings

88101data Container = Container

102+ { containerId :: ContainerID

103+ , containerNames :: [Text]

104+ , containerImageName :: Text

105+ , containerImageId :: ImageID

106+ , containerCommand :: Text

107+ , containerCreatedAt :: Int

108+ , containerStatus :: Text

109+ -- , containerPorts :: Text

110+ , containerLabels :: Labels

111+ -- , containerNetworkSettings :: Text

112+ } deriving (Show, Eq)

113+

114+instance FromJSON Container where

115+ parseJSON (JSON.Object v) =

116+ Container <$> (v .: "Id")

117+ <*> (v .: "Names")

118+ <*> (v .: "Image")

119+ <*> (v .: "ImageID")

120+ <*> (v .: "Command")

121+ <*> (v .: "Created")

122+ <*> (v .: "Status")

123+ -- <*> (v .: "Ports")

124+ <*> (v .: "Labels")

125+ -- <*> (v .: "NetworkSettings")

126+

127+

128+

130+

131+instance FromJSON Status

132+instance ToJSON Status

89133

90134type Digest = Text

91135newtype Labels = Labels (M.Map Name Value) deriving (Eq, Show)

@@ -116,7 +160,14 @@ instance FromJSON Image where

116160 fieldLabelModifier = dropImagePrefix}

117161

118162data CreateOpts = CreateOpts

119−data StartOpts = StartOpts

163+

164+-- detachKeys – Override the key sequence for detaching a container.

165+-- Format is a single character [a-Z] or ctrl-<value> where <value> is one of: a-z, @, ^, [, , or _.

166+data DetachKeys = WithCtrl Char | WithoutCtrl Char | DefaultDetachKey deriving (Eq, Show)

167+

168+data StartOpts = StartOpts { detachKeys :: DetachKeys } deriving (Eq, Show)

169+

170+defaultStartOpts = StartOpts { detachKeys = DefaultDetachKey }

120171

121172data DeleteOpts = DeleteOpts {

122173 deleteVolumes :: Bool