docker-0.7.0.0: tests/tests.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Data.Either (rights)
import Data.String (IsString(..))
import Prelude hiding (all)
import qualified Test.QuickCheck.Monadic as QCM
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck (testProperty)
import Control.Concurrent (threadDelay)
import Control.Lens ((^.), (^?))
import Control.Monad (forM_)
import Control.Monad.IO.Class
import Control.Monad.Trans.Class (lift)
import qualified Data.Aeson as JSON
import Data.Aeson ((.=))
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.KeyMap as KM
#endif
import Data.Aeson.Lens (key, _Array, _Null, _Object,
_String, _Value)
import qualified Data.Aeson.Types as JSON
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString.Lazy as BL
import qualified Data.HashMap.Strict as HM
import Data.Int (Int)
import qualified Data.Map as M
import Data.Maybe (fromJust, isJust, isNothing, listToMaybe)
import Data.Monoid
import Data.Text (Text, unpack)
import qualified Data.Vector as V
import Network.Connection (TLSSettings (..))
import Network.HTTP.Client (newManager)
import Network.HTTP.Client.TLS
import Network.HTTP.Types.Status
import System.Directory (getCurrentDirectory)
import System.Environment (lookupEnv)
import System.Process (system)
import Docker.Client
#if MIN_VERSION_lens_aeson(1,2,0)
emptyMap :: KM.KeyMap v
emptyMap = KM.empty
#else
emptyMap :: HM.HashMap k v
emptyMap = HM.empty
#endif
-- opts = defaultClientOpts
testImageName = "docker-hs/test"
imageToDeleteFullName = "hello-world:latest"
toStrict1 = B.concat . BL.toChunks
runDocker f
-- let opts = defaultClientOpts {baseUrl = "https://127.0.0.1:2376/"}
-- params' <- clientParamsWithClientAuthentication "127.0.0.1" 2376 "~/.docker/test-client-key.pem" "~/.docker/test-client-cert.pem" >>= fromRight
-- params <- clientParamsSetCA params' "~/.docker/test-ca.pem"
-- let settings = mkManagerSettings (TLSSettings params) Nothing
-- mgr <- newManager settings
= do
h <- unixHttpHandler "/var/run/docker.sock"
runDockerT (defaultClientOpts, h) f
testDockerVersion :: IO ()
testDockerVersion =
runDocker $
do v <- getDockerVersion
lift $ assert $ isRight v
testStopNonexisting :: IO ()
testStopNonexisting = runDocker $ do
res <- stopContainer DefaultTimeout $ fromJust $ toContainerID "thisshouldnotexist"
lift $ assert $ isLeft res
testFindImage :: IO ()
testFindImage =
runDocker $
do images <- listImages defaultListOpts >>= fromRight
let xs = filter (elem imageFullName . imageRepoTags) images
lift $ assert $ length xs == 1
where
imageFullName = testImageName <> ":latest"
testDeleteImage :: IO ()
testDeleteImage = runDocker $ do
img <- fmap fromJust findTestImage
result <- deleteImage defaultImageDeleteOpts (imageId img)
lift $ assert $ isRight result
maybeTestImageAfter <- findTestImage
lift $ assert $ isNothing maybeTestImageAfter
where
findTestImage =
do
images <- listImages defaultListOpts >>= fromRight
return $ listToMaybe
$ filter (elem imageToDeleteFullName . imageRepoTags) images
testListContainers :: IO ()
testListContainers =
runDocker $
do containerId <- createContainer (defaultCreateOpts (testImageName <> ":latest")) Nothing
c <- fromRight containerId
res <- listContainers $ ListOpts { all=True }
deleteContainer (ContainerDeleteOpts True True) c
lift $ assert $ isRight res
testBuildFromDockerfile :: IO ()
testBuildFromDockerfile = do
cur <- getCurrentDirectory
let ctxDir = cur ++ "/tests"
runDocker $ do
r <- buildImageFromDockerfile (defaultBuildOpts "docker-hs/dockerfile-test") ctxDir
lift $ assert $ isRight r
testRunAndReadLog :: IO ()
testRunAndReadLog = testRunAndReadLogHelper $ NetworkingConfig HM.empty
testRunAndReadLogWithNetworking :: IO ()
testRunAndReadLogWithNetworking = testRunAndReadLogHelper $ NetworkingConfig $ HM.fromList [("test-network", EndpointConfig ["cellar-door"])]
testRunAndReadLogHelper :: NetworkingConfig -> IO ()
testRunAndReadLogHelper networkingConfig =
runDocker $
do let containerConfig = (defaultContainerConfig (testImageName <> ":latest")) {env = [EnvVar "TEST" "123"]}
createdNetworks <- rights <$> mapM createNetworkWithName networkNames
containerId <- createContainer (CreateOpts containerConfig defaultHostConfig networkingConfig) Nothing
c <- fromRight containerId
status1 <- startContainer defaultStartOpts c
_ <- inspectContainer c >>= fromRight
lift $ threadDelay 300000 -- give 300ms for the application to finish
lift $ assertBool ("starting the container, unexpected status: " ++ show status1) $ isRightUnit status1
logs <- getContainerLogs defaultLogOpts c >>= fromRight
lift $ assert $ (C.pack "123") `C.isInfixOf` (toStrict1 logs)
status3 <- deleteContainer (ContainerDeleteOpts True True) c
lift $ assertBool ("deleting container, unexpected status: " ++ show status3) $ isRightUnit status3
mapM_ removeNetwork createdNetworks
where
isRightUnit (Right ()) = True
isRightUnit _ = False
networkNames = HM.keys $ endpointsConfig networkingConfig
createNetworkWithName name = createNetwork $
(defaultCreateNetworkOpts name) { createNetworkCheckDuplicate = True }
testCreateRemoveNetwork :: IO ()
testCreateRemoveNetwork = do
runDocker $ do
createStatus <- createNetwork $ defaultCreateNetworkOpts "test-network"
lift $ assertBool ("creating a network, unexpected status: " ++ show createStatus) $ isRight createStatus
nid <- fromRight createStatus
removeStatus <- removeNetwork nid
lift $ assertBool ("removing a network, unexpected status: " ++ show removeStatus) $ isRight removeStatus
testLogDriverOptionsJson :: TestTree
testLogDriverOptionsJson = testGroup "Testing LogDriverOptions JSON" [test1, test2, test3]
where
test1 = testCase "Driver option 1" $ assert $ JSON.toJSON sample ^. key key1 . _String == val1
test2 = testCase "Driver option 2" $ assert $ JSON.toJSON sample ^. key key2 . _String == val2
test3 =
testCase "Test override" $ assert $ JSON.toJSON sample2 ^. key key1 . _String == "override"
sample = [LogDriverOption key1 val1, LogDriverOption key2 val2]
sample2 = [LogDriverOption key1 val1, LogDriverOption key1 "override"]
key1 :: IsString a => a
key1 = "some-key"
val1 = "some-val"
key2 :: IsString a => a
key2 = "some-key2"
val2 = "some-key2"
testExposedPortsJson :: TestTree
testExposedPortsJson = testGroup "Testing ExposedPorts JSON" [testTCP, testUDP]
where
testTCP = testCase "tcp port" $ assert $ JSON.toJSON sampleEP ^. key "80/tcp" . _Object == emptyMap
testUDP =
testCase "udp port" $ assert $ JSON.toJSON sampleEP ^. key "1337/tcp" . _Object == emptyMap
sampleEP = [ExposedPort 80 TCP, ExposedPort 1337 UDP]
testLabelsJson :: TestTree
testLabelsJson = testGroup "Testing Labels JSON" [testLS1, testLS2, testOverride]
where
testLS1 = testCase "test label key1" $ assert $ JSON.toJSON sampleLS ^. key key1 . _String == val1
testLS2 = testCase "test label key2" $ assert $ JSON.toJSON sampleLS ^. key key2 . _String == val2
testOverride =
testCase "test label override" $ assert $ JSON.toJSON [Label key1 val1, Label key1 "override"] ^.
key key1 .
_String ==
"override"
sampleLS = [Label key1 val1, Label key2 val2]
key1 :: IsString a => a
key1 = "com.example.some-label"
val1 = "some-value"
key2 :: IsString a => a
key2 = "something"
val2 = "value"
testVolumesJson :: TestTree
testVolumesJson = testGroup "Testing Volumes JSON" [testSample1, testSample2]
where
testSample1 =
testCase "Test exposing volume: /tmp" $ assert $ JSON.toJSON sampleVolumes ^. key "/tmp" . _Object ==
emptyMap
testSample2 =
testCase "Test exposing volume: /opt" $ assert $ JSON.toJSON sampleVolumes ^. key "/opt" . _Object ==
emptyMap
sampleVolumes = [Volume "/tmp", Volume "/opt"]
testBindsJson :: TestTree
testBindsJson = testGroup "Testing Binds JSON" [testSample1, testSample2, testSample3]
where
testSample1 =
testCase "Testing Bind without VolumePermission" $
JSON.String "/foo:/bar" @=? JSON.toJSON (Bind "/foo" "/bar" Nothing)
testSample2 =
testCase "Testing Bind with ReadOnly" $
JSON.String "/foo:/bar:ro" @=? JSON.toJSON (Bind "/foo" "/bar" (Just ReadOnly))
testSample3 =
testCase "Testing Bind with WriteOnly" $
JSON.String "/foo:/bar:rw" @=? JSON.toJSON (Bind "/foo" "/bar" (Just ReadWrite))
testPortBindingJSON :: TestTree
testPortBindingJSON = testGroup "Testing PortBinding JSON" [testSample1]
where
testSample1 =
testCase "Test decoding null hostPorts" $ assert $ (JSON.decode "{ \"22/tcp\": null }" :: Maybe [PortBinding]) == Just [PortBinding 22 TCP []]
testEntrypointJson :: TestTree
testEntrypointJson = testGroup "Testing ContainerConfig JSON" [testSample1, testSample2, testSample3, testSample4, testSample5]
where
testSample1 =
testCase "Test toJSON with empty entrypoint (null)" $ assert $ JSON.toJSON (Entrypoint []) ^. _Null == ()
testSample2 =
testCase "Test toJSON with entrypoint as Array" $ assert $
JSON.toJSON (Entrypoint sampleEntrypointArr) ==
JSON.toJSON sampleEntrypointArr
testSample3 =
testCase "Test decoding entrypoint as string" $ assert $ (JSON.decode "\"cmd\"") ==
Just (Entrypoint ["cmd"])
testSample4 =
testCase "Test decoding as null" $ assert $ (JSON.decode "null" :: Maybe Entrypoint) ==
Just (Entrypoint [])
testSample5 =
testCase "Test decoding as array" $ assert $ (JSON.decode (JSON.encode sampleEntrypointArr) :: Maybe Entrypoint) ==
Just (Entrypoint sampleEntrypointArr)
sampleEntrypointArr = ["cmd", "--some-flag", "--some-flag2"]
testEnvVarJson :: TestTree
testEnvVarJson = testGroup "Testing EnvVar JSON" [testSampleEncode, testSampleDecode]
where
testSampleEncode =
testCase "Test toJSON" $ assert $ JSON.toJSON (EnvVar "cellar" "door") == JSON.String "cellar=door"
testSampleDecode =
testCase "Test fromJSON" $ assert $ (JSON.decode "\"cellar=door\"" :: Maybe EnvVar) ==
Just (EnvVar "cellar" "door")
testNetworkingConfigJson :: TestTree
testNetworkingConfigJson = testGroup "Testing NetworkingConfig JSON" [testSampleEncode]
where
testSampleEncode =
let networkingConfig = NetworkingConfig $ HM.fromList [("custom-network", EndpointConfig ["cellar", "door"])]
in testCase "Test toJSON" $ assert $ JSON.toJSON networkingConfig ==
JSON.object
[ "EndpointsConfig" .= JSON.object
[ "custom-network" .= JSON.object
[ "Aliases" .= (["cellar", "door"] :: [Text])
]
]
]
integrationTests :: TestTree
integrationTests =
testGroup
"Integration Tests"
[ testCase "Get docker version" testDockerVersion
, testCase "Build image from Dockerfile" testBuildFromDockerfile
, testCase "Find image by name" testFindImage
, testCase "Delete image" testDeleteImage
, testCase "List containers" testListContainers
, testCase "Run a dummy container and read its log" testRunAndReadLog
, testCase "Run a dummy container with networking and read its log" testRunAndReadLogWithNetworking
, testCase "Try to stop a container that doesn't exist" testStopNonexisting
, testCase "Create and remove a network" testCreateRemoveNetwork
]
jsonTests :: TestTree
jsonTests =
testGroup
"JSON Tests"
[ testExposedPortsJson
, testVolumesJson
, testBindsJson
, testLabelsJson
, testLogDriverOptionsJson
, testPortBindingJSON
, testEntrypointJson
, testEnvVarJson
, testNetworkingConfigJson
]
setup :: IO ()
setup =
mapM_ system
[ "docker pull " ++ unpack imageToDeleteFullName
, "docker build -t " ++ unpack testImageName ++ " tests"
]
isLeft = not . isRight
isRight (Left _) = False
isRight (Right _) = True
fromRight
:: (MonadIO m, Show l)
=> Either l r -> m r
fromRight (Left l) = do
liftIO $ assertFailure $ "Left: " ++ show l
undefined
fromRight (Right r) = return r
main :: IO ()
main = do
stackage <- lookupEnv "RUN_INTEGRATION_TESTS"
case stackage of
Nothing -> defaultMain $ testGroup "Tests" [jsonTests]
Just _ -> do
setup
defaultMain $ testGroup "Tests" [jsonTests, integrationTests]