git.iko.soy/docker-hs
on master help sign in
Add Entrypoint data type
8b97334Deni Bertovic
docker.cabal+2
compare with master
unifiedsplit
@@ -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+24−6
@@ -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(..)
@@ -96,13 +97,13 @@ import Data.Aeson (FromJSON, ToJSON, genericParseJSON,
96import qualified Data.Aeson as JSON
97import qualified Data.Aeson as JSON
97import Data.Aeson.Types (defaultOptions, fieldLabelModifier)
98import Data.Aeson.Types (defaultOptions, fieldLabelModifier)
98import Data.Char (isAlphaNum, toUpper)
99import Data.Char (isAlphaNum, toUpper)
99−import Data.Foldable (asum)
100import qualified Data.HashMap.Strict as HM
100import qualified Data.HashMap.Strict as HM
101import Data.Monoid ((<>))
101import Data.Monoid ((<>))
102import Data.Scientific (floatingOrInteger)
102import Data.Scientific (floatingOrInteger)
103import Data.Text (Text)
103import Data.Text (Text)
104import qualified Data.Text as T
104import qualified Data.Text as T
105import Data.Time.Clock (UTCTime)
105import Data.Time.Clock (UTCTime)
106+import qualified Data.Vector as V
106import GHC.Generics (Generic)
107import GHC.Generics (Generic)
107import Prelude hiding (all, tail)
108import Prelude hiding (all, tail)
108import Text.Read (readMaybe)
109import Text.Read (readMaybe)
@@ -644,7 +645,7 @@ defaultContainerConfig imageName = ContainerConfig {
644 , cmd=[]
645 , cmd=[]
645 , volumes=[]
646 , volumes=[]
646 , workingDir=Nothing
647 , workingDir=Nothing
647− , entrypoint=[]
648+ , entrypoint=NoEntrypoint
648 , networkDisabled=Nothing
649 , networkDisabled=Nothing
649 , macAddress=Nothing
650 , macAddress=Nothing
650 , labels=[]
651 , labels=[]
@@ -1387,6 +1388,24 @@ instance {-# OVERLAPPING #-} ToJSON [ExposedPort] where
1387 where key (ExposedPort p t) = show p <> slash <> show t
1388 where key (ExposedPort p t) = show p <> slash <> show t
1388 slash = T.unpack "/"
1389 slash = T.unpack "/"
1389
1390
1391+data Entrypoint = Entrypoint [T.Text] | NoEntrypoint deriving (Eq, Show, Generic)
1392+
1393+instance ToJSON Entrypoint where
1394+ toJSON NoEntrypoint = JSON.Null
1395+ toJSON (Entrypoint (e:es)) = toJSON (e:es)
1396+ toJSON (Entrypoint []) = JSON.Null
1397+
1398+instance FromJSON Entrypoint where
1399+ parseJSON (JSON.String e) = return $ Entrypoint [e]
1400+ parseJSON (JSON.Array ar) = do
1401+ arr <- mapM parseJSON (V.toList ar)
1402+ case arr of
1403+ [] -> return NoEntrypoint
1404+ (e:es) -> return $ Entrypoint (e:es)
1405+ parseJSON JSON.Null = return NoEntrypoint
1406+ parseJSON _ = fail "Failed to parse Entrypoint"
1407+
1408+
1390data ContainerConfig = ContainerConfig {
1409data ContainerConfig = ContainerConfig {
1391 hostname :: Maybe Text
1410 hostname :: Maybe Text
1392 , domainname :: Maybe Text
1411 , domainname :: Maybe Text
@@ -1405,7 +1424,7 @@ data ContainerConfig = ContainerConfig {
1405 , image :: Text
1424 , image :: Text
1406 , volumes :: [Volume]
1425 , volumes :: [Volume]
1407 , workingDir :: Maybe FilePath
1426 , workingDir :: Maybe FilePath
1408− , entrypoint :: [Text]
1427+ , entrypoint :: Entrypoint
1409 , networkDisabled :: Maybe Bool -- Note: Should we expand the JSON instance and take away the Maybe? Null is False?
1428 , networkDisabled :: Maybe Bool -- Note: Should we expand the JSON instance and take away the Maybe? Null is False?
1410 , macAddress :: Maybe Text
1429 , macAddress :: Maybe Text
1411 -- , onBuild :: Maybe Text -- For 1.24, only see this in the inspect response.
1430 -- , onBuild :: Maybe Text -- For 1.24, only see this in the inspect response.
@@ -1413,6 +1432,7 @@ data ContainerConfig = ContainerConfig {
1413 , stopSignal :: Signal
1432 , stopSignal :: Signal
1414 } deriving (Eq, Show, Generic)
1433 } deriving (Eq, Show, Generic)
1415
1434
1435+
1416instance ToJSON ContainerConfig where
1436instance ToJSON ContainerConfig where
1417 toJSON = genericToJSON defaultOptions {
1437 toJSON = genericToJSON defaultOptions {
1418 fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
1438 fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
@@ -1434,9 +1454,7 @@ instance FromJSON ContainerConfig where
1434 image <- o .: "Image"
1454 image <- o .: "Image"
1435 volumes <- o .: "Volumes"
1455 volumes <- o .: "Volumes"
1436 workingDir <- o .:? "WorkingDir"
1456 workingDir <- o .:? "WorkingDir"
1437− entrypoint <- asum [ o .:? "Entrypoint" .!= []
1438− , (:[]) <$> o .: "Entrypoint"
1457+ entrypoint <- o .: "Entrypoint"
1439− ]
1440 networkDisabled <- o .:? "networkDisabled"
1458 networkDisabled <- o .:? "networkDisabled"
1441 macAddress <- o .:? "MacAddress"
1459 macAddress <- o .:? "MacAddress"
1442 labels <- o .:? "Labels" .!= []
1460 labels <- o .:? "Labels" .!= []
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 NoEntrypoint ^. _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 NoEntrypoint
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−