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

… issue
codedownio · Jul 30, 2024 · b076663 · b076663
1 parent 6d90723
commit b076663
Show file tree

Hide file tree

Showing 30 changed files with 472 additions and 44 deletions.
diff --git a/flake.nix b/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} \

diff --git a/integration-tests/app/Main.hs b/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
 

diff --git a/integration-tests/integration-tests.cabal b/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
diff --git a/integration-tests/lib/TestLib/Docker.hs b/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

diff --git a/integration-tests/lib/TestLib/Docker/Containers.hs b/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 ()
diff --git a/integration-tests/package.yaml b/integration-tests/package.yaml
@@ -54,4 +54,6 @@ executables:
     - -rtsopts
     - -with-rtsopts=-N
     dependencies:
+    - docker-engine
     - integration-tests
+    - string-interpolate
diff --git a/v1.36/lib/DockerEngine/Model.hs b/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' .

diff --git a/v1.36/lib/DockerEngine/ModelLens.hs b/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 #-}
 

diff --git a/v1.36/tests/Instances.hs b/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