git.iko.soy/docker-hs
on master help sign in
Adds more endpoints
f5f0395Deni Bertovic
src/Docker.hs+71−9
compare with master
unifiedsplit
@@ -23,34 +23,96 @@ getDockerVersion = do
23 return $ fromJust res
23 return $ fromJust res
24
24
25listContainers :: ListOpts -> DockerT IO ([Container])
25listContainers :: 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+
27
34
28listImages :: ListOpts -> DockerT IO ([Image])
35listImages :: 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+
30
44
31createContainer :: CreateOpts -> DockerT IO (ContainerID)
45createContainer :: CreateOpts -> DockerT IO (ContainerID)
32createContainer = undefined
46createContainer = undefined
33
47
34startContainer :: StartOpts -> ContainerID -> DockerT IO (ContainerID)
48startContainer :: 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+
36
57
37stopContainer :: Timeout -> ContainerID ->DockerT IO ()
58stopContainer :: 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+
39
67
40killContainer :: Signal -> ContainerID -> DockerT IO ()
68killContainer :: 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+
42
77
43restartContainer :: Timeout -> ContainerID -> DockerT IO ()
78restartContainer :: 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+
45
87
46pauseContainer :: ContainerID -> DockerT IO ()
88pauseContainer :: 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+
48
97
49unpauseContainer :: ContainerID -> DockerT IO ()
98unpauseContainer :: 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+
51
107
52deleteContainer :: DeleteOpts -> ContainerID -> DockerT IO ()
108deleteContainer :: 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
54
116
55getContainerLogs :: LogOpts -> ContainerID -> DockerT IO ()
117getContainerLogs :: LogOpts -> ContainerID -> DockerT IO ()
56getContainerLogs = undefined
118getContainerLogs = undefined
src/Docker/Internal.hs+23−8
@@ -42,23 +42,38 @@ encodeURL ps = decodeUtf8 $ toByteString $ encodePathSegments ps
42encodeURLWithQuery :: [Text] -> Query -> Text
42encodeURLWithQuery :: [Text] -> Query -> Text
43encodeURLWithQuery ps q = decodeUtf8 $ toByteString $ encodePath ps q
43encodeURLWithQuery ps q = decodeUtf8 $ toByteString $ encodePath ps q
44
44
45−encodeQ = encodeUtf8 . T.pack . show
45+encodeQ = encodeUtf8 . T.pack
46
46
47getEndpoint :: Endpoint -> Text
47getEndpoint :: Endpoint -> Text
48getEndpoint VersionEndpoint = encodeURL ["version"]
48getEndpoint VersionEndpoint = encodeURL ["version"]
49getEndpoint (ListContainersEndpoint lsOpts) = encodeURL ["containers", "json"]
49getEndpoint (ListContainersEndpoint lsOpts) = encodeURL ["containers", "json"]
50getEndpoint (ListImagesEndpoint lsOpts) = encodeURL ["images", "json"]
50getEndpoint (ListImagesEndpoint lsOpts) = encodeURL ["images", "json"]
51getEndpoint CreateContainerEndpoint = encodeURL ["containers", "create"]
51getEndpoint CreateContainerEndpoint = encodeURL ["containers", "create"]
52−getEndpoint (StartContainerEndpoint cid) = encodeURL ["containers", cid, "start"]
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', '-']
53−getEndpoint (StopContainerEndpoint cid) = encodeURL ["containers", cid, "stop"]
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 -> []
54−getEndpoint (KillContainerEndpoint cid) = encodeURL ["containers", cid, "kill"]
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))]
55−getEndpoint (RestartContainerEndpoint cid) = encodeURL ["containers", cid, "restart"]
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+
56getEndpoint (PauseContainerEndpoint cid) = encodeURL ["containers", cid, "pause"]
71getEndpoint (PauseContainerEndpoint cid) = encodeURL ["containers", cid, "pause"]
57getEndpoint (UnpauseContainerEndpoint cid) = encodeURL ["containers", cid, "unpause"]
72getEndpoint (UnpauseContainerEndpoint cid) = encodeURL ["containers", cid, "unpause"]
58getEndpoint (ContainerLogsEndpoint cid (LogOpts follow stdout stderr since timestamps tail)) =
73getEndpoint (ContainerLogsEndpoint cid (LogOpts follow stdout stderr since timestamps tail)) =
59 encodeURLWithQuery ["containers", cid, "logs"] query
74 encodeURLWithQuery ["containers", cid, "logs"] query
60− where query = [("stdout", Just (encodeQ stdout)), ("stderr", Just (encodeQ stderr)), ("follow", Just (encodeQ follow))]
75+ where query = [("stdout", Just (encodeQ $ show stdout)), ("stderr", Just (encodeQ $ show stderr)), ("follow", Just (encodeQ $ show follow))]
61−getEndpoint (DeleteContainerEndpoint cid (DeleteOpts removeVolumes force)) =
76+getEndpoint (DeleteContainerEndpoint (DeleteOpts removeVolumes force) cid) =
62 encodeURLWithQuery ["containers", cid] query
77 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))]
64
79
src/Docker/Types.hs+60−9
@@ -16,6 +16,7 @@ import qualified Data.Text as T
16import GHC.Generics (Generic)
16import GHC.Generics (Generic)
17import qualified Network.HTTP.Client as HTTP
17import qualified Network.HTTP.Client as HTTP
18import Network.HTTP.Types (StdMethod)
18import Network.HTTP.Types (StdMethod)
19+import Prelude hiding (all)
19
20
20type HttpVerb = StdMethod
21type HttpVerb = StdMethod
21
22
@@ -24,25 +25,33 @@ data Endpoint =
24 | ListContainersEndpoint ListOpts
25 | ListContainersEndpoint ListOpts
25 | ListImagesEndpoint ListOpts
26 | ListImagesEndpoint ListOpts
26 | CreateContainerEndpoint
27 | CreateContainerEndpoint
27− | StartContainerEndpoint ContainerID
28+ | StartContainerEndpoint StartOpts ContainerID
28− | StopContainerEndpoint ContainerID
29+ | StopContainerEndpoint Timeout ContainerID
29− | KillContainerEndpoint ContainerID
30+ | KillContainerEndpoint Signal ContainerID
30− | RestartContainerEndpoint ContainerID
31+ | RestartContainerEndpoint Timeout ContainerID
31− | PauseContainerEndpoint ContainerName
32+ | PauseContainerEndpoint ContainerID
32 | UnpauseContainerEndpoint ContainerID
33 | UnpauseContainerEndpoint ContainerID
33 | ContainerLogsEndpoint ContainerID LogOpts
34 | ContainerLogsEndpoint ContainerID LogOpts
34− | DeleteContainerEndpoint ContainerID DeleteOpts
35+ | DeleteContainerEndpoint DeleteOpts ContainerID
35
36
36type URL = Text
37type URL = Text
37type ApiVersion = Text
38type ApiVersion = Text
38type ContainerID = Text
39type ContainerID = Text
39type ImageID = Text
40type ImageID = Text
40−type Timeout = Integer
41+
42+data Timeout = Timeout Integer | DefaultTimeout deriving (Eq, Show)
41
43
42type Request = HTTP.Request
44type Request = HTTP.Request
43type Response = HTTP.Response BL.ByteString
45type Response = HTTP.Response BL.ByteString
44
46
47+data Signal = SIGHUP
48+ | SIGINT
49+ | SIGQUIT
50+ | SIGSTOP
51+ | SIGTERM
52+ | SIGUSR1
53+ | SIG Integer
45−data Signal = SIGINT | SIGKILL deriving (Eq, Show)
54+ | SIGKILL deriving (Eq, Show)
46
55
47data DockerClientOpts = DockerClientOpts {
56data DockerClientOpts = DockerClientOpts {
48 apiVer :: ApiVersion
57 apiVer :: ApiVersion
@@ -59,6 +68,8 @@ runDockerT (opts, h) r = runExceptT $ runReaderT r (opts, h)
59
68
60data ListOpts = ListOpts { all :: Bool } deriving (Eq, Show)
69data ListOpts = ListOpts { all :: Bool } deriving (Eq, Show)
61
70
71+defaultListOpts = ListOpts { all=False }
72+
62defaultClientOpts :: DockerClientOpts
73defaultClientOpts :: DockerClientOpts
63defaultClientOpts = DockerClientOpts {
74defaultClientOpts = DockerClientOpts {
64 apiVer = "v1.22"
75 apiVer = "v1.22"
@@ -85,7 +96,40 @@ instance FromJSON DockerVersion where
85 parseJSON = genericParseJSON defaultOptions {
96 parseJSON = genericParseJSON defaultOptions {
86 fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
97 fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
87
98
99+-- TODO: Add NetworkSettings
100+-- TODO: Add PortBindings
88data Container = Container
101data 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+
129+data Status = Created | Restarting | Running | Paused | Exited | Dead deriving (Eq, Show, Generic)
130+
131+instance FromJSON Status
132+instance ToJSON Status
89
133
90type Digest = Text
134type Digest = Text
91newtype Labels = Labels (M.Map Name Value) deriving (Eq, Show)
135newtype Labels = Labels (M.Map Name Value) deriving (Eq, Show)
@@ -116,7 +160,14 @@ instance FromJSON Image where
116 fieldLabelModifier = dropImagePrefix}
160 fieldLabelModifier = dropImagePrefix}
117
161
118data CreateOpts = CreateOpts
162data CreateOpts = CreateOpts
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+
119−data StartOpts = StartOpts
168+data StartOpts = StartOpts { detachKeys :: DetachKeys } deriving (Eq, Show)
169+
170+defaultStartOpts = StartOpts { detachKeys = DefaultDetachKey }
120
171
121data DeleteOpts = DeleteOpts {
172data DeleteOpts = DeleteOpts {
122 deleteVolumes :: Bool
173 deleteVolumes :: Bool