diff --git a/integration-tests/.gitignore b/integration-tests/.gitignore new file mode 100644 index 0000000..c368d45 --- /dev/null +++ b/integration-tests/.gitignore @@ -0,0 +1,2 @@ +.stack-work/ +*~ \ No newline at end of file diff --git a/integration-tests/Main.hs b/integration-tests/app/Main.hs similarity index 89% rename from integration-tests/Main.hs rename to integration-tests/app/Main.hs index b72180b..b825e34 100644 --- a/integration-tests/Main.hs +++ b/integration-tests/app/Main.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE OverloadedStrings #-} - module Main where +import Control.Concurrent +import Control.Monad.IO.Class import Test.Sandwich basic :: TopSpec diff --git a/integration-tests/docker-engine-integration-tests.cabal b/integration-tests/docker-engine-integration-tests.cabal new file mode 100644 index 0000000..21eb3be --- /dev/null +++ b/integration-tests/docker-engine-integration-tests.cabal @@ -0,0 +1,73 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.36.0. +-- +-- see: https://github.com/sol/hpack + +name: docker-engine-integration-tests +version: 0.1.0.0 +license: BSD3 +build-type: Simple + +library + exposed-modules: + TestLib.Docker + other-modules: + Paths_docker_engine_integration_tests + hs-source-dirs: + lib + default-extensions: + OverloadedStrings + QuasiQuotes + NamedFieldPuns + RecordWildCards + ScopedTypeVariables + FlexibleContexts + FlexibleInstances + LambdaCase + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , base + , bytestring + , containers + , docker-engine + , exceptions + , hostname + , http-client + , http-types + , iproute + , monad-control + , monad-logger + , network + , random + , relude + , retry + , safe + , sandwich + , string-interpolate + , text + , unliftio + , unliftio-core + default-language: Haskell2010 + +executable docker-engine-integration-tests + main-is: Main.hs + other-modules: + Paths_docker_engine_integration_tests + hs-source-dirs: + app + default-extensions: + OverloadedStrings + QuasiQuotes + NamedFieldPuns + RecordWildCards + ScopedTypeVariables + FlexibleContexts + FlexibleInstances + LambdaCase + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base + , sandwich + default-language: Haskell2010 diff --git a/integration-tests/lib/TestLib/Docker.hs b/integration-tests/lib/TestLib/Docker.hs new file mode 100644 index 0000000..9e9d92e --- /dev/null +++ b/integration-tests/lib/TestLib/Docker.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +module TestLib.Docker where + +import Control.Monad.IO.Unlift +import Control.Monad.Logger +import qualified Data.ByteString.Lazy.Char8 as BL8 +import Data.Either +import Data.IP +import qualified Data.Map as M +import Data.String.Interpolate +import Data.Text as T +import DockerEngine.API.Network +import DockerEngine.Client +import DockerEngine.Core +import DockerEngine.MimeTypes +import DockerEngine.Model hiding (Map) +import GHC.Stack +import Network.HTTP.Client as NH +import Network.HTTP.Types.Status as HTTP +import qualified Network.Socket as S +import qualified Network.Socket.ByteString as SBS +import Test.Sandwich +import UnliftIO.Exception + + +data DockerState = DockerState { + dockerEngineConfig :: DockerEngineConfig + , dockerHttpManager :: Manager + } + +dockerState :: Label "dockerState" DockerState +dockerState = Label +type HasDockerState context = HasLabel context "dockerState" DockerState + +introduceDockerState :: ( + HasCallStack, MonadUnliftIO m + ) => SpecFree (LabelValue "dockerState" DockerState :> context) m () -> SpecFree context m () +introduceDockerState = introduce "introduce Docker state" dockerState getDockerState (const $ return ()) + +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) + +runDockerEngineLBS :: (HasCallStack, Produces req accept, MimeType contentType, MonadLoggerIO m) + => DockerState -> DockerEngineRequest req contentType res accept -> m (NH.Response BL8.ByteString) +runDockerEngineLBS ds req = do + runDockerEngineLBS' ds req + +runDockerEngineLBS' :: (HasCallStack, Produces req accept, MimeType contentType, MonadLoggerIO m) + => DockerState -> DockerEngineRequest req contentType res accept -> m (NH.Response BL8.ByteString) +runDockerEngineLBS' (DockerState config manager) req = do + debug [i|---> #{req}|] + liftIO $ dispatchLbs manager config req + + + +-- * Networks + +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) => DockerState -> Text -> M.Map Text Text -> m (Either Text ()) +createNetwork ds networkName labels = leftOnException $ do + let networkConfig = (mkNetworkCreateRequest networkName) { + networkCreateRequestLabels = Just $ M.mapKeys T.unpack labels + } + let req = networkCreate networkConfig + runDockerEngineLBS ds req >>= \case + (is2xx -> True) -> return $ Right () + x@(is403 -> True) -> return $ Left [i|Failed to create network '#{networkName}'. operation not supported for pre-defined networks: '#{x}'|] + x@(is404 -> True) -> return $ Left [i|Failed to create network '#{networkName}'. Plugin not found: '#{x}'|] + x@(is5xx -> True) -> return $ Left [i|Server error in createNetwork for '#{networkName}': '#{x}'|] + x -> return $ Left [i|Unexpected response in createNetwork for '#{networkName}': '#{x}'|] + + +-- * HTTP + +is2xx :: NH.Response a -> Bool +is2xx (responseStatus -> (HTTP.Status code _)) = code >= 200 && code < 300 + +-- is304 :: NH.Response a -> Bool +-- is304 (responseStatus -> (HTTP.Status code _)) = code == 304 + +-- is400 :: NH.Response a -> Bool +-- is400 (responseStatus -> (HTTP.Status code _)) = code == 400 + +is403 :: NH.Response a -> Bool +is403 (responseStatus -> (HTTP.Status code _)) = code == 403 + +is404 :: NH.Response a -> Bool +is404 (responseStatus -> (HTTP.Status code _)) = code == 404 + +-- is409 :: NH.Response a -> Bool +-- is409 (responseStatus -> (HTTP.Status code _)) = code == 409 + +is5xx :: NH.Response a -> Bool +is5xx (responseStatus -> (HTTP.Status code _)) = code >= 500 && code < 600 + +-- * Util + +leftOnException :: (MonadUnliftIO m) => m (Either Text a) -> m (Either Text a) +leftOnException = handleAny $ \e -> return $ Left $ T.pack $ case fromException e of + Just (Reason _ msg) -> msg + _ -> show e diff --git a/integration-tests/package.yaml b/integration-tests/package.yaml new file mode 100644 index 0000000..7cfe9ec --- /dev/null +++ b/integration-tests/package.yaml @@ -0,0 +1,51 @@ +name: docker-engine-integration-tests +version: 0.1.0.0 +license: BSD3 + +dependencies: +- base +- sandwich + +default-extensions: +- OverloadedStrings +- QuasiQuotes +- NamedFieldPuns +- RecordWildCards +- ScopedTypeVariables +- FlexibleContexts +- FlexibleInstances +- LambdaCase + +ghc-options: +- -threaded +- -rtsopts +- -with-rtsopts=-N + +library: + source-dirs: lib + dependencies: + - aeson + - bytestring + - containers + - docker-engine + - exceptions + - hostname + - http-client + - http-types + - iproute + - monad-control + - monad-logger + - network + - random + - relude + - retry + - safe + - string-interpolate + - text + - unliftio + - unliftio-core + +executables: + docker-engine-integration-tests: + main: Main.hs + source-dirs: app diff --git a/stack.yaml b/stack.yaml index 802174f..8f06994 100644 --- a/stack.yaml +++ b/stack.yaml @@ -6,12 +6,14 @@ nix: - zlib packages: -# - './v1.36' -# - './v1.37' -# - './v1.38' -# - './v1.39' -# - './v1.40' -# - './v1.41' -# - './v1.42' -# - './v1.43' -- './v1.44' +# - ./v1.36 +# - ./v1.37 +# - ./v1.38 +# - ./v1.39 +# - ./v1.40 +# - ./v1.41 +# - ./v1.42 +# - ./v1.43 +- ./v1.44 + +- ./integration-tests