Working on integration tests for container create/delete; fix an enum…

… issue

flake.nix

@@ -18,6 +18,11 @@
  yq e -i 'del(.definitions.ContainerSummary.items)' api.yaml
  '';
 
+ # Docker may emit an empty string for HostConfig.Isolation
+ fixHostConfigIsolation = ''
+ yq e -i '.definitions.HostConfig.allOf[1].properties.Isolation.enum += [""]' api.yaml
+ '';
+
  mkApiYaml = { src, fixes ? [] }: pkgs.stdenv.mkDerivation {
  name = "docker-api.yaml";
  inherit src;
@@ -38,52 +43,82 @@
  url = "https://docs.docker.com/reference/engine/v1.36.yaml";
  hash = "sha256-6kS2MJunowLqAEhdCqi+lXLHsGb9dr2M51fuG+ENX0Q=";
  };
- fixes = [fixContainerSummaryDefinition];
+ fixes = [
+ fixContainerSummaryDefinition
+ fixHostConfigIsolation
+ ];
  };
  api_1_37 = mkApiYaml {
  src = pkgs.fetchurl {
  url = "https://docs.docker.com/reference/engine/v1.37.yaml";
  hash = "sha256-TSOJs7T7EDkehQIqRa7U59miFdxH72YIn8ynBx2uUOI=";
  };
- fixes = [fixContainerSummaryDefinition];
+ fixes = [
+ fixContainerSummaryDefinition
+ fixHostConfigIsolation
+ ];
  };
  api_1_38 = mkApiYaml {
  src = pkgs.fetchurl {
  url = "https://docs.docker.com/reference/engine/v1.38.yaml";
  hash = "sha256-5eHhNFiO4YXVhl045OldlL8Mry72LybHzuAtJT1dfMc=";
  };
- fixes = [fixContainerSummaryDefinition];
+ fixes = [
+ fixContainerSummaryDefinition
+ fixHostConfigIsolation
+ ];
  };
  api_1_39 = mkApiYaml {
  src = pkgs.fetchurl {
  url = "https://docs.docker.com/reference/engine/v1.39.yaml";
  hash = "sha256-Oswl1SJb2MCVpTQ/P9Cj+l1gM8d7E7IXxzffmeavhFM=";
  };
- fixes = [fixContainerSummaryDefinition];
+ fixes = [
+ fixContainerSummaryDefinition
+ ];
  };
- api_1_40 = pkgs.fetchurl {
- url = "https://docs.docker.com/reference/engine/v1.40.yaml";
- hash = "sha256-7AOKrQhc1wzFNnMEIk8grt0DK+KtWLTkrrqwAqiKlQo=";
+ api_1_40 = mkApiYaml {
+ src = pkgs.fetchurl {
+ url = "https://docs.docker.com/reference/engine/v1.40.yaml";
+ hash = "sha256-7AOKrQhc1wzFNnMEIk8grt0DK+KtWLTkrrqwAqiKlQo=";
+ };
+ fixes = [fixHostConfigIsolation];
  };
- api_1_41 = pkgs.fetchurl {
- url = "https://docs.docker.com/reference/engine/v1.41.yaml";
- hash = "sha256-bTE0P7dTdIILMxuPy0lm07fB6azn42SxkrLFhramEjE=";
+ api_1_41 = mkApiYaml {
+ src = pkgs.fetchurl {
+ url = "https://docs.docker.com/reference/engine/v1.41.yaml";
+ hash = "sha256-bTE0P7dTdIILMxuPy0lm07fB6azn42SxkrLFhramEjE=";
+ };
+ fixes = [fixHostConfigIsolation];
  };
- api_1_42 = pkgs.fetchurl {
- url = "https://docs.docker.com/reference/engine/v1.42.yaml";
- hash = "sha256-qaILCCvjwXoPf4R7SHEhsTmronF4h7BtsLChP3pHJBI=";
+ api_1_42 = mkApiYaml {
+ src = pkgs.fetchurl {
+ url = "https://docs.docker.com/reference/engine/v1.42.yaml";
+ hash = "sha256-qaILCCvjwXoPf4R7SHEhsTmronF4h7BtsLChP3pHJBI=";
+ };
+ fixes = [fixHostConfigIsolation];
  };
- api_1_43 = pkgs.fetchurl {
- url = "https://docs.docker.com/reference/engine/v1.43.yaml";
- hash = "sha256-R29jmbUjGsOOJl7uITl2vgcifGWhKUmuK4p32Xz+Vbc=";
+ api_1_43 = mkApiYaml {
+ src = pkgs.fetchurl {
+ url = "https://docs.docker.com/reference/engine/v1.43.yaml";
+ hash = "sha256-R29jmbUjGsOOJl7uITl2vgcifGWhKUmuK4p32Xz+Vbc=";
+ };
+ fixes = [fixHostConfigIsolation];
  };
- api_1_44 = pkgs.fetchurl {
- url = "https://docs.docker.com/reference/engine/v1.44.yaml";
- hash = "sha256-GfZnFirciPMRuBrUqjIydfpZ7yw/L26tNBjMxId4NLg=";
+ api_1_44 = mkApiYaml {
+ src = pkgs.fetchurl {
+ url = "https://docs.docker.com/reference/engine/v1.44.yaml";
+ hash = "sha256-GfZnFirciPMRuBrUqjIydfpZ7yw/L26tNBjMxId4NLg=";
+ };
+ fixes = [fixHostConfigIsolation];
  };
 
  mkGenerateScript = apiYaml: dir: pkgs.writeShellScriptBin "generate.sh" ''
  mkdir -p "${dir}"
+
+ # Would be nice to use this to deal with enum problems, but it produces crazy output:
+ # --additional-properties=enumUnknownDefaultCase=true \
+
  ${pkgs.openapi-generator-cli}/bin/openapi-generator-cli generate \
  --generator-name haskell-http-client \
  -i ${apiYaml} \

integration-tests/app/Main.hs

@@ -1,12 +1,36 @@
 module Main where
 
+import Data.String.Interpolate
+import DockerEngine.Model
 import Test.Sandwich
 import TestLib.Docker
 
 
 basic :: TopSpec
 basic = introduceDockerState $ do
  describe "Networks" $ do
+ it "creates and deletes a container" $ do
+ ds <- getContext dockerState
+
+ let name = "test-container"
+ let image = "busybox"
+
+ doesContainerExist ds name >>= (`shouldBe` False)
+
+ containerId <- createContainer ds name image mempty
+ info [i|Created container ID: #{containerId}|]
+
+ inspectResult <- inspectContainer ds containerId
+ info [i|Inspect result by ID: #{inspectResult}|]
+
+ inspectResult' <- inspectContainer ds (Id name)
+ info [i|Inspect result by name: #{inspectResult'}|]
+
+ doesContainerExist ds name >>= (`shouldBe` True)
+
+ deleteContainer ds containerId
+ doesContainerExist ds name >>= (`shouldBe` False)
+
  it "creates and deletes a network" $ do
  ds <- getContext dockerState
 

integration-tests/integration-tests.cabal

@@ -13,6 +13,7 @@ library
  exposed-modules:
  TestLib.Docker
  other-modules:
+ TestLib.Docker.Containers
  TestLib.Docker.Core
  TestLib.Docker.Networks
  TestLib.Docker.Types
@@ -73,6 +74,8 @@ executable integration-tests
  ghc-options: -threaded -Wall -rtsopts -with-rtsopts=-N
  build-depends:
  base
+ , docker-engine
  , integration-tests
  , sandwich
+ , string-interpolate
  default-language: Haskell2010

integration-tests/lib/TestLib/Docker.hs

@@ -7,14 +7,17 @@ module TestLib.Docker (
  introduceDockerState
 
  , module TestLib.Docker.Core
- , module TestLib.Docker.Networks
  , module TestLib.Docker.Types
  , module TestLib.Docker.Util
+
+ , module TestLib.Docker.Containers
+ , module TestLib.Docker.Networks
  ) where
 
 import Control.Monad.IO.Unlift
 import GHC.Stack
 import Test.Sandwich
+import TestLib.Docker.Containers
 import TestLib.Docker.Core
 import TestLib.Docker.Networks
 import TestLib.Docker.Types

integration-tests/lib/TestLib/Docker/Containers.hs

@@ -0,0 +1,57 @@
+{-# LANGUAGE ViewPatterns #-}
+
+module TestLib.Docker.Containers 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.Container
+import DockerEngine.Client
+import DockerEngine.Core
+import DockerEngine.MimeTypes
+import DockerEngine.Model hiding (Map)
+import GHC.Stack
+import Test.Sandwich
+import TestLib.Docker.Core
+import TestLib.Docker.Types
+import TestLib.Docker.Util
+
+
+doesContainerExist :: (
+ HasCallStack, MonadLoggerIO m, MonadUnliftIO m
+ ) => DockerState -> Text -> m Bool
+doesContainerExist ds containerName = isRight <$> inspectContainer ds (Id containerName)
+
+inspectContainer :: (
+ HasCallStack, MonadLoggerIO m, MonadUnliftIO m
+ ) => DockerState -> Id -> m (Either Text ContainerInspectResponse)
+inspectContainer (DockerState config manager) ident = leftOnException $ do
+ let req = containerInspect ident
+ debug [i|---> #{req}|]
+ liftIO (dispatchMime manager config req) >>= \case
+ MimeResult (Left err) _ -> return $ Left [i|(#{ident}) inspectContainer failed: '#{err}'|]
+ MimeResult (Right result) _ -> return $ Right result
+
+createContainer :: (
+ HasCallStack, MonadUnliftIO m, MonadLoggerIO m, MonadFail m, MonadThrow m
+ ) => DockerState -> Text -> Text -> M.Map Text Text -> m Id
+createContainer ds containerName image labels = do
+ let containerConfig = mkContainerCreateRequest {
+ containerCreateRequestLabels = Just $ M.mapKeys T.unpack labels
+ , containerCreateRequestImage = Just image
+ }
+
+ let req = containerCreate (ContentType MimeJSON) containerConfig
+ -&- (Name containerName)
+
+ ContainerCreateResponse {containerCreateResponseId=x} <- runDockerException ds req
+ return (Id x)
+
+deleteContainer :: (HasCallStack, MonadUnliftIO m, MonadLoggerIO m, MonadThrow m) => DockerState -> Id -> m ()
+deleteContainer ds containerId = do
+ _ <- runDockerException ds (containerDelete containerId)
+ return ()

integration-tests/package.yaml

@@ -54,4 +54,6 @@ executables:
  - -rtsopts
  - -with-rtsopts=-N
  dependencies:
+ - docker-engine
  - integration-tests
+ - string-interpolate

v1.36/lib/DockerEngine/Model.hs

@@ -7764,7 +7764,7 @@ data TaskSpecContainerSpec = TaskSpecContainerSpec
  , taskSpecContainerSpecDnsConfig :: !(Maybe TaskSpecContainerSpecDNSConfig) -- ^ "DNSConfig"
  , taskSpecContainerSpecSecrets :: !(Maybe [TaskSpecContainerSpecSecretsInner]) -- ^ "Secrets" - Secrets contains references to zero or more secrets that will be exposed to the service.
  , taskSpecContainerSpecConfigs :: !(Maybe [TaskSpecContainerSpecConfigsInner]) -- ^ "Configs" - Configs contains references to zero or more configs that will be exposed to the service.
- , taskSpecContainerSpecIsolation :: !(Maybe E'Isolation) -- ^ "Isolation" - Isolation technology of the containers running the service. (Windows only)
+ , taskSpecContainerSpecIsolation :: !(Maybe E'Isolation3) -- ^ "Isolation" - Isolation technology of the containers running the service. (Windows only)
  } deriving (P.Show, P.Eq, P.Typeable)
 
 -- | FromJSON TaskSpecContainerSpec
@@ -8960,6 +8960,7 @@ data E'Isolation
  = E'Isolation'Default -- ^ @"default"@
  | E'Isolation'Process -- ^ @"process"@
  | E'Isolation'Hyperv -- ^ @"hyperv"@
+ | E'Isolation'Empty -- ^ @""@
  deriving (P.Show, P.Eq, P.Typeable, P.Ord, P.Bounded, P.Enum)
 
 instance A.ToJSON E'Isolation where toJSON = A.toJSON . fromE'Isolation
@@ -8974,13 +8975,15 @@ fromE'Isolation = \case
  E'Isolation'Default -> "default"
  E'Isolation'Process -> "process"
  E'Isolation'Hyperv -> "hyperv"
+ E'Isolation'Empty -> ""
 
 -- | parse 'E'Isolation' enum
 toE'Isolation :: Text -> P.Either String E'Isolation
 toE'Isolation = \case
  "default" -> P.Right E'Isolation'Default
  "process" -> P.Right E'Isolation'Process
  "hyperv" -> P.Right E'Isolation'Hyperv
+ "" -> P.Right E'Isolation'Empty
  s -> P.Left $ "toE'Isolation: enum parse failure: " P.++ P.show s
 
 
@@ -9016,6 +9019,38 @@ toE'Isolation2 = \case
  s -> P.Left $ "toE'Isolation2: enum parse failure: " P.++ P.show s
 
 
+-- ** E'Isolation3
+
+-- | Enum of 'Text' .
+-- Isolation technology of the containers running the service. (Windows only)
+data E'Isolation3
+ = E'Isolation3'Default -- ^ @"default"@
+ | E'Isolation3'Process -- ^ @"process"@
+ | E'Isolation3'Hyperv -- ^ @"hyperv"@
+ deriving (P.Show, P.Eq, P.Typeable, P.Ord, P.Bounded, P.Enum)
+
+instance A.ToJSON E'Isolation3 where toJSON = A.toJSON . fromE'Isolation3
+instance A.FromJSON E'Isolation3 where parseJSON o = P.either P.fail (pure . P.id) . toE'Isolation3 =<< A.parseJSON o
+instance WH.ToHttpApiData E'Isolation3 where toQueryParam = WH.toQueryParam . fromE'Isolation3
+instance WH.FromHttpApiData E'Isolation3 where parseQueryParam o = WH.parseQueryParam o >>= P.left T.pack . toE'Isolation3
+instance MimeRender MimeMultipartFormData E'Isolation3 where mimeRender _ = mimeRenderDefaultMultipartFormData
+
+-- | unwrap 'E'Isolation3' enum
+fromE'Isolation3 :: E'Isolation3 -> Text
+fromE'Isolation3 = \case
+ E'Isolation3'Default -> "default"
+ E'Isolation3'Process -> "process"
+ E'Isolation3'Hyperv -> "hyperv"
+
+-- | parse 'E'Isolation3' enum
+toE'Isolation3 :: Text -> P.Either String E'Isolation3
+toE'Isolation3 = \case
+ "default" -> P.Right E'Isolation3'Default
+ "process" -> P.Right E'Isolation3'Process
+ "hyperv" -> P.Right E'Isolation3'Hyperv
+ s -> P.Left $ "toE'Isolation3: enum parse failure: " P.++ P.show s
+
+
 -- ** E'Mode
 
 -- | Enum of 'Text' .

v1.36/lib/DockerEngine/ModelLens.hs

@@ -5142,7 +5142,7 @@ taskSpecContainerSpecConfigsL f TaskSpecContainerSpec{..} = (\taskSpecContainerS
 {-# INLINE taskSpecContainerSpecConfigsL #-}
 
 -- | 'taskSpecContainerSpecIsolation' Lens
-taskSpecContainerSpecIsolationL :: Lens_' TaskSpecContainerSpec (Maybe E'Isolation)
+taskSpecContainerSpecIsolationL :: Lens_' TaskSpecContainerSpec (Maybe E'Isolation3)
 taskSpecContainerSpecIsolationL f TaskSpecContainerSpec{..} = (\taskSpecContainerSpecIsolation -> TaskSpecContainerSpec { taskSpecContainerSpecIsolation, ..} ) <$> f taskSpecContainerSpecIsolation
 {-# INLINE taskSpecContainerSpecIsolationL #-}
 

v1.36/tests/Instances.hs

@@ -2093,7 +2093,7 @@ genTaskSpecContainerSpec n =
  <*> arbitraryReducedMaybe n -- taskSpecContainerSpecDnsConfig :: Maybe TaskSpecContainerSpecDNSConfig
  <*> arbitraryReducedMaybe n -- taskSpecContainerSpecSecrets :: Maybe [TaskSpecContainerSpecSecretsInner]
  <*> arbitraryReducedMaybe n -- taskSpecContainerSpecConfigs :: Maybe [TaskSpecContainerSpecConfigsInner]
- <*> arbitraryReducedMaybe n -- taskSpecContainerSpecIsolation :: Maybe E'Isolation
+ <*> arbitraryReducedMaybe n -- taskSpecContainerSpecIsolation :: Maybe E'Isolation3
 
 instance Arbitrary TaskSpecContainerSpecConfigsInner where
  arbitrary = sized genTaskSpecContainerSpecConfigsInner
@@ -2364,6 +2364,9 @@ instance Arbitrary E'Isolation where
 instance Arbitrary E'Isolation2 where
  arbitrary = arbitraryBoundedEnum
 
+instance Arbitrary E'Isolation3 where
+ arbitrary = arbitraryBoundedEnum
+
 instance Arbitrary E'Mode where
  arbitrary = arbitraryBoundedEnum