@@ -12,7 +12,8 @@ import Control.Lens ((^.), (^?))
1212import Control.Monad.IO.Class
1313import Control.Monad.Trans.Class (lift)
1414import 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)
1617import qualified Data.ByteString as B
1718import qualified Data.ByteString.Char8 as C
1819import qualified Data.ByteString.Lazy as BL
@@ -22,6 +23,7 @@ import qualified Data.Map as M
2223import Data.Maybe (fromJust, isJust)
2324import Data.Monoid
2425import Data.Text (Text, unpack)
26+import qualified Data.Vector as V
2527import Network.Connection (TLSSettings (..))
2628import Network.HTTP.Client (newManager)
2729import Network.HTTP.Client.TLS
@@ -31,113 +33,158 @@ import System.Process (system)
3133import Docker.Client
3234
3335-- opts = defaultClientOpts
34−
3536testImageName = "docker-hs-test"
3637
3738toStrict1 = B.concat . BL.toChunks
3839
39−runDocker f = do
40− -- 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 <- clientParamsSetCA params' "~/.docker/test-ca.pem"
43− -- let settings = mkManagerSettings (TLSSettings params) Nothing
44− -- mgr <- newManager settings
45− h <- defaultHttpHandler
46− runDockerT (defaultClientOpts, h) f
40+runDocker f
41+ -- let opts = defaultClientOpts {baseUrl = "https://127.0.0.1:2376/"}
42+ -- params' <- clientParamsWithClientAuthentication "127.0.0.1" 2376 "~/.docker/test-client-key.pem" "~/.docker/test-client-cert.pem" >>= fromRight
43+ -- params <- clientParamsSetCA params' "~/.docker/test-ca.pem"
44+ -- let settings = mkManagerSettings (TLSSettings params) Nothing
45+ -- mgr <- newManager settings
46+ = do
47+ h <- defaultHttpHandler
48+ runDockerT (defaultClientOpts, h) f
4749
4850testDockerVersion :: IO ()
49−testDockerVersion = runDocker $ do
50− v <- getDockerVersion
51− lift $ assert $ isRight v
51+testDockerVersion =
52+ runDocker $
53+ do v <- getDockerVersion
54+ lift $ assert $ isRight v
5255
5356testFindImage :: IO ()
54−testFindImage = runDocker $ do
55− images <- listImages defaultListOpts >>= fromRight
56− let xs = filter ((== [imageFullName]) . imageRepoTags) images
57− lift $ assert $ length xs == 1
58− where imageFullName = testImageName <> ":latest"
57+testFindImage =
58+ runDocker $
59+ do images <- listImages defaultListOpts >>= fromRight
60+ let xs = filter ((== [imageFullName]) . imageRepoTags) images
61+ lift $ assert $ length xs == 1
62+ where
63+ imageFullName = testImageName <> ":latest"
5964
6065testRunAndReadLog :: IO ()
61−testRunAndReadLog = runDocker $ do
62− containerId <- createContainer (defaultCreateOpts (testImageName <> ":latest")) Nothing
63− c <- fromRight containerId
64− status1 <- startContainer defaultStartOpts c
65− _ <- inspectContainer c >>= fromRight
66− lift $ threadDelay 300000 -- give 300ms for the application to finish
67− lift $ assert $ isRightUnit status1
68− status2 <- killContainer SIGTERM c
69− logs <- getContainerLogs defaultLogOpts c >>= fromRight
70− lift $ assert $ isRightUnit status2
71− lift $ assert $ (C.pack "123") `C.isInfixOf` (toStrict1 logs)
72− status3 <- deleteContainer (DeleteOpts True True) c
73− lift $ assert $ isRightUnit status3
74−
75− where
76− isRightUnit (Right ()) = True
77− isRightUnit _ = False
66+testRunAndReadLog =
67+ runDocker $
68+ do containerId <- createContainer (defaultCreateOpts (testImageName <> ":latest")) Nothing
69+ c <- fromRight containerId
70+ status1 <- startContainer defaultStartOpts c
71+ _ <- inspectContainer c >>= fromRight
72+ lift $ threadDelay 300000 -- give 300ms for the application to finish
73+ lift $ assert $ isRightUnit status1
74+ status2 <- killContainer SIGTERM c
75+ logs <- getContainerLogs defaultLogOpts c >>= fromRight
76+ lift $ assert $ isRightUnit status2
77+ lift $ assert $ (C.pack "123") `C.isInfixOf` (toStrict1 logs)
78+ status3 <- deleteContainer (DeleteOpts True True) c
79+ lift $ assert $ isRightUnit status3
80+ where
81+ isRightUnit (Right ()) = True
82+ isRightUnit _ = False
7883
7984testLogDriverOptionsJson :: TestTree
80−testLogDriverOptionsJson = testGroup "Testing LogDriverOptions JSON" [ test1, test2, test3 ]
81− where
82− 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
84− test3 = testCase "Test override" $ assert $ JSON.toJSON sample2 ^. key key1 . _String == "override"
85− sample = [LogDriverOption key1 val1, LogDriverOption key2 val2]
86− sample2 = [LogDriverOption key1 val1, LogDriverOption key1 "override"]
87− key1 = "some-key"
88− val1 = "some-val"
89− key2 = "some-key2"
90− val2 = "some-key2"
85+testLogDriverOptionsJson = testGroup "Testing LogDriverOptions JSON" [test1, test2, test3]
86+ where
87+ test1 = testCase "Driver option 1" $ assert $ JSON.toJSON sample ^. key key1 . _String == val1
88+ test2 = testCase "Driver option 2" $ assert $ JSON.toJSON sample ^. key key2 . _String == val2
89+ test3 =
90+ testCase "Test override" $ assert $ JSON.toJSON sample2 ^. key key1 . _String == "override"
91+ sample = [LogDriverOption key1 val1, LogDriverOption key2 val2]
92+ sample2 = [LogDriverOption key1 val1, LogDriverOption key1 "override"]
93+ key1 = "some-key"
94+ val1 = "some-val"
95+ key2 = "some-key2"
96+ val2 = "some-key2"
9197
9298testExposedPortsJson :: TestTree
93−testExposedPortsJson = testGroup "Testing ExposedPorts JSON" [ testTCP, testUDP ]
94− where
95− testTCP = testCase "tcp port" $ assert $ JSON.toJSON sampleEP ^. key "80/tcp" . _Object == HM.empty
96− testUDP = testCase "udp port" $ assert $ JSON.toJSON sampleEP ^. key "1337/tcp" . _Object == HM.empty
97− sampleEP = [ExposedPort 80 TCP, ExposedPort 1337 UDP]
99+testExposedPortsJson = testGroup "Testing ExposedPorts JSON" [testTCP, testUDP]
100+ where
101+ testTCP = testCase "tcp port" $ assert $ JSON.toJSON sampleEP ^. key "80/tcp" . _Object == HM.empty
102+ testUDP =
103+ testCase "udp port" $ assert $ JSON.toJSON sampleEP ^. key "1337/tcp" . _Object == HM.empty
104+ sampleEP = [ExposedPort 80 TCP, ExposedPort 1337 UDP]
98105
99106testLabelsJson :: TestTree
100−testLabelsJson = testGroup "Testing Labels JSON" [ testLS1, testLS2, testOverride ]
101− where
102− 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
104− testOverride = testCase "test label override" $ assert $ JSON.toJSON [Label key1 val1, Label key1 "override"] ^. key key1 . _String == "override"
105− sampleLS = [Label key1 val1, Label key2 val2]
106− key1 = "com.example.some-label"
107− val1 = "some-value"
108− key2 = "something"
109− val2 = "value"
107+testLabelsJson = testGroup "Testing Labels JSON" [testLS1, testLS2, testOverride]
108+ where
109+ testLS1 = testCase "test label key1" $ assert $ JSON.toJSON sampleLS ^. key key1 . _String == val1
110+ testLS2 = testCase "test label key2" $ assert $ JSON.toJSON sampleLS ^. key key2 . _String == val2
111+ testOverride =
112+ testCase "test label override" $ assert $ JSON.toJSON [Label key1 val1, Label key1 "override"] ^.
113+ key key1 .
114+ _String ==
115+ "override"
116+ sampleLS = [Label key1 val1, Label key2 val2]
117+ key1 = "com.example.some-label"
118+ val1 = "some-value"
119+ key2 = "something"
120+ val2 = "value"
110121
111122testVolumesJson :: TestTree
112−testVolumesJson = testGroup "Testing Volumes JSON" [ testSample1, testSample2 ]
113− where
114− testSample1 = testCase "Test exposing volume: /tmp" $ assert $ JSON.toJSON sampleVolumes ^. key "/tmp" . _Object == HM.empty
115− testSample2 = testCase "Test exposing volume: /opt" $ assert $ JSON.toJSON sampleVolumes ^. key "/opt" . _Object == HM.empty
116− sampleVolumes = [Volume "/tmp", Volume "/opt"]
123+testVolumesJson = testGroup "Testing Volumes JSON" [testSample1, testSample2]
124+ where
125+ testSample1 =
126+ testCase "Test exposing volume: /tmp" $ assert $ JSON.toJSON sampleVolumes ^. key "/tmp" . _Object ==
127+ HM.empty
128+ testSample2 =
129+ testCase "Test exposing volume: /opt" $ assert $ JSON.toJSON sampleVolumes ^. key "/opt" . _Object ==
130+ HM.empty
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"]
117152
118153integrationTests :: TestTree
119−integrationTests = testGroup "Integration Tests" [
120− testCase "Get docker version" testDockerVersion,
121− testCase "Find image by name" testFindImage,
122− testCase "Run a dummy container and read its log" testRunAndReadLog]
154+integrationTests =
155+ testGroup
156+ "Integration Tests"
157+ [ testCase "Get docker version" testDockerVersion
158+ , testCase "Find image by name" testFindImage
159+ , testCase "Run a dummy container and read its log" testRunAndReadLog
160+ ]
123161
124162jsonTests :: 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+ ]
126172
127173setup :: IO ()
128−setup = system ("docker build -t "++unpack testImageName++" tests") >> return ()
174+setup = system ("docker build -t " ++ unpack testImageName ++ " tests") >> return ()
129175
130−isRight (Left _) = False
176+isRight (Left _) = False
131177isRight (Right _) = True
132178
133−fromRight :: (MonadIO m, Show l) => Either l r -> m r
179+fromRight
180+ :: (MonadIO m, Show l)
181+ => Either l r -> m r
134182fromRight (Left l) = do
135− liftIO $ assertFailure $ "Left: " ++ show l
136− undefined
183+ liftIO $ assertFailure $ "Left: " ++ show l
184+ undefined
137185fromRight (Right r) = return r
138186
139187main :: IO ()
140188main = do
141189 setup
142190 defaultMain $ testGroup "Tests" [jsonTests, integrationTests]
143−