{-# LANGUAGE OverloadedStrings #-} module Main where import Data.Either (rights) 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 ((.=)) import Data.Aeson.Lens (key, _Array, _Null, _Object, _String, _Value) 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 -- 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 <- defaultHttpHandler 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 = "some-key" val1 = "some-val" 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 == HM.empty testUDP = testCase "udp port" $ assert $ JSON.toJSON sampleEP ^. key "1337/tcp" . _Object == HM.empty 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 = "com.example.some-label" val1 = "some-value" 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 == HM.empty testSample2 = testCase "Test exposing volume: /opt" $ assert $ JSON.toJSON sampleVolumes ^. key "/opt" . _Object == HM.empty 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)) 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 , 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]