From c255fb8378c5358d25b5f9c0a5e8bf482efe4262 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Kihlberg?= Date: Thu, 9 Nov 2023 12:18:38 +0100 Subject: [PATCH 01/20] implementation scaffold --- .../Language/Marlowe/Runtime/Web/Server/OpenAPI.hs | 6 ++++++ marlowe-runtime-web/test/Spec.hs | 9 +++++++-- 2 files changed, 13 insertions(+), 2 deletions(-) diff --git a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/OpenAPI.hs b/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/OpenAPI.hs index 7562e8adf7..c30a7c1112 100644 --- a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/OpenAPI.hs +++ b/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/OpenAPI.hs @@ -62,6 +62,12 @@ instance ToJSON OpenApiWithEmptySecurity where type API = "openapi.json" :> Get '[JSON] OpenApiWithEmptySecurity +data OpenApiLintIssue = Unknown + deriving (Show, Eq) + +lintOpenApi :: OpenApi -> [OpenApiLintIssue] +lintOpenApi _ = [] + openApi :: OpenApiWithEmptySecurity openApi = OpenApiWithEmptySecurity $ diff --git a/marlowe-runtime-web/test/Spec.hs b/marlowe-runtime-web/test/Spec.hs index 2a8e2d3cf5..e262104c43 100644 --- a/marlowe-runtime-web/test/Spec.hs +++ b/marlowe-runtime-web/test/Spec.hs @@ -26,12 +26,12 @@ import Language.Marlowe.Object.Gen () import Language.Marlowe.Runtime.Transaction.Gen () import Language.Marlowe.Runtime.Web (ContractOrSourceId (..), WithRuntimeStatus) import qualified Language.Marlowe.Runtime.Web as Web -import Language.Marlowe.Runtime.Web.Server.OpenAPI (openApi) +import Language.Marlowe.Runtime.Web.Server.OpenAPI (OpenApiLintIssue, lintOpenApi, openApi) import Servant.API import Servant.OpenApi import Spec.Marlowe.Semantics.Arbitrary () import Spec.Marlowe.Semantics.Next.Arbitrary () -import Test.Hspec (Spec, describe, hspec, it) +import Test.Hspec (Spec, describe, focus, hspec, it, shouldBe) import Test.Hspec.Golden (defaultGolden) import Test.QuickCheck (Arbitrary (..), Gen, elements, genericShrink, listOf, oneof, resize, suchThat) import Test.QuickCheck.Instances () @@ -43,6 +43,11 @@ main = hspec do openAPISpec :: Spec openAPISpec = do + focus do + it "finds no problems with empty schema" do + let actual = lintOpenApi mempty + expected :: [OpenApiLintIssue] = [] + actual `shouldBe` expected validateEveryToJSONWithPatternChecker patternChecker (Proxy @(WrapContractBodies (RetractRuntimeStatus Web.API))) it "Should match the golden test" do defaultGolden "OpenApi" $ From f84e1da86a944d78795efbe603c76fc20da81ca4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Kihlberg?= Date: Thu, 9 Nov 2023 16:10:30 +0100 Subject: [PATCH 02/20] first draft --- marlowe-runtime-web/marlowe-runtime-web.cabal | 2 + .../Marlowe/Runtime/Web/Server/OpenAPI.hs | 50 +++++++++++++++++-- marlowe-runtime-web/test/Spec.hs | 19 ++++++- 3 files changed, 67 insertions(+), 4 deletions(-) diff --git a/marlowe-runtime-web/marlowe-runtime-web.cabal b/marlowe-runtime-web/marlowe-runtime-web.cabal index 46eec00238..a977367be0 100644 --- a/marlowe-runtime-web/marlowe-runtime-web.cabal +++ b/marlowe-runtime-web/marlowe-runtime-web.cabal @@ -133,6 +133,7 @@ library server , eventuo11y-extras ==0.1.1.0 , exceptions >=0.10 && <0.12 , http-media ^>=0.8 + , insert-ordered-containers >=0.2.5 && <0.3 , lens >=5.2 && <6 , lens-aeson ^>=1.2 , marlowe-cardano ==0.2.0.0 @@ -205,6 +206,7 @@ test-suite marlowe-runtime-web-test , bytestring >=0.10.12 && <0.12 , hspec , hspec-golden + , lens >=5.2 && <6 , marlowe-cardano ==0.2.0.0 , marlowe-object:gen , marlowe-runtime-web:{marlowe-runtime-web, server} diff --git a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/OpenAPI.hs b/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/OpenAPI.hs index c30a7c1112..e6daa833c5 100644 --- a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/OpenAPI.hs +++ b/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/OpenAPI.hs @@ -8,13 +8,20 @@ module Language.Marlowe.Runtime.Web.Server.OpenAPI where import Control.Applicative ((<|>)) -import Control.Lens +import Control.Lens hiding (allOf, anyOf) +import qualified Control.Lens as Optics +import qualified Control.Monad as Control import Data.Aeson import Data.Aeson.Lens +import qualified Data.HashMap.Strict.InsOrd as IOHM +import qualified Data.List as List import Data.OpenApi hiding (Server) import Data.String (fromString) +import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text as Text import Data.Version (showVersion) +import GHC.Exts (toList) import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) import qualified Language.Marlowe.Runtime.Web as Web import qualified Paths_marlowe_runtime_web @@ -62,11 +69,48 @@ instance ToJSON OpenApiWithEmptySecurity where type API = "openapi.json" :> Get '[JSON] OpenApiWithEmptySecurity -data OpenApiLintIssue = Unknown +data OpenApiLintIssue = OpenApiLintIssue + { trace :: Text + , message :: Text + } deriving (Show, Eq) lintOpenApi :: OpenApi -> [OpenApiLintIssue] -lintOpenApi _ = [] +lintOpenApi oa = definitionLints + where + showStackTrace :: [Text] -> Text + showStackTrace = Text.concat . List.intersperse "/" . List.reverse + + definitions :: [(Text, Schema)] + definitions = toList $ Optics.view (components . schemas) oa + + schemaRule1Check :: [Text] -> Schema -> [OpenApiLintIssue] + schemaRule1Check stackTrace s = do + let schemaRequiredFields = Optics.view required s + -- TODO: schemaType = Optics.view type_ s + Control.when (null schemaRequiredFields) [] + let schemaProperties = Optics.view properties s + -- TODO: schemaAnyOf = Optics.view anyOf s + -- TODO: schemaOneOf = Optics.view oneOf s + -- TODO: schemaAllOf = Optics.view allOf s + schemaRequiredField <- schemaRequiredFields + if IOHM.member schemaRequiredField schemaProperties + then mempty + else + pure $ + OpenApiLintIssue + { trace = showStackTrace stackTrace + , message = "Missing type for required field '" <> schemaRequiredField <> "'!" + } + + lintSchema :: [Text] -> Schema -> [OpenApiLintIssue] + lintSchema = schemaRule1Check + + definitionLints :: [OpenApiLintIssue] + definitionLints = do + let stackTrace = ["schemas", "components"] + (definitionName, definitionSchema) <- definitions + lintSchema (definitionName : stackTrace) definitionSchema openApi :: OpenApiWithEmptySecurity openApi = diff --git a/marlowe-runtime-web/test/Spec.hs b/marlowe-runtime-web/test/Spec.hs index e262104c43..0fdeb6b02e 100644 --- a/marlowe-runtime-web/test/Spec.hs +++ b/marlowe-runtime-web/test/Spec.hs @@ -8,6 +8,7 @@ module Main where +import Control.Lens ((&), (.~)) import Control.Monad (replicateM) import Data.Aeson (ToJSON, Value (Null)) import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder) @@ -20,13 +21,14 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Internal.Builder as TB import qualified Data.Text.Lazy as TL +import GHC.Exts (fromList) import qualified Language.Marlowe.Core.V1.Semantics.Types as Semantics (Input (..)) import qualified Language.Marlowe.Core.V1.Semantics.Types as V1 import Language.Marlowe.Object.Gen () import Language.Marlowe.Runtime.Transaction.Gen () import Language.Marlowe.Runtime.Web (ContractOrSourceId (..), WithRuntimeStatus) import qualified Language.Marlowe.Runtime.Web as Web -import Language.Marlowe.Runtime.Web.Server.OpenAPI (OpenApiLintIssue, lintOpenApi, openApi) +import Language.Marlowe.Runtime.Web.Server.OpenAPI (OpenApiLintIssue (..), lintOpenApi, openApi) import Servant.API import Servant.OpenApi import Spec.Marlowe.Semantics.Arbitrary () @@ -48,6 +50,21 @@ openAPISpec = do let actual = lintOpenApi mempty expected :: [OpenApiLintIssue] = [] actual `shouldBe` expected + it "rejects object schemas with required fields which have no types" do + let definitions :: Definitions Schema + definitions = fromList [("mydefinition", mempty & required .~ ["myfield"])] + openApiSchema :: OpenApi + openApiSchema = mempty & components . schemas .~ definitions + actual :: [OpenApiLintIssue] + actual = lintOpenApi openApiSchema + expected :: [OpenApiLintIssue] + expected = + [ OpenApiLintIssue + { trace = "components/schemas/mydefinition" + , message = "Missing type for required field 'myfield'!" + } + ] + actual `shouldBe` expected validateEveryToJSONWithPatternChecker patternChecker (Proxy @(WrapContractBodies (RetractRuntimeStatus Web.API))) it "Should match the golden test" do defaultGolden "OpenApi" $ From b183d3909c99f259755759893c1b9ba0bf656913 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Kihlberg?= Date: Wed, 15 Nov 2023 12:52:17 +0100 Subject: [PATCH 03/20] lint openapi definitions --- marlowe-runtime-web/marlowe-runtime-web.cabal | 1 + .../Marlowe/Runtime/Web/Server/OpenAPI.hs | 64 +++++-- marlowe-runtime-web/test/Spec.hs | 178 +++++++++++++++++- 3 files changed, 220 insertions(+), 23 deletions(-) diff --git a/marlowe-runtime-web/marlowe-runtime-web.cabal b/marlowe-runtime-web/marlowe-runtime-web.cabal index a977367be0..aeae13cc4f 100644 --- a/marlowe-runtime-web/marlowe-runtime-web.cabal +++ b/marlowe-runtime-web/marlowe-runtime-web.cabal @@ -206,6 +206,7 @@ test-suite marlowe-runtime-web-test , bytestring >=0.10.12 && <0.12 , hspec , hspec-golden + , insert-ordered-containers >=0.2.5 && <0.3 , lens >=5.2 && <6 , marlowe-cardano ==0.2.0.0 , marlowe-object:gen diff --git a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/OpenAPI.hs b/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/OpenAPI.hs index e6daa833c5..b75a70173d 100644 --- a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/OpenAPI.hs +++ b/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/OpenAPI.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-orphans #-} -- | This module defines the API and server for serving the Open API @@ -10,11 +11,13 @@ module Language.Marlowe.Runtime.Web.Server.OpenAPI where import Control.Applicative ((<|>)) import Control.Lens hiding (allOf, anyOf) import qualified Control.Lens as Optics +import Control.Monad ((<=<)) import qualified Control.Monad as Control import Data.Aeson import Data.Aeson.Lens import qualified Data.HashMap.Strict.InsOrd as IOHM import qualified Data.List as List +import qualified Data.Maybe as Maybe import Data.OpenApi hiding (Server) import Data.String (fromString) import Data.Text (Text) @@ -81,37 +84,62 @@ lintOpenApi oa = definitionLints showStackTrace :: [Text] -> Text showStackTrace = Text.concat . List.intersperse "/" . List.reverse - definitions :: [(Text, Schema)] - definitions = toList $ Optics.view (components . schemas) oa + definitions :: Definitions Schema + definitions = Optics.view (components . schemas) oa + + schemaRef :: Referenced Schema -> Maybe Schema + schemaRef = \case + Inline s -> Just s + Ref (Reference ((`IOHM.lookup` definitions) -> s)) -> s schemaRule1Check :: [Text] -> Schema -> [OpenApiLintIssue] schemaRule1Check stackTrace s = do - let schemaRequiredFields = Optics.view required s - -- TODO: schemaType = Optics.view type_ s - Control.when (null schemaRequiredFields) [] - let schemaProperties = Optics.view properties s - -- TODO: schemaAnyOf = Optics.view anyOf s - -- TODO: schemaOneOf = Optics.view oneOf s - -- TODO: schemaAllOf = Optics.view allOf s + let schemaRequiredFields :: [Text] + schemaRequiredFields = Optics.view required s + + checkIfPropertyHaveTypedef :: Text -> Schema -> Maybe OpenApiType + checkIfPropertyHaveTypedef fieldName ss = + IOHM.lookup fieldName (Optics.view properties ss) >>= schemaRef >>= Optics.view type_ + + schemaAnyOf :: Maybe [Referenced Schema] + schemaAnyOf = Optics.view anyOf s + + schemaOneOf :: Maybe [Referenced Schema] + schemaOneOf = Optics.view oneOf s + + schemaAllOf :: Maybe [Referenced Schema] + schemaAllOf = Optics.view allOf s + schemaRequiredField <- schemaRequiredFields - if IOHM.member schemaRequiredField schemaProperties - then mempty - else - pure $ - OpenApiLintIssue - { trace = showStackTrace stackTrace - , message = "Missing type for required field '" <> schemaRequiredField <> "'!" - } + let checkForType :: Referenced Schema -> Bool + checkForType = Maybe.isJust . (checkIfPropertyHaveTypedef schemaRequiredField <=< schemaRef) + + typeIsInProperties = Maybe.isJust $ checkIfPropertyHaveTypedef schemaRequiredField s + typeIsInEveryAnyOf = maybe False (and . fmap checkForType) schemaAnyOf + typeIsInEveryOneOf = maybe False (and . fmap checkForType) schemaOneOf + typeIsInOneAllOf = maybe False (or . fmap checkForType) schemaAllOf + + Control.when (typeIsInProperties || typeIsInEveryAnyOf || typeIsInEveryOneOf || typeIsInOneAllOf) [] + + pure $ + OpenApiLintIssue + { trace = showStackTrace stackTrace + , message = "Missing type for required field '" <> schemaRequiredField <> "'!" + } lintSchema :: [Text] -> Schema -> [OpenApiLintIssue] lintSchema = schemaRule1Check + -- DONE: definitionLints :: [OpenApiLintIssue] definitionLints = do let stackTrace = ["schemas", "components"] - (definitionName, definitionSchema) <- definitions + (definitionName, definitionSchema) <- toList definitions lintSchema (definitionName : stackTrace) definitionSchema +-- TODO: path->param +-- TODO: path->operation* + openApi :: OpenApiWithEmptySecurity openApi = OpenApiWithEmptySecurity $ diff --git a/marlowe-runtime-web/test/Spec.hs b/marlowe-runtime-web/test/Spec.hs index 0fdeb6b02e..41ede015d5 100644 --- a/marlowe-runtime-web/test/Spec.hs +++ b/marlowe-runtime-web/test/Spec.hs @@ -8,12 +8,13 @@ module Main where -import Control.Lens ((&), (.~)) +import Control.Lens ((&), (.~), (?~)) import Control.Monad (replicateM) import Data.Aeson (ToJSON, Value (Null)) import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder) import qualified Data.ByteString as BS import Data.Data (Typeable) +import qualified Data.HashMap.Strict.InsOrd as IOHM import Data.Kind (Type) import Data.OpenApi hiding (version) import Data.Proxy @@ -50,9 +51,144 @@ openAPISpec = do let actual = lintOpenApi mempty expected :: [OpenApiLintIssue] = [] actual `shouldBe` expected - it "rejects object schemas with required fields which have no types" do + it "reports object schemas with required fields which have no types" do let definitions :: Definitions Schema - definitions = fromList [("mydefinition", mempty & required .~ ["myfield"])] + definitions = + fromList + [ ("mydefinition1", mempty & required .~ ["myfield1a"]) + , ("mydefinition2", mempty & required .~ ["myfield2a", "myfield2b"]) + , + ( "mydefinition3" + , mempty + & required .~ ["myfield3a", "myfield3b"] + & properties .~ IOHM.singleton "myfield3a" (Inline mempty) + ) + , + ( "mydefinition4" + , mempty + & type_ ?~ OpenApiBoolean + ) + , + ( "mydefinition5" + , mempty + ) + , + ( "mydefinition6" + , mempty + & required .~ ["myfield6a", "myfield6b", "myfield6c"] + & properties + .~ fromList + [ ("myfield6a", Ref (Reference "mydefinition4")) + , ("myfield6b", Ref (Reference "mydefinition5")) + , ("myfield6c", Ref (Reference "mydefinition?")) + ] + ) + , + ( "mydefinition7" + , mempty + & required .~ ["myfield7a"] + & oneOf + ?~ [ Inline + ( mempty + & properties + .~ fromList + [ ("myfield7a", Ref (Reference "mydefinition4")) + ] + ) + , Inline + ( mempty + & properties + .~ fromList + [ ("myfield7a", Inline (mempty & type_ ?~ OpenApiInteger)) + ] + ) + ] + ) + , + ( "mydefinition8" + , mempty + & required .~ ["myfield8a"] + & oneOf + ?~ [ Inline + ( mempty + & properties + .~ fromList + [ ("myfield8a", Ref (Reference "mydefinition4")) + ] + ) + , Inline + ( mempty + & properties + .~ fromList + [ ("myfield8a", Inline mempty) + ] + ) + ] + ) + , + ( "mydefinition9" + , mempty + & required .~ ["myfield9a"] + & anyOf + ?~ [ Inline + ( mempty + & properties + .~ fromList + [ ("myfield9a", Ref (Reference "mydefinition4")) + ] + ) + , Inline + ( mempty + & properties + .~ fromList + [ ("myfield9a", Inline (mempty & type_ ?~ OpenApiInteger)) + ] + ) + ] + ) + , + ( "mydefinition10" + , mempty + & required .~ ["myfield10a"] + & anyOf + ?~ [ Inline + ( mempty + & properties + .~ fromList + [ ("myfield10a", Ref (Reference "mydefinition4")) + ] + ) + , Inline + ( mempty + & properties + .~ fromList + [ ("myfield10a", Inline mempty) + ] + ) + ] + ) + , + ( "mydefinition11" + , mempty + & required .~ ["myfield11a"] + & allOf + ?~ [ Inline + ( mempty + & properties + .~ fromList + [ ("myfield11a", Ref (Reference "mydefinition4")) + ] + ) + , Inline + ( mempty + & properties + .~ fromList + [ ("myfield11a", Inline mempty) + ] + ) + ] + ) + ] openApiSchema :: OpenApi openApiSchema = mempty & components . schemas .~ definitions actual :: [OpenApiLintIssue] @@ -60,8 +196,40 @@ openAPISpec = do expected :: [OpenApiLintIssue] expected = [ OpenApiLintIssue - { trace = "components/schemas/mydefinition" - , message = "Missing type for required field 'myfield'!" + { trace = "components/schemas/mydefinition1" + , message = "Missing type for required field 'myfield1a'!" + } + , OpenApiLintIssue + { trace = "components/schemas/mydefinition2" + , message = "Missing type for required field 'myfield2a'!" + } + , OpenApiLintIssue + { trace = "components/schemas/mydefinition2" + , message = "Missing type for required field 'myfield2b'!" + } + , OpenApiLintIssue + { trace = "components/schemas/mydefinition3" + , message = "Missing type for required field 'myfield3a'!" + } + , OpenApiLintIssue + { trace = "components/schemas/mydefinition3" + , message = "Missing type for required field 'myfield3b'!" + } + , OpenApiLintIssue + { trace = "components/schemas/mydefinition6" + , message = "Missing type for required field 'myfield6b'!" + } + , OpenApiLintIssue + { trace = "components/schemas/mydefinition6" + , message = "Missing type for required field 'myfield6c'!" + } + , OpenApiLintIssue + { trace = "components/schemas/mydefinition8" + , message = "Missing type for required field 'myfield8a'!" + } + , OpenApiLintIssue + { trace = "components/schemas/mydefinition10" + , message = "Missing type for required field 'myfield10a'!" } ] actual `shouldBe` expected From 6b76fe0fabecec76568c8b859a7944403fb1236e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Kihlberg?= Date: Wed, 15 Nov 2023 13:54:27 +0100 Subject: [PATCH 04/20] lint path parameters --- .../Marlowe/Runtime/Web/Server/OpenAPI.hs | 42 ++++++++++++------- 1 file changed, 27 insertions(+), 15 deletions(-) diff --git a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/OpenAPI.hs b/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/OpenAPI.hs index b75a70173d..ebce83f254 100644 --- a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/OpenAPI.hs +++ b/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/OpenAPI.hs @@ -28,7 +28,7 @@ import GHC.Exts (toList) import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) import qualified Language.Marlowe.Runtime.Web as Web import qualified Paths_marlowe_runtime_web -import Servant +import Servant hiding (Param) import Servant.OpenApi (toOpenApi) import Servant.Pagination @@ -79,18 +79,26 @@ data OpenApiLintIssue = OpenApiLintIssue deriving (Show, Eq) lintOpenApi :: OpenApi -> [OpenApiLintIssue] -lintOpenApi oa = definitionLints +lintOpenApi oa = schemaDefinitionLints <> pathParametersLints where showStackTrace :: [Text] -> Text showStackTrace = Text.concat . List.intersperse "/" . List.reverse - definitions :: Definitions Schema - definitions = Optics.view (components . schemas) oa + schemaDefinitions :: Definitions Schema + schemaDefinitions = Optics.view (components . schemas) oa + + paramDefinitions :: Definitions Param + paramDefinitions = Optics.view (components . parameters) oa schemaRef :: Referenced Schema -> Maybe Schema schemaRef = \case Inline s -> Just s - Ref (Reference ((`IOHM.lookup` definitions) -> s)) -> s + Ref (Reference ((`IOHM.lookup` schemaDefinitions) -> s)) -> s + + paramRef :: Referenced Param -> Maybe Param + paramRef = \case + Inline s -> Just s + Ref (Reference ((`IOHM.lookup` paramDefinitions) -> s)) -> s schemaRule1Check :: [Text] -> Schema -> [OpenApiLintIssue] schemaRule1Check stackTrace s = do @@ -110,7 +118,8 @@ lintOpenApi oa = definitionLints schemaAllOf :: Maybe [Referenced Schema] schemaAllOf = Optics.view allOf s - schemaRequiredField <- schemaRequiredFields + schemaRequiredField :: Text <- schemaRequiredFields + let checkForType :: Referenced Schema -> Bool checkForType = Maybe.isJust . (checkIfPropertyHaveTypedef schemaRequiredField <=< schemaRef) @@ -130,15 +139,18 @@ lintOpenApi oa = definitionLints lintSchema :: [Text] -> Schema -> [OpenApiLintIssue] lintSchema = schemaRule1Check - -- DONE: - definitionLints :: [OpenApiLintIssue] - definitionLints = do - let stackTrace = ["schemas", "components"] - (definitionName, definitionSchema) <- toList definitions - lintSchema (definitionName : stackTrace) definitionSchema - --- TODO: path->param --- TODO: path->operation* + schemaDefinitionLints :: [OpenApiLintIssue] + schemaDefinitionLints = do + (definitionName, definitionSchema) <- toList schemaDefinitions + lintSchema [definitionName, "schemas", "components"] definitionSchema + + -- DONE: path->param + pathParametersLints :: [OpenApiLintIssue] + pathParametersLints = do + (Text.pack -> path, endpoint) <- toList $ Optics.view paths oa + param :: Param <- Maybe.mapMaybe paramRef $ Optics.view parameters endpoint + s :: Schema <- Maybe.maybeToList (schemaRef =<< Optics.view schema param) + lintSchema [Optics.view name param, "parameters", path, "paths"] s openApi :: OpenApiWithEmptySecurity openApi = From 9d391a8399828b7908958f8bed259078feac1ee5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Kihlberg?= Date: Wed, 15 Nov 2023 14:14:48 +0100 Subject: [PATCH 05/20] lint operations --- .../Marlowe/Runtime/Web/Server/OpenAPI.hs | 33 ++++++++++++++++--- 1 file changed, 29 insertions(+), 4 deletions(-) diff --git a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/OpenAPI.hs b/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/OpenAPI.hs index ebce83f254..055e20d085 100644 --- a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/OpenAPI.hs +++ b/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/OpenAPI.hs @@ -79,7 +79,7 @@ data OpenApiLintIssue = OpenApiLintIssue deriving (Show, Eq) lintOpenApi :: OpenApi -> [OpenApiLintIssue] -lintOpenApi oa = schemaDefinitionLints <> pathParametersLints +lintOpenApi oa = schemaDefinitionLints <> pathParametersLints <> pathOperationLints where showStackTrace :: [Text] -> Text showStackTrace = Text.concat . List.intersperse "/" . List.reverse @@ -139,18 +139,43 @@ lintOpenApi oa = schemaDefinitionLints <> pathParametersLints lintSchema :: [Text] -> Schema -> [OpenApiLintIssue] lintSchema = schemaRule1Check + lintParam :: [Text] -> Param -> [OpenApiLintIssue] + lintParam stacktrace param = do + s :: Schema <- Maybe.maybeToList (schemaRef =<< Optics.view schema param) + lintSchema (Optics.view name param : stacktrace) s + schemaDefinitionLints :: [OpenApiLintIssue] schemaDefinitionLints = do (definitionName, definitionSchema) <- toList schemaDefinitions lintSchema [definitionName, "schemas", "components"] definitionSchema - -- DONE: path->param pathParametersLints :: [OpenApiLintIssue] pathParametersLints = do (Text.pack -> path, endpoint) <- toList $ Optics.view paths oa param :: Param <- Maybe.mapMaybe paramRef $ Optics.view parameters endpoint - s :: Schema <- Maybe.maybeToList (schemaRef =<< Optics.view schema param) - lintSchema [Optics.view name param, "parameters", path, "paths"] s + lintParam ["parameters", path, "paths"] param + + -- DONE: path->operation*->param + -- TODO: path->operation*->request + -- TODO: path->operation*->response + pathOperationLints :: [OpenApiLintIssue] + pathOperationLints = do + (Text.pack -> path, endpoint) <- toList $ Optics.view paths oa + (operationName :: Text, operation :: Operation) <- + zip + ["get", "put", "post", "delete", "options", "head", "patch", "trace"] + $ Maybe.catMaybes + [ Optics.view get endpoint + , Optics.view put endpoint + , Optics.view post endpoint + , Optics.view delete endpoint + , Optics.view options endpoint + , Optics.view head_ endpoint + , Optics.view patch endpoint + , Optics.view Data.OpenApi.trace endpoint + ] + param :: Param <- Maybe.mapMaybe paramRef $ Optics.view parameters operation + lintParam ["parameters", operationName, path, "paths"] param openApi :: OpenApiWithEmptySecurity openApi = From 39b49db169fb8e9f1d9fa3f726fe382dca7769a2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Kihlberg?= Date: Wed, 15 Nov 2023 17:47:15 +0100 Subject: [PATCH 06/20] lint everything --- .../Marlowe/Runtime/Web/Server/OpenAPI.hs | 76 ++++++++++++++++--- 1 file changed, 67 insertions(+), 9 deletions(-) diff --git a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/OpenAPI.hs b/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/OpenAPI.hs index 055e20d085..5d8fad32f4 100644 --- a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/OpenAPI.hs +++ b/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/OpenAPI.hs @@ -90,6 +90,15 @@ lintOpenApi oa = schemaDefinitionLints <> pathParametersLints <> pathOperationLi paramDefinitions :: Definitions Param paramDefinitions = Optics.view (components . parameters) oa + requestBodyDefinitions :: Definitions RequestBody + requestBodyDefinitions = Optics.view (components . requestBodies) oa + + responseDefinitions :: Definitions Response + responseDefinitions = Optics.view (components . responses) oa + + headerDefinitions :: Definitions Data.OpenApi.Header + headerDefinitions = Optics.view (components . headers) oa + schemaRef :: Referenced Schema -> Maybe Schema schemaRef = \case Inline s -> Just s @@ -100,6 +109,21 @@ lintOpenApi oa = schemaDefinitionLints <> pathParametersLints <> pathOperationLi Inline s -> Just s Ref (Reference ((`IOHM.lookup` paramDefinitions) -> s)) -> s + reqeuestBodyRef :: Referenced RequestBody -> Maybe RequestBody + reqeuestBodyRef = \case + Inline s -> Just s + Ref (Reference ((`IOHM.lookup` requestBodyDefinitions) -> s)) -> s + + responseRef :: Referenced Response -> Maybe Response + responseRef = \case + Inline s -> Just s + Ref (Reference ((`IOHM.lookup` responseDefinitions) -> s)) -> s + + headerRef :: Referenced Data.OpenApi.Header -> Maybe Data.OpenApi.Header + headerRef = \case + Inline s -> Just s + Ref (Reference ((`IOHM.lookup` headerDefinitions) -> s)) -> s + schemaRule1Check :: [Text] -> Schema -> [OpenApiLintIssue] schemaRule1Check stackTrace s = do let schemaRequiredFields :: [Text] @@ -124,11 +148,11 @@ lintOpenApi oa = schemaDefinitionLints <> pathParametersLints <> pathOperationLi checkForType = Maybe.isJust . (checkIfPropertyHaveTypedef schemaRequiredField <=< schemaRef) typeIsInProperties = Maybe.isJust $ checkIfPropertyHaveTypedef schemaRequiredField s - typeIsInEveryAnyOf = maybe False (and . fmap checkForType) schemaAnyOf - typeIsInEveryOneOf = maybe False (and . fmap checkForType) schemaOneOf - typeIsInOneAllOf = maybe False (or . fmap checkForType) schemaAllOf + typeIsInEveryAnyOfItem = maybe False (and . fmap checkForType) schemaAnyOf + typeIsInEveryOneOfItem = maybe False (and . fmap checkForType) schemaOneOf + typeIsInAnyAllOfItem = maybe False (or . fmap checkForType) schemaAllOf - Control.when (typeIsInProperties || typeIsInEveryAnyOf || typeIsInEveryOneOf || typeIsInOneAllOf) [] + Control.when (typeIsInProperties || typeIsInEveryAnyOfItem || typeIsInEveryOneOfItem || typeIsInAnyAllOfItem) [] pure $ OpenApiLintIssue @@ -144,6 +168,29 @@ lintOpenApi oa = schemaDefinitionLints <> pathParametersLints <> pathOperationLi s :: Schema <- Maybe.maybeToList (schemaRef =<< Optics.view schema param) lintSchema (Optics.view name param : stacktrace) s + lintMediaTypeObject :: [Text] -> MediaTypeObject -> [OpenApiLintIssue] + lintMediaTypeObject stacktrace mediaTypeObject = + lintSchema stacktrace =<< (Maybe.maybeToList $ schemaRef =<< Optics.view schema mediaTypeObject) + + lintRequestBody :: [Text] -> RequestBody -> [OpenApiLintIssue] + lintRequestBody stacktrace request = do + (show -> Text.pack -> mediaType, bodyContent :: MediaTypeObject) <- toList $ Optics.view content request + lintMediaTypeObject (mediaType : stacktrace) bodyContent + + lintHeader :: [Text] -> Data.OpenApi.Header -> [OpenApiLintIssue] + lintHeader stacktrace header = + lintSchema stacktrace =<< (Maybe.maybeToList $ schemaRef =<< Optics.view schema header) + + lintResponse :: [Text] -> Response -> [OpenApiLintIssue] + lintResponse stacktrace res = do + let responseContentLints = do + (show -> Text.pack -> mediaType, responseContent :: MediaTypeObject) <- toList $ Optics.view content res + lintMediaTypeObject (mediaType : "content" : stacktrace) responseContent + responseHeadersLints = do + (headerName, headerRef -> maybeHeader) <- toList $ Optics.view headers res + lintHeader (headerName : stacktrace) =<< Maybe.maybeToList maybeHeader + responseContentLints <> responseHeadersLints + schemaDefinitionLints :: [OpenApiLintIssue] schemaDefinitionLints = do (definitionName, definitionSchema) <- toList schemaDefinitions @@ -155,9 +202,6 @@ lintOpenApi oa = schemaDefinitionLints <> pathParametersLints <> pathOperationLi param :: Param <- Maybe.mapMaybe paramRef $ Optics.view parameters endpoint lintParam ["parameters", path, "paths"] param - -- DONE: path->operation*->param - -- TODO: path->operation*->request - -- TODO: path->operation*->response pathOperationLints :: [OpenApiLintIssue] pathOperationLints = do (Text.pack -> path, endpoint) <- toList $ Optics.view paths oa @@ -174,8 +218,22 @@ lintOpenApi oa = schemaDefinitionLints <> pathParametersLints <> pathOperationLi , Optics.view patch endpoint , Optics.view Data.OpenApi.trace endpoint ] - param :: Param <- Maybe.mapMaybe paramRef $ Optics.view parameters operation - lintParam ["parameters", operationName, path, "paths"] param + + concat + [ do + param :: Param <- Maybe.mapMaybe paramRef $ Optics.view parameters operation + lintParam ["parameters", operationName, path, "paths"] param + , do + request :: RequestBody <- Maybe.maybeToList $ reqeuestBodyRef =<< Optics.view requestBody operation + lintRequestBody ["requestBody", operationName, path, "paths"] request + , do + defaultResponse :: Response <- + Maybe.maybeToList $ responseRef =<< Optics.view default_ (Optics.view responses operation) + lintResponse ["default", "responses", operationName, path, "paths"] defaultResponse + , do + (show -> Text.pack -> httpCode, responseRef -> maybeRes) <- toList $ Optics.view (responses . responses) operation + lintResponse [httpCode, "responses", operationName, path, "paths"] =<< Maybe.maybeToList maybeRes + ] openApi :: OpenApiWithEmptySecurity openApi = From e4cecc49d1bbf8de20ab6943d3aa7090af6db8e4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Kihlberg?= Date: Thu, 16 Nov 2023 19:48:01 +0100 Subject: [PATCH 07/20] fix bug --- marlowe-runtime-web/marlowe-runtime-web.cabal | 1 + .../Marlowe/Runtime/Web/Server/OpenAPI.hs | 107 ++-- marlowe-runtime-web/test/Spec.hs | 477 +++++++++++------- 3 files changed, 358 insertions(+), 227 deletions(-) diff --git a/marlowe-runtime-web/marlowe-runtime-web.cabal b/marlowe-runtime-web/marlowe-runtime-web.cabal index aeae13cc4f..79c821c155 100644 --- a/marlowe-runtime-web/marlowe-runtime-web.cabal +++ b/marlowe-runtime-web/marlowe-runtime-web.cabal @@ -213,6 +213,7 @@ test-suite marlowe-runtime-web-test , marlowe-runtime-web:{marlowe-runtime-web, server} , marlowe-runtime:gen , marlowe-test + , mtl >=2.2 && <3 , openapi3 >=3.2 && <4 , QuickCheck , quickcheck-instances diff --git a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/OpenAPI.hs b/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/OpenAPI.hs index 5d8fad32f4..f3e1ff93f7 100644 --- a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/OpenAPI.hs +++ b/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/OpenAPI.hs @@ -11,8 +11,9 @@ module Language.Marlowe.Runtime.Web.Server.OpenAPI where import Control.Applicative ((<|>)) import Control.Lens hiding (allOf, anyOf) import qualified Control.Lens as Optics -import Control.Monad ((<=<)) -import qualified Control.Monad as Control +import Control.Monad.Reader (ReaderT (runReaderT)) +import qualified Control.Monad.Reader as Reader +import qualified Control.Monad.Trans as Trans import Data.Aeson import Data.Aeson.Lens import qualified Data.HashMap.Strict.InsOrd as IOHM @@ -78,12 +79,68 @@ data OpenApiLintIssue = OpenApiLintIssue } deriving (Show, Eq) +showStackTrace :: [Text] -> Text +showStackTrace = Text.concat . List.intersperse "/" . List.reverse + +newtype OpenApiLintEnvironment = OpenApiLintEnvironment + { schemaDefinitions :: Definitions Schema + } + +lookupSchema :: (Monad m) => Referenced Schema -> ReaderT OpenApiLintEnvironment m (Maybe Schema) +lookupSchema = \case + Inline ss -> pure $ Just ss + Ref (Reference ref) -> do + defs :: Definitions Schema <- Reader.asks schemaDefinitions + pure $ IOHM.lookup ref defs + +lookupType :: forall m. (Monad m) => Schema -> ReaderT OpenApiLintEnvironment m [OpenApiType] +lookupType s = + let lookupSchemaType = Maybe.maybeToList $ Optics.view type_ s + lookupOneOfType = case Optics.view oneOf s of + Just refs -> do + lookups :: [Maybe Schema] <- traverse lookupSchema refs + if any Maybe.isNothing lookups + then pure [] + else List.nub . concat <$> traverse lookupType (Maybe.catMaybes lookups) + Nothing -> pure [] + in if null lookupSchemaType + then lookupOneOfType + else pure lookupSchemaType + +lookupFieldType :: forall m. (Monad m) => Text -> Schema -> ReaderT OpenApiLintEnvironment m (Maybe [OpenApiType]) +lookupFieldType fieldName = + let loop :: Schema -> ReaderT OpenApiLintEnvironment m (Maybe [OpenApiType]) + loop s = + case IOHM.lookup fieldName (Optics.view properties s) of + Just ref -> lookupSchema ref >>= maybe (pure Nothing) (fmap (\x -> if null x then Nothing else Just x) . lookupType) + Nothing -> case Optics.view oneOf s of + Just s' -> do + s'' :: [Maybe Schema] <- traverse lookupSchema s' + if all Maybe.isJust s'' + then do + tjosan <- traverse loop (Maybe.catMaybes s'') + pure $ List.nub . concat <$> sequence tjosan + else pure Nothing + Nothing -> pure Nothing + in loop + +schemaRule1Check :: [Text] -> Schema -> ReaderT OpenApiLintEnvironment [] OpenApiLintIssue +schemaRule1Check stacktrace s = do + schemaRequiredField :: Text <- Trans.lift $ Optics.view required s + mFieldType <- lookupFieldType schemaRequiredField s + case mFieldType of + Just _ -> Trans.lift [] + Nothing -> + Trans.lift + [ OpenApiLintIssue + { trace = showStackTrace stacktrace + , message = "Missing type for required field '" <> schemaRequiredField <> "'!" + } + ] + lintOpenApi :: OpenApi -> [OpenApiLintIssue] lintOpenApi oa = schemaDefinitionLints <> pathParametersLints <> pathOperationLints where - showStackTrace :: [Text] -> Text - showStackTrace = Text.concat . List.intersperse "/" . List.reverse - schemaDefinitions :: Definitions Schema schemaDefinitions = Optics.view (components . schemas) oa @@ -124,44 +181,8 @@ lintOpenApi oa = schemaDefinitionLints <> pathParametersLints <> pathOperationLi Inline s -> Just s Ref (Reference ((`IOHM.lookup` headerDefinitions) -> s)) -> s - schemaRule1Check :: [Text] -> Schema -> [OpenApiLintIssue] - schemaRule1Check stackTrace s = do - let schemaRequiredFields :: [Text] - schemaRequiredFields = Optics.view required s - - checkIfPropertyHaveTypedef :: Text -> Schema -> Maybe OpenApiType - checkIfPropertyHaveTypedef fieldName ss = - IOHM.lookup fieldName (Optics.view properties ss) >>= schemaRef >>= Optics.view type_ - - schemaAnyOf :: Maybe [Referenced Schema] - schemaAnyOf = Optics.view anyOf s - - schemaOneOf :: Maybe [Referenced Schema] - schemaOneOf = Optics.view oneOf s - - schemaAllOf :: Maybe [Referenced Schema] - schemaAllOf = Optics.view allOf s - - schemaRequiredField :: Text <- schemaRequiredFields - - let checkForType :: Referenced Schema -> Bool - checkForType = Maybe.isJust . (checkIfPropertyHaveTypedef schemaRequiredField <=< schemaRef) - - typeIsInProperties = Maybe.isJust $ checkIfPropertyHaveTypedef schemaRequiredField s - typeIsInEveryAnyOfItem = maybe False (and . fmap checkForType) schemaAnyOf - typeIsInEveryOneOfItem = maybe False (and . fmap checkForType) schemaOneOf - typeIsInAnyAllOfItem = maybe False (or . fmap checkForType) schemaAllOf - - Control.when (typeIsInProperties || typeIsInEveryAnyOfItem || typeIsInEveryOneOfItem || typeIsInAnyAllOfItem) [] - - pure $ - OpenApiLintIssue - { trace = showStackTrace stackTrace - , message = "Missing type for required field '" <> schemaRequiredField <> "'!" - } - lintSchema :: [Text] -> Schema -> [OpenApiLintIssue] - lintSchema = schemaRule1Check + lintSchema stacktrace s = runReaderT (schemaRule1Check stacktrace s) (OpenApiLintEnvironment schemaDefinitions) lintParam :: [Text] -> Param -> [OpenApiLintIssue] lintParam stacktrace param = do @@ -228,7 +249,7 @@ lintOpenApi oa = schemaDefinitionLints <> pathParametersLints <> pathOperationLi lintRequestBody ["requestBody", operationName, path, "paths"] request , do defaultResponse :: Response <- - Maybe.maybeToList $ responseRef =<< Optics.view default_ (Optics.view responses operation) + Maybe.maybeToList $ responseRef =<< Optics.view (responses . default_) operation lintResponse ["default", "responses", operationName, path, "paths"] defaultResponse , do (show -> Text.pack -> httpCode, responseRef -> maybeRes) <- toList $ Optics.view (responses . responses) operation diff --git a/marlowe-runtime-web/test/Spec.hs b/marlowe-runtime-web/test/Spec.hs index 41ede015d5..7b487d9dcc 100644 --- a/marlowe-runtime-web/test/Spec.hs +++ b/marlowe-runtime-web/test/Spec.hs @@ -10,9 +10,11 @@ module Main where import Control.Lens ((&), (.~), (?~)) import Control.Monad (replicateM) +import Control.Monad.Reader (ReaderT (runReaderT), runReader) import Data.Aeson (ToJSON, Value (Null)) import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder) import qualified Data.ByteString as BS +import Data.Coerce (coerce) import Data.Data (Typeable) import qualified Data.HashMap.Strict.InsOrd as IOHM import Data.Kind (Type) @@ -22,14 +24,22 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Internal.Builder as TB import qualified Data.Text.Lazy as TL -import GHC.Exts (fromList) import qualified Language.Marlowe.Core.V1.Semantics.Types as Semantics (Input (..)) import qualified Language.Marlowe.Core.V1.Semantics.Types as V1 import Language.Marlowe.Object.Gen () import Language.Marlowe.Runtime.Transaction.Gen () import Language.Marlowe.Runtime.Web (ContractOrSourceId (..), WithRuntimeStatus) import qualified Language.Marlowe.Runtime.Web as Web -import Language.Marlowe.Runtime.Web.Server.OpenAPI (OpenApiLintIssue (..), lintOpenApi, openApi) +import Language.Marlowe.Runtime.Web.Server.OpenAPI ( + OpenApiLintEnvironment (..), + OpenApiLintIssue (..), + OpenApiWithEmptySecurity (..), + lintOpenApi, + lookupFieldType, + lookupType, + openApi, + schemaRule1Check, + ) import Servant.API import Servant.OpenApi import Spec.Marlowe.Semantics.Arbitrary () @@ -47,192 +57,291 @@ main = hspec do openAPISpec :: Spec openAPISpec = do focus do - it "finds no problems with empty schema" do - let actual = lintOpenApi mempty + it "finds no problems with the Marlowe Runtime OpenApi Schema" do + let actual = lintOpenApi $ coerce openApi expected :: [OpenApiLintIssue] = [] actual `shouldBe` expected - it "reports object schemas with required fields which have no types" do - let definitions :: Definitions Schema - definitions = - fromList - [ ("mydefinition1", mempty & required .~ ["myfield1a"]) - , ("mydefinition2", mempty & required .~ ["myfield2a", "myfield2b"]) - , - ( "mydefinition3" - , mempty - & required .~ ["myfield3a", "myfield3b"] - & properties .~ IOHM.singleton "myfield3a" (Inline mempty) - ) - , - ( "mydefinition4" - , mempty - & type_ ?~ OpenApiBoolean - ) - , - ( "mydefinition5" - , mempty - ) - , - ( "mydefinition6" - , mempty - & required .~ ["myfield6a", "myfield6b", "myfield6c"] - & properties - .~ fromList - [ ("myfield6a", Ref (Reference "mydefinition4")) - , ("myfield6b", Ref (Reference "mydefinition5")) - , ("myfield6c", Ref (Reference "mydefinition?")) - ] - ) - , - ( "mydefinition7" - , mempty - & required .~ ["myfield7a"] - & oneOf - ?~ [ Inline - ( mempty - & properties - .~ fromList - [ ("myfield7a", Ref (Reference "mydefinition4")) - ] - ) - , Inline - ( mempty - & properties - .~ fromList - [ ("myfield7a", Inline (mempty & type_ ?~ OpenApiInteger)) - ] - ) - ] - ) - , - ( "mydefinition8" - , mempty - & required .~ ["myfield8a"] - & oneOf - ?~ [ Inline - ( mempty - & properties - .~ fromList - [ ("myfield8a", Ref (Reference "mydefinition4")) - ] - ) - , Inline - ( mempty - & properties - .~ fromList - [ ("myfield8a", Inline mempty) - ] - ) - ] - ) - , - ( "mydefinition9" - , mempty - & required .~ ["myfield9a"] - & anyOf - ?~ [ Inline - ( mempty - & properties - .~ fromList - [ ("myfield9a", Ref (Reference "mydefinition4")) - ] - ) - , Inline - ( mempty - & properties - .~ fromList - [ ("myfield9a", Inline (mempty & type_ ?~ OpenApiInteger)) - ] - ) - ] - ) - , - ( "mydefinition10" - , mempty - & required .~ ["myfield10a"] - & anyOf - ?~ [ Inline - ( mempty - & properties - .~ fromList - [ ("myfield10a", Ref (Reference "mydefinition4")) - ] - ) - , Inline - ( mempty - & properties - .~ fromList - [ ("myfield10a", Inline mempty) - ] - ) - ] - ) - , - ( "mydefinition11" - , mempty - & required .~ ["myfield11a"] - & allOf - ?~ [ Inline - ( mempty - & properties - .~ fromList - [ ("myfield11a", Ref (Reference "mydefinition4")) - ] - ) - , Inline - ( mempty - & properties - .~ fromList - [ ("myfield11a", Inline mempty) - ] - ) - ] - ) + + describe "lookupType" do + it "test 00" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = mempty + actual = runReader (lookupType input) linterEnv + expected = [] + actual `shouldBe` expected + + it "test 01" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = mempty & type_ ?~ OpenApiBoolean + actual = runReader (lookupType input) linterEnv + expected = [OpenApiBoolean] + actual `shouldBe` expected + + it "test 02" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = + mempty + & oneOf + ?~ [ Inline (mempty & type_ ?~ OpenApiString) + , Inline (mempty & type_ ?~ OpenApiString) + , Inline (mempty & type_ ?~ OpenApiBoolean) + ] + actual = runReader (lookupType input) linterEnv + expected = [OpenApiString, OpenApiBoolean] + actual `shouldBe` expected + + it "test 03" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = + mempty + & oneOf + ?~ [ Ref (Reference "mydef") + , Inline (mempty & type_ ?~ OpenApiString) + , Inline (mempty & type_ ?~ OpenApiBoolean) + ] + actual = runReader (lookupType input) linterEnv + expected = [] + actual `shouldBe` expected + + it "test 04" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = + OpenApiLintEnvironment $ + IOHM.fromList + [ ("mydef", mempty & type_ ?~ OpenApiInteger) + ] + input :: Schema + input = + mempty + & oneOf + ?~ [ Ref (Reference "mydef") + , Inline (mempty & type_ ?~ OpenApiString) + , Inline (mempty & type_ ?~ OpenApiBoolean) + ] + actual = runReader (lookupType input) linterEnv + expected = [OpenApiInteger, OpenApiString, OpenApiBoolean] + actual `shouldBe` expected + + describe "lookupFieldType" do + it "test 00" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = mempty + actual = runReader (lookupFieldType "hey" input) linterEnv + expected = Nothing + actual `shouldBe` expected + + it "test 01" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = mempty & properties .~ IOHM.fromList [("hey", Inline (mempty & description ?~ "no type!"))] + actual = runReader (lookupFieldType "hey" input) linterEnv + expected = Nothing + actual `shouldBe` expected + + it "test 02" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = mempty & properties .~ IOHM.fromList [("hey", Inline (mempty & type_ ?~ OpenApiBoolean))] + actual = runReader (lookupFieldType "hey" input) linterEnv + expected = Just [OpenApiBoolean] + actual `shouldBe` expected + + it "test 03" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = mempty & oneOf ?~ [Inline (mempty & properties .~ IOHM.fromList [])] + actual = runReader (lookupFieldType "hey" input) linterEnv + expected = Nothing + actual `shouldBe` expected + + it "test 04" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = + mempty & oneOf ?~ [Inline (mempty & properties .~ IOHM.fromList [("hey", Inline (mempty & description ?~ "no type!"))])] + actual = runReader (lookupFieldType "hey" input) linterEnv + expected = Nothing + actual `shouldBe` expected + + it "test 05" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = + mempty & oneOf ?~ [Inline (mempty & properties .~ IOHM.fromList [("hey", Inline (mempty & type_ ?~ OpenApiBoolean))])] + actual = runReader (lookupFieldType "hey" input) linterEnv + expected = Just [OpenApiBoolean] + actual `shouldBe` expected + + it "test 06" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = + mempty + & oneOf + ?~ [ Inline + ( mempty + & properties + .~ IOHM.fromList + [ ("hey", Inline (mempty & type_ ?~ OpenApiInteger)) + ] + ) + ] + actual = runReader (lookupFieldType "hey" input) linterEnv + expected = Just [OpenApiInteger] + actual `shouldBe` expected + + it "test 07" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = + mempty + & oneOf + ?~ [ Inline + ( mempty + & properties + .~ IOHM.fromList + [ ("hey", Inline (mempty & description ?~ "no type!")) + ] + ) + ] + actual = runReader (lookupFieldType "hey" input) linterEnv + expected = Nothing + actual `shouldBe` expected + + it "test 08" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = + OpenApiLintEnvironment $ + IOHM.fromList + [ ("yo", mempty & type_ ?~ OpenApiString) + ] + input :: Schema + input = + mempty + & oneOf + ?~ [ Inline + ( mempty + & properties + .~ IOHM.fromList + [ ("hey", Ref (Reference "yo")) + ] + ) + ] + actual = runReader (lookupFieldType "hey" input) linterEnv + expected = Just [OpenApiString] + actual `shouldBe` expected + + it "test 09" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = + OpenApiLintEnvironment $ + IOHM.fromList + [ ("yo", mempty & type_ ?~ OpenApiString) + , ("sup", mempty & description ?~ "no type!") + ] + input :: Schema + input = + mempty + & oneOf + ?~ [ Inline + ( mempty + & properties + .~ IOHM.fromList + [ ("hey", Ref (Reference "sup")) + ] + ) + ] + actual = runReader (lookupFieldType "hey" input) linterEnv + expected = Nothing + actual `shouldBe` expected + + it "test 10" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = + OpenApiLintEnvironment $ + IOHM.fromList + [ ("yo", mempty & type_ ?~ OpenApiString) + , ("sup", mempty & oneOf ?~ [Ref (Reference "yo")]) + ] + input :: Schema + input = + mempty + & properties + .~ IOHM.fromList + [ ("hey", Ref (Reference "sup")) + ] + actual = runReader (lookupFieldType "hey" input) linterEnv + expected = Just [OpenApiString] + actual `shouldBe` expected + + it "test 11" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = + OpenApiLintEnvironment $ + IOHM.fromList + [ ("yo", mempty & type_ ?~ OpenApiString) + , ("sup", mempty & oneOf ?~ [Ref (Reference "yo")]) + , ("bye", mempty & properties .~ IOHM.fromList [("hey", Inline (mempty & type_ ?~ OpenApiBoolean))]) + ] + input :: Schema + input = + mempty + & oneOf + ?~ [ Inline (mempty & properties .~ IOHM.fromList [("hey", Ref (Reference "sup"))]) + , Inline (mempty & properties .~ IOHM.fromList [("hey", Ref (Reference "yo"))]) + , Inline (mempty & properties .~ IOHM.fromList [("hey", Inline (mempty & type_ ?~ OpenApiInteger))]) + , Ref (Reference "bye") + ] + actual = runReader (lookupFieldType "hey" input) linterEnv + expected = Just [OpenApiString, OpenApiInteger, OpenApiBoolean] + actual `shouldBe` expected + + describe "schemaRule1Check" do + it "test 00" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = mempty + actual = runReaderT (schemaRule1Check [] input) linterEnv + expected = [] + actual `shouldBe` expected + + it "test 01" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = mempty & required .~ ["myfield"] + actual = runReaderT (schemaRule1Check ["huey", "dewey", "louie"] input) linterEnv + expected = + [ OpenApiLintIssue + { trace = "louie/dewey/huey" + , message = "Missing type for required field 'myfield'!" + } ] - openApiSchema :: OpenApi - openApiSchema = mempty & components . schemas .~ definitions - actual :: [OpenApiLintIssue] - actual = lintOpenApi openApiSchema - expected :: [OpenApiLintIssue] - expected = - [ OpenApiLintIssue - { trace = "components/schemas/mydefinition1" - , message = "Missing type for required field 'myfield1a'!" - } - , OpenApiLintIssue - { trace = "components/schemas/mydefinition2" - , message = "Missing type for required field 'myfield2a'!" - } - , OpenApiLintIssue - { trace = "components/schemas/mydefinition2" - , message = "Missing type for required field 'myfield2b'!" - } - , OpenApiLintIssue - { trace = "components/schemas/mydefinition3" - , message = "Missing type for required field 'myfield3a'!" - } - , OpenApiLintIssue - { trace = "components/schemas/mydefinition3" - , message = "Missing type for required field 'myfield3b'!" - } - , OpenApiLintIssue - { trace = "components/schemas/mydefinition6" - , message = "Missing type for required field 'myfield6b'!" - } - , OpenApiLintIssue - { trace = "components/schemas/mydefinition6" - , message = "Missing type for required field 'myfield6c'!" - } - , OpenApiLintIssue - { trace = "components/schemas/mydefinition8" - , message = "Missing type for required field 'myfield8a'!" - } - , OpenApiLintIssue - { trace = "components/schemas/mydefinition10" - , message = "Missing type for required field 'myfield10a'!" - } - ] + actual `shouldBe` expected + + it "finds no problems with empty schema" do + let actual = lintOpenApi mempty + expected :: [OpenApiLintIssue] = [] actual `shouldBe` expected + validateEveryToJSONWithPatternChecker patternChecker (Proxy @(WrapContractBodies (RetractRuntimeStatus Web.API))) it "Should match the golden test" do defaultGolden "OpenApi" $ From af0bce0f4647c540a757f540cb930a9e89214521 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Kihlberg?= Date: Thu, 16 Nov 2023 20:01:14 +0100 Subject: [PATCH 08/20] remove focus --- marlowe-runtime-web/test/Spec.hs | 563 +++++++++++++++---------------- 1 file changed, 281 insertions(+), 282 deletions(-) diff --git a/marlowe-runtime-web/test/Spec.hs b/marlowe-runtime-web/test/Spec.hs index 7b487d9dcc..3318147c92 100644 --- a/marlowe-runtime-web/test/Spec.hs +++ b/marlowe-runtime-web/test/Spec.hs @@ -44,7 +44,7 @@ import Servant.API import Servant.OpenApi import Spec.Marlowe.Semantics.Arbitrary () import Spec.Marlowe.Semantics.Next.Arbitrary () -import Test.Hspec (Spec, describe, focus, hspec, it, shouldBe) +import Test.Hspec (Spec, describe, hspec, it, shouldBe) import Test.Hspec.Golden (defaultGolden) import Test.QuickCheck (Arbitrary (..), Gen, elements, genericShrink, listOf, oneof, resize, suchThat) import Test.QuickCheck.Instances () @@ -56,292 +56,291 @@ main = hspec do openAPISpec :: Spec openAPISpec = do - focus do - it "finds no problems with the Marlowe Runtime OpenApi Schema" do - let actual = lintOpenApi $ coerce openApi - expected :: [OpenApiLintIssue] = [] + it "finds no problems with the Marlowe Runtime OpenApi Schema" do + let actual = lintOpenApi $ coerce openApi + expected :: [OpenApiLintIssue] = [] + actual `shouldBe` expected + + describe "lookupType" do + it "test 00" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = mempty + actual = runReader (lookupType input) linterEnv + expected = [] actual `shouldBe` expected - describe "lookupType" do - it "test 00" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = OpenApiLintEnvironment mempty - input :: Schema - input = mempty - actual = runReader (lookupType input) linterEnv - expected = [] - actual `shouldBe` expected - - it "test 01" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = OpenApiLintEnvironment mempty - input :: Schema - input = mempty & type_ ?~ OpenApiBoolean - actual = runReader (lookupType input) linterEnv - expected = [OpenApiBoolean] - actual `shouldBe` expected - - it "test 02" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = OpenApiLintEnvironment mempty - input :: Schema - input = - mempty - & oneOf - ?~ [ Inline (mempty & type_ ?~ OpenApiString) - , Inline (mempty & type_ ?~ OpenApiString) - , Inline (mempty & type_ ?~ OpenApiBoolean) - ] - actual = runReader (lookupType input) linterEnv - expected = [OpenApiString, OpenApiBoolean] - actual `shouldBe` expected - - it "test 03" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = OpenApiLintEnvironment mempty - input :: Schema - input = - mempty - & oneOf - ?~ [ Ref (Reference "mydef") - , Inline (mempty & type_ ?~ OpenApiString) - , Inline (mempty & type_ ?~ OpenApiBoolean) - ] - actual = runReader (lookupType input) linterEnv - expected = [] - actual `shouldBe` expected - - it "test 04" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = - OpenApiLintEnvironment $ - IOHM.fromList - [ ("mydef", mempty & type_ ?~ OpenApiInteger) - ] - input :: Schema - input = - mempty - & oneOf - ?~ [ Ref (Reference "mydef") - , Inline (mempty & type_ ?~ OpenApiString) - , Inline (mempty & type_ ?~ OpenApiBoolean) - ] - actual = runReader (lookupType input) linterEnv - expected = [OpenApiInteger, OpenApiString, OpenApiBoolean] - actual `shouldBe` expected - - describe "lookupFieldType" do - it "test 00" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = OpenApiLintEnvironment mempty - input :: Schema - input = mempty - actual = runReader (lookupFieldType "hey" input) linterEnv - expected = Nothing - actual `shouldBe` expected - - it "test 01" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = OpenApiLintEnvironment mempty - input :: Schema - input = mempty & properties .~ IOHM.fromList [("hey", Inline (mempty & description ?~ "no type!"))] - actual = runReader (lookupFieldType "hey" input) linterEnv - expected = Nothing - actual `shouldBe` expected - - it "test 02" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = OpenApiLintEnvironment mempty - input :: Schema - input = mempty & properties .~ IOHM.fromList [("hey", Inline (mempty & type_ ?~ OpenApiBoolean))] - actual = runReader (lookupFieldType "hey" input) linterEnv - expected = Just [OpenApiBoolean] - actual `shouldBe` expected - - it "test 03" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = OpenApiLintEnvironment mempty - input :: Schema - input = mempty & oneOf ?~ [Inline (mempty & properties .~ IOHM.fromList [])] - actual = runReader (lookupFieldType "hey" input) linterEnv - expected = Nothing - actual `shouldBe` expected - - it "test 04" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = OpenApiLintEnvironment mempty - input :: Schema - input = - mempty & oneOf ?~ [Inline (mempty & properties .~ IOHM.fromList [("hey", Inline (mempty & description ?~ "no type!"))])] - actual = runReader (lookupFieldType "hey" input) linterEnv - expected = Nothing - actual `shouldBe` expected - - it "test 05" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = OpenApiLintEnvironment mempty - input :: Schema - input = - mempty & oneOf ?~ [Inline (mempty & properties .~ IOHM.fromList [("hey", Inline (mempty & type_ ?~ OpenApiBoolean))])] - actual = runReader (lookupFieldType "hey" input) linterEnv - expected = Just [OpenApiBoolean] - actual `shouldBe` expected - - it "test 06" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = OpenApiLintEnvironment mempty - input :: Schema - input = - mempty - & oneOf - ?~ [ Inline - ( mempty - & properties - .~ IOHM.fromList - [ ("hey", Inline (mempty & type_ ?~ OpenApiInteger)) - ] - ) - ] - actual = runReader (lookupFieldType "hey" input) linterEnv - expected = Just [OpenApiInteger] - actual `shouldBe` expected - - it "test 07" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = OpenApiLintEnvironment mempty - input :: Schema - input = - mempty - & oneOf - ?~ [ Inline - ( mempty - & properties - .~ IOHM.fromList - [ ("hey", Inline (mempty & description ?~ "no type!")) - ] - ) - ] - actual = runReader (lookupFieldType "hey" input) linterEnv - expected = Nothing - actual `shouldBe` expected - - it "test 08" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = - OpenApiLintEnvironment $ - IOHM.fromList - [ ("yo", mempty & type_ ?~ OpenApiString) - ] - input :: Schema - input = - mempty - & oneOf - ?~ [ Inline - ( mempty - & properties - .~ IOHM.fromList - [ ("hey", Ref (Reference "yo")) - ] - ) - ] - actual = runReader (lookupFieldType "hey" input) linterEnv - expected = Just [OpenApiString] - actual `shouldBe` expected - - it "test 09" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = - OpenApiLintEnvironment $ - IOHM.fromList - [ ("yo", mempty & type_ ?~ OpenApiString) - , ("sup", mempty & description ?~ "no type!") - ] - input :: Schema - input = - mempty - & oneOf - ?~ [ Inline - ( mempty - & properties - .~ IOHM.fromList - [ ("hey", Ref (Reference "sup")) - ] - ) - ] - actual = runReader (lookupFieldType "hey" input) linterEnv - expected = Nothing - actual `shouldBe` expected - - it "test 10" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = - OpenApiLintEnvironment $ - IOHM.fromList - [ ("yo", mempty & type_ ?~ OpenApiString) - , ("sup", mempty & oneOf ?~ [Ref (Reference "yo")]) - ] - input :: Schema - input = - mempty - & properties - .~ IOHM.fromList - [ ("hey", Ref (Reference "sup")) - ] - actual = runReader (lookupFieldType "hey" input) linterEnv - expected = Just [OpenApiString] - actual `shouldBe` expected - - it "test 11" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = - OpenApiLintEnvironment $ - IOHM.fromList - [ ("yo", mempty & type_ ?~ OpenApiString) - , ("sup", mempty & oneOf ?~ [Ref (Reference "yo")]) - , ("bye", mempty & properties .~ IOHM.fromList [("hey", Inline (mempty & type_ ?~ OpenApiBoolean))]) + it "test 01" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = mempty & type_ ?~ OpenApiBoolean + actual = runReader (lookupType input) linterEnv + expected = [OpenApiBoolean] + actual `shouldBe` expected + + it "test 02" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = + mempty + & oneOf + ?~ [ Inline (mempty & type_ ?~ OpenApiString) + , Inline (mempty & type_ ?~ OpenApiString) + , Inline (mempty & type_ ?~ OpenApiBoolean) + ] + actual = runReader (lookupType input) linterEnv + expected = [OpenApiString, OpenApiBoolean] + actual `shouldBe` expected + + it "test 03" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = + mempty + & oneOf + ?~ [ Ref (Reference "mydef") + , Inline (mempty & type_ ?~ OpenApiString) + , Inline (mempty & type_ ?~ OpenApiBoolean) + ] + actual = runReader (lookupType input) linterEnv + expected = [] + actual `shouldBe` expected + + it "test 04" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = + OpenApiLintEnvironment $ + IOHM.fromList + [ ("mydef", mempty & type_ ?~ OpenApiInteger) + ] + input :: Schema + input = + mempty + & oneOf + ?~ [ Ref (Reference "mydef") + , Inline (mempty & type_ ?~ OpenApiString) + , Inline (mempty & type_ ?~ OpenApiBoolean) + ] + actual = runReader (lookupType input) linterEnv + expected = [OpenApiInteger, OpenApiString, OpenApiBoolean] + actual `shouldBe` expected + + describe "lookupFieldType" do + it "test 00" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = mempty + actual = runReader (lookupFieldType "hey" input) linterEnv + expected = Nothing + actual `shouldBe` expected + + it "test 01" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = mempty & properties .~ IOHM.fromList [("hey", Inline (mempty & description ?~ "no type!"))] + actual = runReader (lookupFieldType "hey" input) linterEnv + expected = Nothing + actual `shouldBe` expected + + it "test 02" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = mempty & properties .~ IOHM.fromList [("hey", Inline (mempty & type_ ?~ OpenApiBoolean))] + actual = runReader (lookupFieldType "hey" input) linterEnv + expected = Just [OpenApiBoolean] + actual `shouldBe` expected + + it "test 03" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = mempty & oneOf ?~ [Inline (mempty & properties .~ IOHM.fromList [])] + actual = runReader (lookupFieldType "hey" input) linterEnv + expected = Nothing + actual `shouldBe` expected + + it "test 04" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = + mempty & oneOf ?~ [Inline (mempty & properties .~ IOHM.fromList [("hey", Inline (mempty & description ?~ "no type!"))])] + actual = runReader (lookupFieldType "hey" input) linterEnv + expected = Nothing + actual `shouldBe` expected + + it "test 05" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = + mempty & oneOf ?~ [Inline (mempty & properties .~ IOHM.fromList [("hey", Inline (mempty & type_ ?~ OpenApiBoolean))])] + actual = runReader (lookupFieldType "hey" input) linterEnv + expected = Just [OpenApiBoolean] + actual `shouldBe` expected + + it "test 06" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = + mempty + & oneOf + ?~ [ Inline + ( mempty + & properties + .~ IOHM.fromList + [ ("hey", Inline (mempty & type_ ?~ OpenApiInteger)) + ] + ) + ] + actual = runReader (lookupFieldType "hey" input) linterEnv + expected = Just [OpenApiInteger] + actual `shouldBe` expected + + it "test 07" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = + mempty + & oneOf + ?~ [ Inline + ( mempty + & properties + .~ IOHM.fromList + [ ("hey", Inline (mempty & description ?~ "no type!")) + ] + ) + ] + actual = runReader (lookupFieldType "hey" input) linterEnv + expected = Nothing + actual `shouldBe` expected + + it "test 08" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = + OpenApiLintEnvironment $ + IOHM.fromList + [ ("yo", mempty & type_ ?~ OpenApiString) + ] + input :: Schema + input = + mempty + & oneOf + ?~ [ Inline + ( mempty + & properties + .~ IOHM.fromList + [ ("hey", Ref (Reference "yo")) + ] + ) + ] + actual = runReader (lookupFieldType "hey" input) linterEnv + expected = Just [OpenApiString] + actual `shouldBe` expected + + it "test 09" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = + OpenApiLintEnvironment $ + IOHM.fromList + [ ("yo", mempty & type_ ?~ OpenApiString) + , ("sup", mempty & description ?~ "no type!") + ] + input :: Schema + input = + mempty + & oneOf + ?~ [ Inline + ( mempty + & properties + .~ IOHM.fromList + [ ("hey", Ref (Reference "sup")) + ] + ) + ] + actual = runReader (lookupFieldType "hey" input) linterEnv + expected = Nothing + actual `shouldBe` expected + + it "test 10" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = + OpenApiLintEnvironment $ + IOHM.fromList + [ ("yo", mempty & type_ ?~ OpenApiString) + , ("sup", mempty & oneOf ?~ [Ref (Reference "yo")]) + ] + input :: Schema + input = + mempty + & properties + .~ IOHM.fromList + [ ("hey", Ref (Reference "sup")) ] - input :: Schema - input = - mempty - & oneOf - ?~ [ Inline (mempty & properties .~ IOHM.fromList [("hey", Ref (Reference "sup"))]) - , Inline (mempty & properties .~ IOHM.fromList [("hey", Ref (Reference "yo"))]) - , Inline (mempty & properties .~ IOHM.fromList [("hey", Inline (mempty & type_ ?~ OpenApiInteger))]) - , Ref (Reference "bye") - ] - actual = runReader (lookupFieldType "hey" input) linterEnv - expected = Just [OpenApiString, OpenApiInteger, OpenApiBoolean] - actual `shouldBe` expected - - describe "schemaRule1Check" do - it "test 00" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = OpenApiLintEnvironment mempty - input :: Schema - input = mempty - actual = runReaderT (schemaRule1Check [] input) linterEnv - expected = [] - actual `shouldBe` expected - - it "test 01" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = OpenApiLintEnvironment mempty - input :: Schema - input = mempty & required .~ ["myfield"] - actual = runReaderT (schemaRule1Check ["huey", "dewey", "louie"] input) linterEnv - expected = - [ OpenApiLintIssue - { trace = "louie/dewey/huey" - , message = "Missing type for required field 'myfield'!" - } - ] - actual `shouldBe` expected - - it "finds no problems with empty schema" do - let actual = lintOpenApi mempty - expected :: [OpenApiLintIssue] = [] + actual = runReader (lookupFieldType "hey" input) linterEnv + expected = Just [OpenApiString] actual `shouldBe` expected + it "test 11" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = + OpenApiLintEnvironment $ + IOHM.fromList + [ ("yo", mempty & type_ ?~ OpenApiString) + , ("sup", mempty & oneOf ?~ [Ref (Reference "yo")]) + , ("bye", mempty & properties .~ IOHM.fromList [("hey", Inline (mempty & type_ ?~ OpenApiBoolean))]) + ] + input :: Schema + input = + mempty + & oneOf + ?~ [ Inline (mempty & properties .~ IOHM.fromList [("hey", Ref (Reference "sup"))]) + , Inline (mempty & properties .~ IOHM.fromList [("hey", Ref (Reference "yo"))]) + , Inline (mempty & properties .~ IOHM.fromList [("hey", Inline (mempty & type_ ?~ OpenApiInteger))]) + , Ref (Reference "bye") + ] + actual = runReader (lookupFieldType "hey" input) linterEnv + expected = Just [OpenApiString, OpenApiInteger, OpenApiBoolean] + actual `shouldBe` expected + + describe "schemaRule1Check" do + it "test 00" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = mempty + actual = runReaderT (schemaRule1Check [] input) linterEnv + expected = [] + actual `shouldBe` expected + + it "test 01" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = mempty & required .~ ["myfield"] + actual = runReaderT (schemaRule1Check ["huey", "dewey", "louie"] input) linterEnv + expected = + [ OpenApiLintIssue + { trace = "louie/dewey/huey" + , message = "Missing type for required field 'myfield'!" + } + ] + actual `shouldBe` expected + + it "finds no problems with empty schema" do + let actual = lintOpenApi mempty + expected :: [OpenApiLintIssue] = [] + actual `shouldBe` expected + validateEveryToJSONWithPatternChecker patternChecker (Proxy @(WrapContractBodies (RetractRuntimeStatus Web.API))) it "Should match the golden test" do defaultGolden "OpenApi" $ From e19d3fd7e0613e76fa09a435149f32a1ccf08c5e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Kihlberg?= Date: Tue, 21 Nov 2023 12:12:11 +0100 Subject: [PATCH 09/20] reorganize linter tests --- marlowe-runtime-web/test/Spec.hs | 559 ++++++++++++++++--------------- 1 file changed, 280 insertions(+), 279 deletions(-) diff --git a/marlowe-runtime-web/test/Spec.hs b/marlowe-runtime-web/test/Spec.hs index 3318147c92..b265f9d332 100644 --- a/marlowe-runtime-web/test/Spec.hs +++ b/marlowe-runtime-web/test/Spec.hs @@ -56,290 +56,291 @@ main = hspec do openAPISpec :: Spec openAPISpec = do - it "finds no problems with the Marlowe Runtime OpenApi Schema" do - let actual = lintOpenApi $ coerce openApi - expected :: [OpenApiLintIssue] = [] - actual `shouldBe` expected - - describe "lookupType" do - it "test 00" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = OpenApiLintEnvironment mempty - input :: Schema - input = mempty - actual = runReader (lookupType input) linterEnv - expected = [] + describe "linter" do + it "finds no problems with empty schema" do + let actual = lintOpenApi mempty + expected :: [OpenApiLintIssue] = [] actual `shouldBe` expected - it "test 01" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = OpenApiLintEnvironment mempty - input :: Schema - input = mempty & type_ ?~ OpenApiBoolean - actual = runReader (lookupType input) linterEnv - expected = [OpenApiBoolean] + it "finds no problems with the Marlowe Runtime OpenApi Schema" do + let actual = lintOpenApi $ coerce openApi + expected :: [OpenApiLintIssue] = [] actual `shouldBe` expected - it "test 02" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = OpenApiLintEnvironment mempty - input :: Schema - input = - mempty - & oneOf - ?~ [ Inline (mempty & type_ ?~ OpenApiString) - , Inline (mempty & type_ ?~ OpenApiString) - , Inline (mempty & type_ ?~ OpenApiBoolean) - ] - actual = runReader (lookupType input) linterEnv - expected = [OpenApiString, OpenApiBoolean] - actual `shouldBe` expected - - it "test 03" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = OpenApiLintEnvironment mempty - input :: Schema - input = - mempty - & oneOf - ?~ [ Ref (Reference "mydef") - , Inline (mempty & type_ ?~ OpenApiString) - , Inline (mempty & type_ ?~ OpenApiBoolean) - ] - actual = runReader (lookupType input) linterEnv - expected = [] - actual `shouldBe` expected - - it "test 04" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = - OpenApiLintEnvironment $ - IOHM.fromList - [ ("mydef", mempty & type_ ?~ OpenApiInteger) - ] - input :: Schema - input = - mempty - & oneOf - ?~ [ Ref (Reference "mydef") - , Inline (mempty & type_ ?~ OpenApiString) - , Inline (mempty & type_ ?~ OpenApiBoolean) - ] - actual = runReader (lookupType input) linterEnv - expected = [OpenApiInteger, OpenApiString, OpenApiBoolean] - actual `shouldBe` expected - - describe "lookupFieldType" do - it "test 00" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = OpenApiLintEnvironment mempty - input :: Schema - input = mempty - actual = runReader (lookupFieldType "hey" input) linterEnv - expected = Nothing - actual `shouldBe` expected - - it "test 01" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = OpenApiLintEnvironment mempty - input :: Schema - input = mempty & properties .~ IOHM.fromList [("hey", Inline (mempty & description ?~ "no type!"))] - actual = runReader (lookupFieldType "hey" input) linterEnv - expected = Nothing - actual `shouldBe` expected - - it "test 02" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = OpenApiLintEnvironment mempty - input :: Schema - input = mempty & properties .~ IOHM.fromList [("hey", Inline (mempty & type_ ?~ OpenApiBoolean))] - actual = runReader (lookupFieldType "hey" input) linterEnv - expected = Just [OpenApiBoolean] - actual `shouldBe` expected - - it "test 03" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = OpenApiLintEnvironment mempty - input :: Schema - input = mempty & oneOf ?~ [Inline (mempty & properties .~ IOHM.fromList [])] - actual = runReader (lookupFieldType "hey" input) linterEnv - expected = Nothing - actual `shouldBe` expected - - it "test 04" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = OpenApiLintEnvironment mempty - input :: Schema - input = - mempty & oneOf ?~ [Inline (mempty & properties .~ IOHM.fromList [("hey", Inline (mempty & description ?~ "no type!"))])] - actual = runReader (lookupFieldType "hey" input) linterEnv - expected = Nothing - actual `shouldBe` expected - - it "test 05" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = OpenApiLintEnvironment mempty - input :: Schema - input = - mempty & oneOf ?~ [Inline (mempty & properties .~ IOHM.fromList [("hey", Inline (mempty & type_ ?~ OpenApiBoolean))])] - actual = runReader (lookupFieldType "hey" input) linterEnv - expected = Just [OpenApiBoolean] - actual `shouldBe` expected - - it "test 06" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = OpenApiLintEnvironment mempty - input :: Schema - input = - mempty - & oneOf - ?~ [ Inline - ( mempty - & properties - .~ IOHM.fromList - [ ("hey", Inline (mempty & type_ ?~ OpenApiInteger)) - ] - ) - ] - actual = runReader (lookupFieldType "hey" input) linterEnv - expected = Just [OpenApiInteger] - actual `shouldBe` expected - - it "test 07" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = OpenApiLintEnvironment mempty - input :: Schema - input = - mempty - & oneOf - ?~ [ Inline - ( mempty - & properties - .~ IOHM.fromList - [ ("hey", Inline (mempty & description ?~ "no type!")) - ] - ) - ] - actual = runReader (lookupFieldType "hey" input) linterEnv - expected = Nothing - actual `shouldBe` expected - - it "test 08" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = - OpenApiLintEnvironment $ - IOHM.fromList - [ ("yo", mempty & type_ ?~ OpenApiString) - ] - input :: Schema - input = - mempty - & oneOf - ?~ [ Inline - ( mempty - & properties - .~ IOHM.fromList - [ ("hey", Ref (Reference "yo")) - ] - ) - ] - actual = runReader (lookupFieldType "hey" input) linterEnv - expected = Just [OpenApiString] - actual `shouldBe` expected - - it "test 09" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = - OpenApiLintEnvironment $ - IOHM.fromList - [ ("yo", mempty & type_ ?~ OpenApiString) - , ("sup", mempty & description ?~ "no type!") - ] - input :: Schema - input = - mempty - & oneOf - ?~ [ Inline - ( mempty - & properties - .~ IOHM.fromList - [ ("hey", Ref (Reference "sup")) - ] - ) - ] - actual = runReader (lookupFieldType "hey" input) linterEnv - expected = Nothing - actual `shouldBe` expected - - it "test 10" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = - OpenApiLintEnvironment $ - IOHM.fromList - [ ("yo", mempty & type_ ?~ OpenApiString) - , ("sup", mempty & oneOf ?~ [Ref (Reference "yo")]) - ] - input :: Schema - input = - mempty - & properties - .~ IOHM.fromList - [ ("hey", Ref (Reference "sup")) + describe "lookupType" do + it "test 00" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = mempty + actual = runReader (lookupType input) linterEnv + expected = [] + actual `shouldBe` expected + + it "test 01" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = mempty & type_ ?~ OpenApiBoolean + actual = runReader (lookupType input) linterEnv + expected = [OpenApiBoolean] + actual `shouldBe` expected + + it "test 02" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = + mempty + & oneOf + ?~ [ Inline (mempty & type_ ?~ OpenApiString) + , Inline (mempty & type_ ?~ OpenApiString) + , Inline (mempty & type_ ?~ OpenApiBoolean) + ] + actual = runReader (lookupType input) linterEnv + expected = [OpenApiString, OpenApiBoolean] + actual `shouldBe` expected + + it "test 03" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = + mempty + & oneOf + ?~ [ Ref (Reference "mydef") + , Inline (mempty & type_ ?~ OpenApiString) + , Inline (mempty & type_ ?~ OpenApiBoolean) + ] + actual = runReader (lookupType input) linterEnv + expected = [] + actual `shouldBe` expected + + it "test 04" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = + OpenApiLintEnvironment $ + IOHM.fromList + [ ("mydef", mempty & type_ ?~ OpenApiInteger) ] - actual = runReader (lookupFieldType "hey" input) linterEnv - expected = Just [OpenApiString] - actual `shouldBe` expected - - it "test 11" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = - OpenApiLintEnvironment $ - IOHM.fromList - [ ("yo", mempty & type_ ?~ OpenApiString) - , ("sup", mempty & oneOf ?~ [Ref (Reference "yo")]) - , ("bye", mempty & properties .~ IOHM.fromList [("hey", Inline (mempty & type_ ?~ OpenApiBoolean))]) - ] - input :: Schema - input = - mempty - & oneOf - ?~ [ Inline (mempty & properties .~ IOHM.fromList [("hey", Ref (Reference "sup"))]) - , Inline (mempty & properties .~ IOHM.fromList [("hey", Ref (Reference "yo"))]) - , Inline (mempty & properties .~ IOHM.fromList [("hey", Inline (mempty & type_ ?~ OpenApiInteger))]) - , Ref (Reference "bye") - ] - actual = runReader (lookupFieldType "hey" input) linterEnv - expected = Just [OpenApiString, OpenApiInteger, OpenApiBoolean] - actual `shouldBe` expected - - describe "schemaRule1Check" do - it "test 00" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = OpenApiLintEnvironment mempty - input :: Schema - input = mempty - actual = runReaderT (schemaRule1Check [] input) linterEnv - expected = [] - actual `shouldBe` expected - - it "test 01" do - let linterEnv :: OpenApiLintEnvironment - linterEnv = OpenApiLintEnvironment mempty - input :: Schema - input = mempty & required .~ ["myfield"] - actual = runReaderT (schemaRule1Check ["huey", "dewey", "louie"] input) linterEnv - expected = - [ OpenApiLintIssue - { trace = "louie/dewey/huey" - , message = "Missing type for required field 'myfield'!" - } - ] - actual `shouldBe` expected - - it "finds no problems with empty schema" do - let actual = lintOpenApi mempty - expected :: [OpenApiLintIssue] = [] - actual `shouldBe` expected + input :: Schema + input = + mempty + & oneOf + ?~ [ Ref (Reference "mydef") + , Inline (mempty & type_ ?~ OpenApiString) + , Inline (mempty & type_ ?~ OpenApiBoolean) + ] + actual = runReader (lookupType input) linterEnv + expected = [OpenApiInteger, OpenApiString, OpenApiBoolean] + actual `shouldBe` expected + + describe "lookupFieldType" do + it "test 00" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = mempty + actual = runReader (lookupFieldType "hey" input) linterEnv + expected = Nothing + actual `shouldBe` expected + + it "test 01" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = mempty & properties .~ IOHM.fromList [("hey", Inline (mempty & description ?~ "no type!"))] + actual = runReader (lookupFieldType "hey" input) linterEnv + expected = Nothing + actual `shouldBe` expected + + it "test 02" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = mempty & properties .~ IOHM.fromList [("hey", Inline (mempty & type_ ?~ OpenApiBoolean))] + actual = runReader (lookupFieldType "hey" input) linterEnv + expected = Just [OpenApiBoolean] + actual `shouldBe` expected + + it "test 03" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = mempty & oneOf ?~ [Inline (mempty & properties .~ IOHM.fromList [])] + actual = runReader (lookupFieldType "hey" input) linterEnv + expected = Nothing + actual `shouldBe` expected + + it "test 04" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = + mempty & oneOf ?~ [Inline (mempty & properties .~ IOHM.fromList [("hey", Inline (mempty & description ?~ "no type!"))])] + actual = runReader (lookupFieldType "hey" input) linterEnv + expected = Nothing + actual `shouldBe` expected + + it "test 05" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = + mempty & oneOf ?~ [Inline (mempty & properties .~ IOHM.fromList [("hey", Inline (mempty & type_ ?~ OpenApiBoolean))])] + actual = runReader (lookupFieldType "hey" input) linterEnv + expected = Just [OpenApiBoolean] + actual `shouldBe` expected + + it "test 06" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = + mempty + & oneOf + ?~ [ Inline + ( mempty + & properties + .~ IOHM.fromList + [ ("hey", Inline (mempty & type_ ?~ OpenApiInteger)) + ] + ) + ] + actual = runReader (lookupFieldType "hey" input) linterEnv + expected = Just [OpenApiInteger] + actual `shouldBe` expected + + it "test 07" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = + mempty + & oneOf + ?~ [ Inline + ( mempty + & properties + .~ IOHM.fromList + [ ("hey", Inline (mempty & description ?~ "no type!")) + ] + ) + ] + actual = runReader (lookupFieldType "hey" input) linterEnv + expected = Nothing + actual `shouldBe` expected + + it "test 08" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = + OpenApiLintEnvironment $ + IOHM.fromList + [ ("yo", mempty & type_ ?~ OpenApiString) + ] + input :: Schema + input = + mempty + & oneOf + ?~ [ Inline + ( mempty + & properties + .~ IOHM.fromList + [ ("hey", Ref (Reference "yo")) + ] + ) + ] + actual = runReader (lookupFieldType "hey" input) linterEnv + expected = Just [OpenApiString] + actual `shouldBe` expected + + it "test 09" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = + OpenApiLintEnvironment $ + IOHM.fromList + [ ("yo", mempty & type_ ?~ OpenApiString) + , ("sup", mempty & description ?~ "no type!") + ] + input :: Schema + input = + mempty + & oneOf + ?~ [ Inline + ( mempty + & properties + .~ IOHM.fromList + [ ("hey", Ref (Reference "sup")) + ] + ) + ] + actual = runReader (lookupFieldType "hey" input) linterEnv + expected = Nothing + actual `shouldBe` expected + + it "test 10" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = + OpenApiLintEnvironment $ + IOHM.fromList + [ ("yo", mempty & type_ ?~ OpenApiString) + , ("sup", mempty & oneOf ?~ [Ref (Reference "yo")]) + ] + input :: Schema + input = + mempty + & properties + .~ IOHM.fromList + [ ("hey", Ref (Reference "sup")) + ] + actual = runReader (lookupFieldType "hey" input) linterEnv + expected = Just [OpenApiString] + actual `shouldBe` expected + + it "test 11" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = + OpenApiLintEnvironment $ + IOHM.fromList + [ ("yo", mempty & type_ ?~ OpenApiString) + , ("sup", mempty & oneOf ?~ [Ref (Reference "yo")]) + , ("bye", mempty & properties .~ IOHM.fromList [("hey", Inline (mempty & type_ ?~ OpenApiBoolean))]) + ] + input :: Schema + input = + mempty + & oneOf + ?~ [ Inline (mempty & properties .~ IOHM.fromList [("hey", Ref (Reference "sup"))]) + , Inline (mempty & properties .~ IOHM.fromList [("hey", Ref (Reference "yo"))]) + , Inline (mempty & properties .~ IOHM.fromList [("hey", Inline (mempty & type_ ?~ OpenApiInteger))]) + , Ref (Reference "bye") + ] + actual = runReader (lookupFieldType "hey" input) linterEnv + expected = Just [OpenApiString, OpenApiInteger, OpenApiBoolean] + actual `shouldBe` expected + + describe "schemaRule1Check" do + it "test 00" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = mempty + actual = runReaderT (schemaRule1Check [] input) linterEnv + expected = [] + actual `shouldBe` expected + + it "test 01" do + let linterEnv :: OpenApiLintEnvironment + linterEnv = OpenApiLintEnvironment mempty + input :: Schema + input = mempty & required .~ ["myfield"] + actual = runReaderT (schemaRule1Check ["huey", "dewey", "louie"] input) linterEnv + expected = + [ OpenApiLintIssue + { trace = "louie/dewey/huey" + , message = "Missing type for required field 'myfield'!" + } + ] + actual `shouldBe` expected validateEveryToJSONWithPatternChecker patternChecker (Proxy @(WrapContractBodies (RetractRuntimeStatus Web.API))) it "Should match the golden test" do From 983d25eb2882e6c875fb4bc53a2619304bc18001 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Kihlberg?= Date: Tue, 21 Nov 2023 12:13:45 +0100 Subject: [PATCH 10/20] Fix missing type definition in OpenApi schema (PLT-8732) --- marlowe-runtime-web/.golden/OpenApi/golden | 3 ++- .../src/Language/Marlowe/Runtime/Web/Orphans.hs | 1 + 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/marlowe-runtime-web/.golden/OpenApi/golden b/marlowe-runtime-web/.golden/OpenApi/golden index a426e48487..0bd278870a 100644 --- a/marlowe-runtime-web/.golden/OpenApi/golden +++ b/marlowe-runtime-web/.golden/OpenApi/golden @@ -2528,7 +2528,8 @@ "required": [ "tx_interval", "tx_inputs" - ] + ], + "type": "object" }, "TransactionOutput": { "description": "Marlowe transaction output.", diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Orphans.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Orphans.hs index 779899ba79..b572a9e673 100644 --- a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Orphans.hs +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Orphans.hs @@ -665,6 +665,7 @@ instance ToSchema V1.TransactionInput where & description ?~ "Marlowe transaction input." & required .~ fmap fst [intervalSchema, inputsSchema] & properties .~ [intervalSchema, inputsSchema] + & type_ ?~ OpenApiObject instance ToSchema V1.TransactionOutput where declareNamedSchema _ = From b92fbe20d6fe102688a8c419dffa4ade54aae247 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Kihlberg?= Date: Tue, 21 Nov 2023 12:19:53 +0100 Subject: [PATCH 11/20] changelog entry --- .../20231121_121737_bjorn.wilhelm.kihlberg_PLT_8555.md | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 marlowe-runtime/changelog.d/20231121_121737_bjorn.wilhelm.kihlberg_PLT_8555.md diff --git a/marlowe-runtime/changelog.d/20231121_121737_bjorn.wilhelm.kihlberg_PLT_8555.md b/marlowe-runtime/changelog.d/20231121_121737_bjorn.wilhelm.kihlberg_PLT_8555.md new file mode 100644 index 0000000000..f0272b8ad3 --- /dev/null +++ b/marlowe-runtime/changelog.d/20231121_121737_bjorn.wilhelm.kihlberg_PLT_8555.md @@ -0,0 +1,3 @@ +### Fixed + +- The `TransactionInput` definition in the generated OpenApi schema for Marlowe Runtime Web is now explicitly typed as an `object`. From 5c9f218020c749b563b90a443339924db98d7f6f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Kihlberg?= Date: Tue, 21 Nov 2023 17:47:14 +0100 Subject: [PATCH 12/20] disable linter tests --- marlowe-runtime-web/test/Spec.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/marlowe-runtime-web/test/Spec.hs b/marlowe-runtime-web/test/Spec.hs index b265f9d332..834133c602 100644 --- a/marlowe-runtime-web/test/Spec.hs +++ b/marlowe-runtime-web/test/Spec.hs @@ -44,7 +44,7 @@ import Servant.API import Servant.OpenApi import Spec.Marlowe.Semantics.Arbitrary () import Spec.Marlowe.Semantics.Next.Arbitrary () -import Test.Hspec (Spec, describe, hspec, it, shouldBe) +import Test.Hspec (Spec, describe, hspec, it, shouldBe, xdescribe) import Test.Hspec.Golden (defaultGolden) import Test.QuickCheck (Arbitrary (..), Gen, elements, genericShrink, listOf, oneof, resize, suchThat) import Test.QuickCheck.Instances () @@ -56,7 +56,7 @@ main = hspec do openAPISpec :: Spec openAPISpec = do - describe "linter" do + xdescribe "linter" do it "finds no problems with empty schema" do let actual = lintOpenApi mempty expected :: [OpenApiLintIssue] = [] From 7357ea9a6538d079c16dd5db3159ed0dddf6ae2e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Kihlberg?= Date: Wed, 22 Nov 2023 11:08:41 +0100 Subject: [PATCH 13/20] lets see if this works --- marlowe-runtime-web/test/Spec.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/marlowe-runtime-web/test/Spec.hs b/marlowe-runtime-web/test/Spec.hs index 834133c602..7c54cbb83b 100644 --- a/marlowe-runtime-web/test/Spec.hs +++ b/marlowe-runtime-web/test/Spec.hs @@ -56,12 +56,12 @@ main = hspec do openAPISpec :: Spec openAPISpec = do - xdescribe "linter" do - it "finds no problems with empty schema" do - let actual = lintOpenApi mempty - expected :: [OpenApiLintIssue] = [] - actual `shouldBe` expected + it "finds no problems with empty schema" do + let actual = lintOpenApi mempty + expected :: [OpenApiLintIssue] = [] + actual `shouldBe` expected + xdescribe "linter" do it "finds no problems with the Marlowe Runtime OpenApi Schema" do let actual = lintOpenApi $ coerce openApi expected :: [OpenApiLintIssue] = [] From a1c6b17a2ec009c12df33db4c6d8737145871bba Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Kihlberg?= Date: Wed, 22 Nov 2023 11:58:25 +0100 Subject: [PATCH 14/20] and what about this? --- marlowe-runtime-web/test/Spec.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/marlowe-runtime-web/test/Spec.hs b/marlowe-runtime-web/test/Spec.hs index 7c54cbb83b..170a4b3f6b 100644 --- a/marlowe-runtime-web/test/Spec.hs +++ b/marlowe-runtime-web/test/Spec.hs @@ -56,10 +56,11 @@ main = hspec do openAPISpec :: Spec openAPISpec = do - it "finds no problems with empty schema" do - let actual = lintOpenApi mempty - expected :: [OpenApiLintIssue] = [] - actual `shouldBe` expected + describe "linter" do + it "finds no problems with empty schema" do + let actual = lintOpenApi mempty + expected :: [OpenApiLintIssue] = [] + actual `shouldBe` expected xdescribe "linter" do it "finds no problems with the Marlowe Runtime OpenApi Schema" do From e110ed3352876eed63233f0ac232c398a17b95f7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Kihlberg?= Date: Wed, 22 Nov 2023 12:06:57 +0100 Subject: [PATCH 15/20] pr driven development --- marlowe-runtime-web/test/Spec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/marlowe-runtime-web/test/Spec.hs b/marlowe-runtime-web/test/Spec.hs index 170a4b3f6b..54a1b8d966 100644 --- a/marlowe-runtime-web/test/Spec.hs +++ b/marlowe-runtime-web/test/Spec.hs @@ -62,12 +62,12 @@ openAPISpec = do expected :: [OpenApiLintIssue] = [] actual `shouldBe` expected - xdescribe "linter" do it "finds no problems with the Marlowe Runtime OpenApi Schema" do let actual = lintOpenApi $ coerce openApi expected :: [OpenApiLintIssue] = [] actual `shouldBe` expected + xdescribe "linter" do describe "lookupType" do it "test 00" do let linterEnv :: OpenApiLintEnvironment From 994a1eb4a15e889ed68cc911256e7fc5c2852cfc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Kihlberg?= Date: Wed, 22 Nov 2023 12:12:53 +0100 Subject: [PATCH 16/20] pr driven development --- marlowe-runtime-web/test/Spec.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/marlowe-runtime-web/test/Spec.hs b/marlowe-runtime-web/test/Spec.hs index 54a1b8d966..daf3f88c6f 100644 --- a/marlowe-runtime-web/test/Spec.hs +++ b/marlowe-runtime-web/test/Spec.hs @@ -67,7 +67,6 @@ openAPISpec = do expected :: [OpenApiLintIssue] = [] actual `shouldBe` expected - xdescribe "linter" do describe "lookupType" do it "test 00" do let linterEnv :: OpenApiLintEnvironment @@ -78,6 +77,8 @@ openAPISpec = do expected = [] actual `shouldBe` expected + xdescribe "linter" do + describe "lookupType" do it "test 01" do let linterEnv :: OpenApiLintEnvironment linterEnv = OpenApiLintEnvironment mempty From d6d152ed34ff45c30e8990b0316fdf7168223cd4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Kihlberg?= Date: Wed, 22 Nov 2023 12:18:21 +0100 Subject: [PATCH 17/20] pr driven development --- marlowe-runtime-web/test/Spec.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/marlowe-runtime-web/test/Spec.hs b/marlowe-runtime-web/test/Spec.hs index daf3f88c6f..5a17627d32 100644 --- a/marlowe-runtime-web/test/Spec.hs +++ b/marlowe-runtime-web/test/Spec.hs @@ -76,9 +76,6 @@ openAPISpec = do actual = runReader (lookupType input) linterEnv expected = [] actual `shouldBe` expected - - xdescribe "linter" do - describe "lookupType" do it "test 01" do let linterEnv :: OpenApiLintEnvironment linterEnv = OpenApiLintEnvironment mempty @@ -137,6 +134,7 @@ openAPISpec = do expected = [OpenApiInteger, OpenApiString, OpenApiBoolean] actual `shouldBe` expected + xdescribe "linter" do describe "lookupFieldType" do it "test 00" do let linterEnv :: OpenApiLintEnvironment From cdf2fb687677bf646fadcd04f618f091dbd1062a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Kihlberg?= Date: Wed, 22 Nov 2023 12:24:02 +0100 Subject: [PATCH 18/20] pr driven development --- marlowe-runtime-web/test/Spec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/marlowe-runtime-web/test/Spec.hs b/marlowe-runtime-web/test/Spec.hs index 5a17627d32..1fee9c715c 100644 --- a/marlowe-runtime-web/test/Spec.hs +++ b/marlowe-runtime-web/test/Spec.hs @@ -134,7 +134,6 @@ openAPISpec = do expected = [OpenApiInteger, OpenApiString, OpenApiBoolean] actual `shouldBe` expected - xdescribe "linter" do describe "lookupFieldType" do it "test 00" do let linterEnv :: OpenApiLintEnvironment @@ -318,6 +317,7 @@ openAPISpec = do expected = Just [OpenApiString, OpenApiInteger, OpenApiBoolean] actual `shouldBe` expected + xdescribe "linter" do describe "schemaRule1Check" do it "test 00" do let linterEnv :: OpenApiLintEnvironment From ff423b7c7174b035d7a5052df1f0fa4a235b9106 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Kihlberg?= Date: Wed, 22 Nov 2023 12:33:16 +0100 Subject: [PATCH 19/20] pr driven development --- marlowe-runtime-web/test/Spec.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/marlowe-runtime-web/test/Spec.hs b/marlowe-runtime-web/test/Spec.hs index 1fee9c715c..3d9430a0bc 100644 --- a/marlowe-runtime-web/test/Spec.hs +++ b/marlowe-runtime-web/test/Spec.hs @@ -317,7 +317,6 @@ openAPISpec = do expected = Just [OpenApiString, OpenApiInteger, OpenApiBoolean] actual `shouldBe` expected - xdescribe "linter" do describe "schemaRule1Check" do it "test 00" do let linterEnv :: OpenApiLintEnvironment @@ -328,6 +327,8 @@ openAPISpec = do expected = [] actual `shouldBe` expected + xdescribe "linter" do + describe "schemaRule1Check" do it "test 01" do let linterEnv :: OpenApiLintEnvironment linterEnv = OpenApiLintEnvironment mempty From 75ee244a952144d744f23cccc59abfe47f4ca99f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Kihlberg?= Date: Wed, 22 Nov 2023 12:40:13 +0100 Subject: [PATCH 20/20] pr driven development --- marlowe-runtime-web/test/Spec.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/marlowe-runtime-web/test/Spec.hs b/marlowe-runtime-web/test/Spec.hs index 3d9430a0bc..7fbefdc322 100644 --- a/marlowe-runtime-web/test/Spec.hs +++ b/marlowe-runtime-web/test/Spec.hs @@ -44,7 +44,7 @@ import Servant.API import Servant.OpenApi import Spec.Marlowe.Semantics.Arbitrary () import Spec.Marlowe.Semantics.Next.Arbitrary () -import Test.Hspec (Spec, describe, hspec, it, shouldBe, xdescribe) +import Test.Hspec (Spec, describe, hspec, it, shouldBe) import Test.Hspec.Golden (defaultGolden) import Test.QuickCheck (Arbitrary (..), Gen, elements, genericShrink, listOf, oneof, resize, suchThat) import Test.QuickCheck.Instances () @@ -327,8 +327,6 @@ openAPISpec = do expected = [] actual `shouldBe` expected - xdescribe "linter" do - describe "schemaRule1Check" do it "test 01" do let linterEnv :: OpenApiLintEnvironment linterEnv = OpenApiLintEnvironment mempty