-
Notifications
You must be signed in to change notification settings - Fork 0
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Add first integration test (network create + delete)
- Loading branch information
Showing
8 changed files
with
222 additions
and
141 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -1,23 +1,23 @@ | ||
| module Main where | ||
|
|
||
| import Control.Concurrent | ||
| import Control.Monad.IO.Class | ||
| import Test.Sandwich | ||
| import TestLib.Docker | ||
|
|
||
|
|
||
| basic :: TopSpec | ||
| basic = describe "Simple tests" $ do | ||
| describe "Arithmetic" $ do | ||
| it "adds" $ do | ||
| (2 + 2) `shouldBe` 4 | ||
| (2 + 3) `shouldBe` 5 | ||
| basic = introduceDockerState $ do | ||
| describe "Networks" $ do | ||
| it "creates and deletes a network" $ do | ||
| ds <- getContext dockerState | ||
|
|
||
| let name = "test-network" | ||
| doesNetworkExist ds name >>= (`shouldBe` False) | ||
|
|
||
| it "subtracts" $ do | ||
| warn "This might not be right..." | ||
| (3 - 2) `shouldBe` 0 | ||
| networkId <- createNetwork ds name mempty | ||
| doesNetworkExist ds name >>= (`shouldBe` True) | ||
|
|
||
| describe "Strings" $ | ||
| it "concatenates" $ | ||
| ("abc" <> "def") `shouldBe` "abcdef" | ||
| deleteNetwork ds networkId | ||
| doesNetworkExist ds name >>= (`shouldBe` False) | ||
|
|
||
| main :: IO () | ||
| main = runSandwichWithCommandLineArgs defaultOptions basic |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,66 @@ | ||
|
|
||
| module TestLib.Docker.Core where | ||
|
|
||
| import Control.Monad.Catch (MonadThrow) | ||
| import Control.Monad.IO.Unlift | ||
| import Control.Monad.Logger | ||
| import Data.String.Interpolate | ||
| import DockerEngine.Client | ||
| import DockerEngine.Core | ||
| import DockerEngine.MimeTypes | ||
| import GHC.Stack | ||
| import Network.HTTP.Client as NH | ||
| import qualified Network.Socket as S | ||
| import qualified Network.Socket.ByteString as SBS | ||
| import Test.Sandwich | ||
| import TestLib.Docker.Types | ||
|
|
||
|
|
||
| getDockerState :: MonadLoggerIO m => m DockerState | ||
| getDockerState = do | ||
| config <- liftIO (newConfig >>= return) | ||
| manager <- liftIO $ newUnixDomainSocketManager "/var/run/docker.sock" | ||
| return $ DockerState config manager | ||
| where | ||
| newUnixDomainSocketManager :: FilePath -> IO Manager | ||
| newUnixDomainSocketManager path = do | ||
| newManager $ defaultManagerSettings { managerRawConnection = return $ openUnixSocket path } | ||
| where | ||
| openUnixSocket filePath _ _ _ = do | ||
| s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol | ||
| S.connect s (S.SockAddrUnix filePath) | ||
| makeConnection (SBS.recv s 8096) | ||
| (SBS.sendAll s) | ||
| (S.close s) | ||
|
|
||
| runDocker :: ( | ||
| HasCallStack, Produces req accept, MimeType contentType, MimeUnrender accept res, MonadLoggerIO m | ||
| ) | ||
| => DockerState | ||
| -> DockerEngineRequest req contentType res accept | ||
| -> m (MimeResult res) | ||
| runDocker (DockerState config manager) req = do | ||
| debug [i|---> #{req}|] | ||
| liftIO $ dispatchMime manager config req | ||
|
|
||
| runDocker' :: ( | ||
| HasCallStack, Produces req accept, MimeType contentType, MimeUnrender accept res, MonadLoggerIO m | ||
| ) | ||
| => DockerState | ||
| -> DockerEngineRequest req contentType res accept | ||
| -> m (Either MimeError res) | ||
| runDocker' (DockerState config manager) req = do | ||
| debug [i|---> #{req}|] | ||
| liftIO $ dispatchMime' manager config req | ||
|
|
||
| runDockerException :: ( | ||
| HasCallStack, Produces req accept, MimeType contentType, MimeUnrender accept res, MonadLoggerIO m, MonadThrow m | ||
| ) | ||
| => DockerState | ||
| -> DockerEngineRequest req contentType res accept | ||
| -> m res | ||
| runDockerException (DockerState config manager) req = do | ||
| debug [i|---> #{req}|] | ||
| liftIO (dispatchMime' manager config req) >>= \case | ||
| Left mimeError -> expectationFailure [i|Got MimeError: #{mimeError}|] | ||
| Right x -> return x |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,50 @@ | ||
| {-# LANGUAGE ViewPatterns #-} | ||
|
|
||
| module TestLib.Docker.Networks where | ||
|
|
||
| import Control.Monad.Catch | ||
| import Control.Monad.IO.Unlift | ||
| import Control.Monad.Logger | ||
| import Data.Either | ||
| import qualified Data.Map as M | ||
| import Data.String.Interpolate | ||
| import Data.Text as T | ||
| import DockerEngine.API.Network | ||
| import DockerEngine.Client | ||
| import DockerEngine.Model hiding (Map) | ||
| import GHC.Stack | ||
| import Test.Sandwich | ||
| import TestLib.Docker.Core | ||
| import TestLib.Docker.Types | ||
| import TestLib.Docker.Util | ||
|
|
||
|
|
||
| doesNetworkExist :: ( | ||
| HasCallStack, MonadLoggerIO m, MonadUnliftIO m | ||
| ) => DockerState -> Text -> m Bool | ||
| doesNetworkExist ds networkName = isRight <$> inspectNetwork ds (Id networkName) | ||
|
|
||
| inspectNetwork :: ( | ||
| HasCallStack, MonadLoggerIO m, MonadUnliftIO m | ||
| ) => DockerState -> Id -> m (Either Text Network) | ||
| inspectNetwork (DockerState config manager) ident = leftOnException $ do | ||
| let req = networkInspect ident | ||
| debug [i|---> #{req}|] | ||
| liftIO (dispatchMime manager config req) >>= \case | ||
| MimeResult (Left err) _ -> return $ Left [i|(#{ident}) inspectNetwork failed: '#{err}'|] | ||
| MimeResult (Right result) _ -> return $ Right result | ||
|
|
||
| createNetwork :: ( | ||
| HasCallStack, MonadUnliftIO m, MonadLoggerIO m, MonadFail m, MonadThrow m | ||
| ) => DockerState -> Text -> M.Map Text Text -> m Id | ||
| createNetwork ds networkName labels = do | ||
| let networkConfig = (mkNetworkCreateRequest networkName) { | ||
| networkCreateRequestLabels = Just $ M.mapKeys T.unpack labels | ||
| } | ||
| NetworkCreateResponse {networkCreateResponseId=(Just x)} <- runDockerException ds (networkCreate networkConfig) | ||
| return (Id x) | ||
|
|
||
| deleteNetwork :: (HasCallStack, MonadUnliftIO m, MonadLoggerIO m, MonadThrow m) => DockerState -> Id -> m () | ||
| deleteNetwork ds networkId = do | ||
| _ <- runDockerException ds (networkDelete networkId) | ||
| return () |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,19 @@ | ||
| {-# LANGUAGE ConstraintKinds #-} | ||
| {-# LANGUAGE DataKinds #-} | ||
|
|
||
| module TestLib.Docker.Types where | ||
|
|
||
|
|
||
| import DockerEngine.Core | ||
| import Network.HTTP.Client as NH | ||
| import Test.Sandwich | ||
|
|
||
|
|
||
| data DockerState = DockerState { | ||
| dockerEngineConfig :: DockerEngineConfig | ||
| , dockerHttpManager :: Manager | ||
| } | ||
|
|
||
| dockerState :: Label "dockerState" DockerState | ||
| dockerState = Label | ||
| type HasDockerState context = HasLabel context "dockerState" DockerState |
Oops, something went wrong.