Merge pull request #747 from input-output-hk/PLT-8555

PLT-8555: OpenAPI linting

marlowe-runtime-web/.golden/OpenApi/golden

@@ -2528,7 +2528,8 @@
                 "required": [
                     "tx_interval",
                     "tx_inputs"
-                ]
+                ],
+                "type": "object"
             },
             "TransactionOutput": {
                 "description": "Marlowe transaction output.",

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,11 +206,14 @@ 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
     , marlowe-runtime-web:{marlowe-runtime-web, server}
     , marlowe-runtime:gen
     , marlowe-test
+    , mtl >=2.2 && <3
     , openapi3 >=3.2 && <4
     , QuickCheck
     , quickcheck-instances

marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/OpenAPI.hs

@@ -1,24 +1,35 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE ViewPatterns #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 -- | This module defines the API and server for serving the Open API
 -- specification.
 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 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
+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)
 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
-import Servant
+import Servant hiding (Param)
 import Servant.OpenApi (toOpenApi)
 import Servant.Pagination
 
@@ -62,6 +73,189 @@ instance ToJSON OpenApiWithEmptySecurity where
 
 type API = "openapi.json" :> Get '[JSON] OpenApiWithEmptySecurity
 
+data OpenApiLintIssue = OpenApiLintIssue
+  { trace :: Text
+  , message :: Text
+  }
+  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
+    schemaDefinitions :: Definitions Schema
+    schemaDefinitions = Optics.view (components . schemas) oa
+
+    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
+      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
+
+    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
+
+    lintSchema :: [Text] -> Schema -> [OpenApiLintIssue]
+    lintSchema stacktrace s = runReaderT (schemaRule1Check stacktrace s) (OpenApiLintEnvironment schemaDefinitions)
+
+    lintParam :: [Text] -> Param -> [OpenApiLintIssue]
+    lintParam stacktrace param = do
+      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
+      lintSchema [definitionName, "schemas", "components"] definitionSchema
+
+    pathParametersLints :: [OpenApiLintIssue]
+    pathParametersLints = do
+      (Text.pack -> path, endpoint) <- toList $ Optics.view paths oa
+      param :: Param <- Maybe.mapMaybe paramRef $ Optics.view parameters endpoint
+      lintParam ["parameters", path, "paths"] param
+
+    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
+            ]
+
+      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 (responses . default_) 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 =
   OpenApiWithEmptySecurity $

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 _ =