git.iko.soy/docker-hs
on master help sign in
Merge pull request #29 from denibertovic/entrypoint
734b9bdDeni Bertovic
.gitignore+1
compare with master
unifiedsplit
@@ -4,3 +4,4 @@
4*~
4*~
5.stack-work/
5.stack-work/
6dist-newstyle
6dist-newstyle
7+/cabal.project.local
docker.cabal+2
@@ -27,6 +27,7 @@ library
27 , data-default-class >= 0.0.1 && < 0.2.0
27 , data-default-class >= 0.0.1 && < 0.2.0
28 , http-client >= 0.4.0 && < 0.5.0
28 , http-client >= 0.4.0 && < 0.5.0
29 , http-types >= 0.9 && < 0.10.0
29 , http-types >= 0.9 && < 0.10.0
30+ , vector
30 , conduit
31 , conduit
31 , conduit-combinators
32 , conduit-combinators
32 , conduit-extra
33 , conduit-extra
@@ -76,6 +77,7 @@ test-suite docker-hs-tests
76 , transformers
77 , transformers
77 , QuickCheck
78 , QuickCheck
78 , process
79 , process
80+ , vector
79 type: exitcode-stdio-1.0
81 type: exitcode-stdio-1.0
80 main-is: tests.hs
82 main-is: tests.hs
81 hs-source-dirs: tests
83 hs-source-dirs: tests
src/Docker/Client/Types.hs+21−4
@@ -28,6 +28,7 @@ module Docker.Client.Types (
28 , Label(..)
28 , Label(..)
29 , Tag
29 , Tag
30 , Image(..)
30 , Image(..)
31+ , Entrypoint(..)
31 , dropImagePrefix
32 , dropImagePrefix
32 , CreateOpts(..)
33 , CreateOpts(..)
33 , BuildOpts(..)
34 , BuildOpts(..)
@@ -102,6 +103,7 @@ import Data.Scientific (floatingOrInteger)
102import Data.Text (Text)
103import Data.Text (Text)
103import qualified Data.Text as T
104import qualified Data.Text as T
104import Data.Time.Clock (UTCTime)
105import Data.Time.Clock (UTCTime)
106+import qualified Data.Vector as V
105import GHC.Generics (Generic)
107import GHC.Generics (Generic)
106import Prelude hiding (all, tail)
108import Prelude hiding (all, tail)
107import Text.Read (readMaybe)
109import Text.Read (readMaybe)
@@ -643,7 +645,7 @@ defaultContainerConfig imageName = ContainerConfig {
643 , cmd=[]
645 , cmd=[]
644 , volumes=[]
646 , volumes=[]
645 , workingDir=Nothing
647 , workingDir=Nothing
646− , entrypoint=Nothing
648+ , entrypoint=Entrypoint []
647 , networkDisabled=Nothing
649 , networkDisabled=Nothing
648 , macAddress=Nothing
650 , macAddress=Nothing
649 , labels=[]
651 , labels=[]
@@ -1386,6 +1388,21 @@ instance {-# OVERLAPPING #-} ToJSON [ExposedPort] where
1386 where key (ExposedPort p t) = show p <> slash <> show t
1388 where key (ExposedPort p t) = show p <> slash <> show t
1387 slash = T.unpack "/"
1389 slash = T.unpack "/"
1388
1390
1391+data Entrypoint = Entrypoint [T.Text] deriving (Eq, Show, Generic)
1392+
1393+instance ToJSON Entrypoint where
1394+ toJSON (Entrypoint (e:es)) = toJSON (e:es)
1395+ toJSON (Entrypoint []) = JSON.Null
1396+
1397+instance FromJSON Entrypoint where
1398+ parseJSON (JSON.String e) = return $ Entrypoint [e]
1399+ parseJSON (JSON.Array ar) = do
1400+ arr <- mapM parseJSON (V.toList ar)
1401+ return $ Entrypoint arr
1402+ parseJSON JSON.Null = return $ Entrypoint []
1403+ parseJSON _ = fail "Failed to parse Entrypoint"
1404+
1405+
1389data ContainerConfig = ContainerConfig {
1406data ContainerConfig = ContainerConfig {
1390 hostname :: Maybe Text
1407 hostname :: Maybe Text
1391 , domainname :: Maybe Text
1408 , domainname :: Maybe Text
@@ -1404,7 +1421,7 @@ data ContainerConfig = ContainerConfig {
1404 , image :: Text
1421 , image :: Text
1405 , volumes :: [Volume]
1422 , volumes :: [Volume]
1406 , workingDir :: Maybe FilePath
1423 , workingDir :: Maybe FilePath
1407− , entrypoint :: Maybe Text -- Can be null?
1424+ , entrypoint :: Entrypoint
1408 , networkDisabled :: Maybe Bool -- Note: Should we expand the JSON instance and take away the Maybe? Null is False?
1425 , networkDisabled :: Maybe Bool -- Note: Should we expand the JSON instance and take away the Maybe? Null is False?
1409 , macAddress :: Maybe Text
1426 , macAddress :: Maybe Text
1410 -- , onBuild :: Maybe Text -- For 1.24, only see this in the inspect response.
1427 -- , onBuild :: Maybe Text -- For 1.24, only see this in the inspect response.
@@ -1412,6 +1429,7 @@ data ContainerConfig = ContainerConfig {
1412 , stopSignal :: Signal
1429 , stopSignal :: Signal
1413 } deriving (Eq, Show, Generic)
1430 } deriving (Eq, Show, Generic)
1414
1431
1432+
1415instance ToJSON ContainerConfig where
1433instance ToJSON ContainerConfig where
1416 toJSON = genericToJSON defaultOptions {
1434 toJSON = genericToJSON defaultOptions {
1417 fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
1435 fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
@@ -1433,7 +1451,7 @@ instance FromJSON ContainerConfig where
1433 image <- o .: "Image"
1451 image <- o .: "Image"
1434 volumes <- o .: "Volumes"
1452 volumes <- o .: "Volumes"
1435 workingDir <- o .:? "WorkingDir"
1453 workingDir <- o .:? "WorkingDir"
1436− entrypoint <- o .:? "Entrypoint"
1454+ entrypoint <- o .: "Entrypoint"
1437 networkDisabled <- o .:? "networkDisabled"
1455 networkDisabled <- o .:? "networkDisabled"
1438 macAddress <- o .:? "MacAddress"
1456 macAddress <- o .:? "MacAddress"
1439 labels <- o .:? "Labels" .!= []
1457 labels <- o .:? "Labels" .!= []
@@ -1464,4 +1482,3 @@ toJsonKeyVal vs getKey getVal = JSON.Object $ foldl f HM.empty vs
1464-- | Helper function that return an empty dictionary "{}"
1482-- | Helper function that return an empty dictionary "{}"
1465emptyJsonObject :: JSON.Value
1483emptyJsonObject :: JSON.Value
1466emptyJsonObject = JSON.Object HM.empty
1484emptyJsonObject = JSON.Object HM.empty
1467−
tests/tests.hs+124−77
@@ -12,7 +12,8 @@ import Control.Lens ((^.), (^?))
12import Control.Monad.IO.Class
12import Control.Monad.IO.Class
13import Control.Monad.Trans.Class (lift)
13import Control.Monad.Trans.Class (lift)
14import qualified Data.Aeson as JSON
14import qualified Data.Aeson as JSON
15−import Data.Aeson.Lens (key, _Object, _String, _Value)
15+import Data.Aeson.Lens (key, _Array, _Null, _Object,
16+ _String, _Value)
16import qualified Data.ByteString as B
17import qualified Data.ByteString as B
17import qualified Data.ByteString.Char8 as C
18import qualified Data.ByteString.Char8 as C
18import qualified Data.ByteString.Lazy as BL
19import qualified Data.ByteString.Lazy as BL
@@ -22,6 +23,7 @@ import qualified Data.Map as M
22import Data.Maybe (fromJust, isJust)
23import Data.Maybe (fromJust, isJust)
23import Data.Monoid
24import Data.Monoid
24import Data.Text (Text, unpack)
25import Data.Text (Text, unpack)
26+import qualified Data.Vector as V
25import Network.Connection (TLSSettings (..))
27import Network.Connection (TLSSettings (..))
26import Network.HTTP.Client (newManager)
28import Network.HTTP.Client (newManager)
27import Network.HTTP.Client.TLS
29import Network.HTTP.Client.TLS
@@ -31,113 +33,158 @@ import System.Process (system)
31import Docker.Client
33import Docker.Client
32
34
33-- opts = defaultClientOpts
35-- opts = defaultClientOpts
34−
35testImageName = "docker-hs-test"
36testImageName = "docker-hs-test"
36
37
37toStrict1 = B.concat . BL.toChunks
38toStrict1 = B.concat . BL.toChunks
38
39
39−runDocker f = do
40+runDocker f
40− -- let opts = defaultClientOpts {baseUrl = "https://127.0.0.1:2376/"}
41+ -- let opts = defaultClientOpts {baseUrl = "https://127.0.0.1:2376/"}
41− -- params' <- clientParamsWithClientAuthentication "127.0.0.1" 2376 "~/.docker/test-client-key.pem" "~/.docker/test-client-cert.pem" >>= fromRight
42+ -- params' <- clientParamsWithClientAuthentication "127.0.0.1" 2376 "~/.docker/test-client-key.pem" "~/.docker/test-client-cert.pem" >>= fromRight
42− -- params <- clientParamsSetCA params' "~/.docker/test-ca.pem"
43+ -- params <- clientParamsSetCA params' "~/.docker/test-ca.pem"
43− -- let settings = mkManagerSettings (TLSSettings params) Nothing
44+ -- let settings = mkManagerSettings (TLSSettings params) Nothing
44− -- mgr <- newManager settings
45+ -- mgr <- newManager settings
46+ = do
45− h <- defaultHttpHandler
47+ h <- defaultHttpHandler
46− runDockerT (defaultClientOpts, h) f
48+ runDockerT (defaultClientOpts, h) f
47
49
48testDockerVersion :: IO ()
50testDockerVersion :: IO ()
49−testDockerVersion = runDocker $ do
51+testDockerVersion =
52+ runDocker $
50− v <- getDockerVersion
53+ do v <- getDockerVersion
51− lift $ assert $ isRight v
54+ lift $ assert $ isRight v
52
55
53testFindImage :: IO ()
56testFindImage :: IO ()
54−testFindImage = runDocker $ do
57+testFindImage =
58+ runDocker $
55− images <- listImages defaultListOpts >>= fromRight
59+ do images <- listImages defaultListOpts >>= fromRight
56− let xs = filter ((== [imageFullName]) . imageRepoTags) images
60+ let xs = filter ((== [imageFullName]) . imageRepoTags) images
57− lift $ assert $ length xs == 1
61+ lift $ assert $ length xs == 1
62+ where
58− where imageFullName = testImageName <> ":latest"
63+ imageFullName = testImageName <> ":latest"
59
64
60testRunAndReadLog :: IO ()
65testRunAndReadLog :: IO ()
61−testRunAndReadLog = runDocker $ do
66+testRunAndReadLog =
67+ runDocker $
62− containerId <- createContainer (defaultCreateOpts (testImageName <> ":latest")) Nothing
68+ do containerId <- createContainer (defaultCreateOpts (testImageName <> ":latest")) Nothing
63− c <- fromRight containerId
69+ c <- fromRight containerId
64− status1 <- startContainer defaultStartOpts c
70+ status1 <- startContainer defaultStartOpts c
65− _ <- inspectContainer c >>= fromRight
71+ _ <- inspectContainer c >>= fromRight
66− lift $ threadDelay 300000 -- give 300ms for the application to finish
72+ lift $ threadDelay 300000 -- give 300ms for the application to finish
67− lift $ assert $ isRightUnit status1
73+ lift $ assert $ isRightUnit status1
68− status2 <- killContainer SIGTERM c
74+ status2 <- killContainer SIGTERM c
69− logs <- getContainerLogs defaultLogOpts c >>= fromRight
75+ logs <- getContainerLogs defaultLogOpts c >>= fromRight
70− lift $ assert $ isRightUnit status2
76+ lift $ assert $ isRightUnit status2
71− lift $ assert $ (C.pack "123") `C.isInfixOf` (toStrict1 logs)
77+ lift $ assert $ (C.pack "123") `C.isInfixOf` (toStrict1 logs)
72− status3 <- deleteContainer (DeleteOpts True True) c
78+ status3 <- deleteContainer (DeleteOpts True True) c
73− lift $ assert $ isRightUnit status3
79+ lift $ assert $ isRightUnit status3
74−
75− where
80+ where
76− isRightUnit (Right ()) = True
81+ isRightUnit (Right ()) = True
77− isRightUnit _ = False
82+ isRightUnit _ = False
78
83
79testLogDriverOptionsJson :: TestTree
84testLogDriverOptionsJson :: TestTree
80−testLogDriverOptionsJson = testGroup "Testing LogDriverOptions JSON" [ test1, test2, test3 ]
85+testLogDriverOptionsJson = testGroup "Testing LogDriverOptions JSON" [test1, test2, test3]
81− where
86+ where
82− test1 = testCase "Driver option 1" $ assert $ JSON.toJSON sample ^. key key1 . _String == val1
87+ test1 = testCase "Driver option 1" $ assert $ JSON.toJSON sample ^. key key1 . _String == val1
83− test2 = testCase "Driver option 2" $ assert $ JSON.toJSON sample ^. key key2 . _String == val2
88+ test2 = testCase "Driver option 2" $ assert $ JSON.toJSON sample ^. key key2 . _String == val2
89+ test3 =
84− test3 = testCase "Test override" $ assert $ JSON.toJSON sample2 ^. key key1 . _String == "override"
90+ testCase "Test override" $ assert $ JSON.toJSON sample2 ^. key key1 . _String == "override"
85− sample = [LogDriverOption key1 val1, LogDriverOption key2 val2]
91+ sample = [LogDriverOption key1 val1, LogDriverOption key2 val2]
86− sample2 = [LogDriverOption key1 val1, LogDriverOption key1 "override"]
92+ sample2 = [LogDriverOption key1 val1, LogDriverOption key1 "override"]
87− key1 = "some-key"
93+ key1 = "some-key"
88− val1 = "some-val"
94+ val1 = "some-val"
89− key2 = "some-key2"
95+ key2 = "some-key2"
90− val2 = "some-key2"
96+ val2 = "some-key2"
91
97
92testExposedPortsJson :: TestTree
98testExposedPortsJson :: TestTree
93−testExposedPortsJson = testGroup "Testing ExposedPorts JSON" [ testTCP, testUDP ]
99+testExposedPortsJson = testGroup "Testing ExposedPorts JSON" [testTCP, testUDP]
94− where
100+ where
95− testTCP = testCase "tcp port" $ assert $ JSON.toJSON sampleEP ^. key "80/tcp" . _Object == HM.empty
101+ testTCP = testCase "tcp port" $ assert $ JSON.toJSON sampleEP ^. key "80/tcp" . _Object == HM.empty
102+ testUDP =
96− testUDP = testCase "udp port" $ assert $ JSON.toJSON sampleEP ^. key "1337/tcp" . _Object == HM.empty
103+ testCase "udp port" $ assert $ JSON.toJSON sampleEP ^. key "1337/tcp" . _Object == HM.empty
97− sampleEP = [ExposedPort 80 TCP, ExposedPort 1337 UDP]
104+ sampleEP = [ExposedPort 80 TCP, ExposedPort 1337 UDP]
98
105
99testLabelsJson :: TestTree
106testLabelsJson :: TestTree
100−testLabelsJson = testGroup "Testing Labels JSON" [ testLS1, testLS2, testOverride ]
107+testLabelsJson = testGroup "Testing Labels JSON" [testLS1, testLS2, testOverride]
101− where
108+ where
102− testLS1 = testCase "test label key1" $ assert $ JSON.toJSON sampleLS ^. key key1 . _String == val1
109+ testLS1 = testCase "test label key1" $ assert $ JSON.toJSON sampleLS ^. key key1 . _String == val1
103− testLS2 = testCase "test label key2" $ assert $ JSON.toJSON sampleLS ^. key key2 . _String == val2
110+ testLS2 = testCase "test label key2" $ assert $ JSON.toJSON sampleLS ^. key key2 . _String == val2
111+ testOverride =
104− testOverride = testCase "test label override" $ assert $ JSON.toJSON [Label key1 val1, Label key1 "override"] ^. key key1 . _String == "override"
112+ testCase "test label override" $ assert $ JSON.toJSON [Label key1 val1, Label key1 "override"] ^.
113+ key key1 .
114+ _String ==
115+ "override"
105− sampleLS = [Label key1 val1, Label key2 val2]
116+ sampleLS = [Label key1 val1, Label key2 val2]
106− key1 = "com.example.some-label"
117+ key1 = "com.example.some-label"
107− val1 = "some-value"
118+ val1 = "some-value"
108− key2 = "something"
119+ key2 = "something"
109− val2 = "value"
120+ val2 = "value"
110
121
111testVolumesJson :: TestTree
122testVolumesJson :: TestTree
112−testVolumesJson = testGroup "Testing Volumes JSON" [ testSample1, testSample2 ]
123+testVolumesJson = testGroup "Testing Volumes JSON" [testSample1, testSample2]
113− where
124+ where
125+ testSample1 =
114− testSample1 = testCase "Test exposing volume: /tmp" $ assert $ JSON.toJSON sampleVolumes ^. key "/tmp" . _Object == HM.empty
126+ testCase "Test exposing volume: /tmp" $ assert $ JSON.toJSON sampleVolumes ^. key "/tmp" . _Object ==
127+ HM.empty
128+ testSample2 =
115− testSample2 = testCase "Test exposing volume: /opt" $ assert $ JSON.toJSON sampleVolumes ^. key "/opt" . _Object == HM.empty
129+ testCase "Test exposing volume: /opt" $ assert $ JSON.toJSON sampleVolumes ^. key "/opt" . _Object ==
130+ HM.empty
116− sampleVolumes = [Volume "/tmp", Volume "/opt"]
131+ sampleVolumes = [Volume "/tmp", Volume "/opt"]
132+
133+testEntrypointJson :: TestTree
134+testEntrypointJson = testGroup "Testing ContainerConfig JSON" [testSample1, testSample2, testSample3, testSample4, testSample5]
135+ where
136+ testSample1 =
137+ testCase "Test toJSON with empty entrypoint (null)" $ assert $ JSON.toJSON (Entrypoint []) ^. _Null == ()
138+ testSample2 =
139+ testCase "Test toJSON with entrypoint as Array" $ assert $
140+ JSON.toJSON (Entrypoint sampleEntrypointArr) ==
141+ JSON.toJSON sampleEntrypointArr
142+ testSample3 =
143+ testCase "Test decoding entrypoint as string" $ assert $ (JSON.decode "\"cmd\"") ==
144+ Just (Entrypoint ["cmd"])
145+ testSample4 =
146+ testCase "Test decoding as null" $ assert $ (JSON.decode "null" :: Maybe Entrypoint) ==
147+ Just (Entrypoint [])
148+ testSample5 =
149+ testCase "Test decoding as array" $ assert $ (JSON.decode (JSON.encode sampleEntrypointArr) :: Maybe Entrypoint) ==
150+ Just (Entrypoint sampleEntrypointArr)
151+ sampleEntrypointArr = ["cmd", "--some-flag", "--some-flag2"]
117
152
118integrationTests :: TestTree
153integrationTests :: TestTree
119−integrationTests = testGroup "Integration Tests" [
154+integrationTests =
155+ testGroup
156+ "Integration Tests"
120− testCase "Get docker version" testDockerVersion,
157+ [ testCase "Get docker version" testDockerVersion
121− testCase "Find image by name" testFindImage,
158+ , testCase "Find image by name" testFindImage
122− testCase "Run a dummy container and read its log" testRunAndReadLog]
159+ , testCase "Run a dummy container and read its log" testRunAndReadLog
160+ ]
123
161
124jsonTests :: TestTree
162jsonTests :: TestTree
125−jsonTests = testGroup "JSON Tests" [testExposedPortsJson, testVolumesJson, testLabelsJson, testLogDriverOptionsJson]
163+jsonTests =
164+ testGroup
165+ "JSON Tests"
166+ [ testExposedPortsJson
167+ , testVolumesJson
168+ , testLabelsJson
169+ , testLogDriverOptionsJson
170+ , testEntrypointJson
171+ ]
126
172
127setup :: IO ()
173setup :: IO ()
128−setup = system ("docker build -t "++unpack testImageName++" tests") >> return ()
174+setup = system ("docker build -t " ++ unpack testImageName ++ " tests") >> return ()
129
175
130−isRight (Left _) = False
176+isRight (Left _) = False
131isRight (Right _) = True
177isRight (Right _) = True
132
178
179+fromRight
133−fromRight :: (MonadIO m, Show l) => Either l r -> m r
180+ :: (MonadIO m, Show l)
181+ => Either l r -> m r
134fromRight (Left l) = do
182fromRight (Left l) = do
135− liftIO $ assertFailure $ "Left: " ++ show l
183+ liftIO $ assertFailure $ "Left: " ++ show l
136− undefined
184+ undefined
137fromRight (Right r) = return r
185fromRight (Right r) = return r
138
186
139main :: IO ()
187main :: IO ()
140main = do
188main = do
141 setup
189 setup
142 defaultMain $ testGroup "Tests" [jsonTests, integrationTests]
190 defaultMain $ testGroup "Tests" [jsonTests, integrationTests]
143−