mirror of
https://github.com/ilyakooo0/compaREST.git
synced 2024-09-11 06:25:40 +03:00
Structural compatibility (#49)
* First very rough draft of structural compatibility * Horrible schema hack * absurdIssue -> structuralIssue * Added some structural comparing * Added yet more structural comparisons * dropped ProdConsEqHList * Bumped resolver * Nonrecursive schema
This commit is contained in:
parent
8687e5fbac
commit
cbfeeedc1e
@ -53,6 +53,7 @@ common common-options
|
||||
, unordered-containers
|
||||
, vector
|
||||
, yaml
|
||||
, hashable
|
||||
|
||||
default-extensions: ApplicativeDo
|
||||
, BangPatterns
|
||||
@ -93,6 +94,7 @@ common common-options
|
||||
, UndecidableInstances
|
||||
, ViewPatterns
|
||||
, QuantifiedConstraints
|
||||
, DefaultSignatures
|
||||
|
||||
library
|
||||
import: common-options
|
||||
@ -121,6 +123,9 @@ library
|
||||
, OpenAPI.Checker.Validate.SecurityRequirement
|
||||
, OpenAPI.Checker.Validate.Server
|
||||
, OpenAPI.Checker.Validate.Sums
|
||||
, OpenAPI.Checker.Validate.Header
|
||||
, OpenAPI.Checker.Validate.Link
|
||||
, OpenAPI.Checker.Common
|
||||
|
||||
executable openapi-diff
|
||||
import: common-options
|
||||
|
@ -43,3 +43,9 @@ instance
|
||||
|
||||
singletonH :: a -> HList '[a]
|
||||
singletonH a = a `HCons` HNil
|
||||
|
||||
instance Eq (HList '[]) where
|
||||
HNil == HNil = True
|
||||
|
||||
instance (Eq x, Eq (HList xs)) => Eq (HList (x ': xs)) where
|
||||
(HCons x xs) == (HCons y ys) = x == y && xs == ys
|
||||
|
@ -26,6 +26,7 @@ data BehaviorLevel
|
||||
PayloadLevel
|
||||
| SchemaLevel
|
||||
| TypedSchemaLevel
|
||||
| LinkLevel
|
||||
|
||||
class (Ord (Behave a b), Show (Behave a b))
|
||||
=> Behavable (a :: BehaviorLevel) (b :: BehaviorLevel) where
|
||||
|
10
src/OpenAPI/Checker/Common.hs
Normal file
10
src/OpenAPI/Checker/Common.hs
Normal file
@ -0,0 +1,10 @@
|
||||
module OpenAPI.Checker.Common
|
||||
( zipAll
|
||||
)
|
||||
where
|
||||
|
||||
zipAll :: [a] -> [b] -> Maybe [(a, b)]
|
||||
zipAll [] [] = Just []
|
||||
zipAll (x : xs) (y : ys) = ((x, y) :) <$> zipAll xs ys
|
||||
zipAll (_ : _) [] = Nothing
|
||||
zipAll [] (_ : _) = Nothing
|
@ -1,13 +1,16 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module OpenAPI.Checker.References
|
||||
( Step (..)
|
||||
, dereference
|
||||
)
|
||||
where
|
||||
|
||||
import Data.HList
|
||||
import qualified Data.HashMap.Strict.InsOrd as IOHM
|
||||
import Data.Maybe
|
||||
import Data.OpenApi
|
||||
import qualified Data.OpenApi.Schema.Generator as G
|
||||
import Data.Typeable
|
||||
import OpenAPI.Checker.Orphans ()
|
||||
import OpenAPI.Checker.Subtree
|
||||
@ -26,7 +29,25 @@ dereference
|
||||
-> Traced (Referenced a)
|
||||
-> Traced a
|
||||
dereference defs x = case extract x of
|
||||
Inline a
|
||||
-> traced (ask x >>> step InlineStep) a
|
||||
Ref r@(Reference ref)
|
||||
-> traced (ask defs >>> step (ReferencedStep r)) (fromJust $ IOHM.lookup ref $ extract defs)
|
||||
Inline a ->
|
||||
traced (ask x >>> step InlineStep) a
|
||||
Ref r@(Reference ref) ->
|
||||
traced (ask defs >>> step (ReferencedStep r)) (fromJust $ IOHM.lookup ref $ extract defs)
|
||||
|
||||
instance Subtree a => Subtree (Referenced a) where
|
||||
type CheckEnv (Referenced a) = ProdCons (Traced (Definitions a)) ': CheckEnv a
|
||||
type SubtreeLevel (Referenced a) = SubtreeLevel a
|
||||
|
||||
checkStructuralCompatibility env pc' = do
|
||||
let pc = do
|
||||
x <- pc'
|
||||
defs <- extract <$> getH @(ProdCons (Traced (Definitions a))) env
|
||||
pure (G.dereference defs x)
|
||||
checkStructuralCompatibility env pc
|
||||
|
||||
checkSemanticCompatibility env bhv pc' = do
|
||||
let pc = do
|
||||
x <- pc'
|
||||
defs <- getH @(ProdCons (Traced (Definitions a))) env
|
||||
pure (dereference defs x)
|
||||
checkCompatibility env bhv pc
|
||||
|
@ -1,3 +1,5 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module OpenAPI.Checker.Subtree
|
||||
( Steppable (..)
|
||||
, Trace
|
||||
@ -6,17 +8,27 @@ module OpenAPI.Checker.Subtree
|
||||
, pattern Traced
|
||||
, traced
|
||||
, Subtree (..)
|
||||
, checkCompatibility
|
||||
, CompatM (..)
|
||||
, CompatFormula'
|
||||
, CompatFormula
|
||||
, SemanticCompatFormula
|
||||
, ProdCons (..)
|
||||
, HasUnsupportedFeature (..)
|
||||
, swapProdCons
|
||||
, runCompatFormula
|
||||
, issueAt
|
||||
, anyOfAt
|
||||
, structuralIssue
|
||||
, memo
|
||||
|
||||
-- * Structural helpers
|
||||
, structuralMaybe
|
||||
, structuralMaybeWith
|
||||
, structuralEq
|
||||
, iohmStructural
|
||||
, iohmStructuralWith
|
||||
, structuralList
|
||||
|
||||
-- * Reexports
|
||||
, (>>>)
|
||||
, (<<<)
|
||||
@ -30,11 +42,15 @@ where
|
||||
import Control.Comonad.Env
|
||||
import Control.Monad.Identity
|
||||
import Control.Monad.State
|
||||
import Data.Foldable
|
||||
import Data.Functor.Compose
|
||||
import Data.HList
|
||||
import qualified Data.HashMap.Strict.InsOrd as IOHM
|
||||
import Data.Hashable
|
||||
import Data.Kind
|
||||
import Data.Monoid
|
||||
import Data.OpenApi
|
||||
import qualified Data.Set as S
|
||||
import Data.Typeable
|
||||
import OpenAPI.Checker.Behavior
|
||||
import OpenAPI.Checker.Formula
|
||||
@ -89,18 +105,97 @@ newtype CompatM a = CompatM
|
||||
|
||||
type CompatFormula' q f r = Compose CompatM (FormulaF q f r)
|
||||
|
||||
type CompatFormula = CompatFormula' Behave AnIssue 'APILevel
|
||||
type SemanticCompatFormula = CompatFormula' Behave AnIssue 'APILevel
|
||||
|
||||
type StructuralCompatFormula = CompatFormula' UnitQuiver Proxy ()
|
||||
|
||||
data UnitQuiver a b where
|
||||
UnitQuiver :: UnitQuiver () ()
|
||||
|
||||
deriving stock instance Eq (UnitQuiver a b)
|
||||
|
||||
deriving stock instance Ord (UnitQuiver a b)
|
||||
|
||||
deriving stock instance Show (UnitQuiver a b)
|
||||
|
||||
class (Typeable t, Issuable (SubtreeLevel t)) => Subtree (t :: Type) where
|
||||
type CheckEnv t :: [Type]
|
||||
type SubtreeLevel t :: BehaviorLevel
|
||||
|
||||
checkCompatibility
|
||||
:: HasAll (CheckEnv t) xs
|
||||
checkStructuralCompatibility
|
||||
:: (HasAll (CheckEnv t) xs)
|
||||
=> HList xs
|
||||
-> ProdCons t
|
||||
-> StructuralCompatFormula ()
|
||||
|
||||
checkSemanticCompatibility
|
||||
:: (HasAll (CheckEnv t) xs)
|
||||
=> HList xs
|
||||
-> Behavior (SubtreeLevel t)
|
||||
-> ProdCons (Traced t)
|
||||
-> CompatFormula ()
|
||||
-> SemanticCompatFormula ()
|
||||
|
||||
checkCompatibility
|
||||
:: (HasAll (CheckEnv t) xs, Subtree t)
|
||||
=> HList xs
|
||||
-> Behavior (SubtreeLevel t)
|
||||
-> ProdCons (Traced t)
|
||||
-> SemanticCompatFormula ()
|
||||
checkCompatibility e bhv pc =
|
||||
case runCompatFormula $ checkStructuralCompatibility e $ fmap extract pc of
|
||||
Left _ -> checkSemanticCompatibility e bhv pc
|
||||
Right () -> pure ()
|
||||
|
||||
structuralMaybe
|
||||
:: (Subtree a, HasAll (CheckEnv a) xs)
|
||||
=> HList xs
|
||||
-> ProdCons (Maybe a)
|
||||
-> StructuralCompatFormula ()
|
||||
structuralMaybe e = structuralMaybeWith (checkStructuralCompatibility e)
|
||||
|
||||
structuralMaybeWith
|
||||
:: (ProdCons a -> StructuralCompatFormula ())
|
||||
-> ProdCons (Maybe a)
|
||||
-> StructuralCompatFormula ()
|
||||
structuralMaybeWith f (ProdCons (Just a) (Just b)) = f $ ProdCons a b
|
||||
structuralMaybeWith _ (ProdCons Nothing Nothing) = pure ()
|
||||
structuralMaybeWith _ _ = structuralIssue
|
||||
|
||||
structuralList
|
||||
:: (Subtree a, HasAll (CheckEnv a) xs)
|
||||
=> HList xs -> ProdCons [a] -> StructuralCompatFormula ()
|
||||
structuralList _ (ProdCons [] []) = pure ()
|
||||
structuralList e (ProdCons (a:aa) (b:bb)) = do
|
||||
checkStructuralCompatibility e $ ProdCons a b
|
||||
structuralList e $ ProdCons aa bb
|
||||
pure ()
|
||||
structuralList _ _ = structuralIssue
|
||||
|
||||
structuralEq :: Eq a => ProdCons a -> StructuralCompatFormula ()
|
||||
structuralEq (ProdCons a b) = if a == b then pure () else structuralIssue
|
||||
|
||||
iohmStructural
|
||||
:: (HasAll (CheckEnv v) (k ': xs), Ord k, Subtree v, Hashable k)
|
||||
=> HList xs
|
||||
-> ProdCons (IOHM.InsOrdHashMap k v)
|
||||
-> StructuralCompatFormula ()
|
||||
iohmStructural e =
|
||||
iohmStructuralWith (\k -> checkStructuralCompatibility (k `HCons` e))
|
||||
|
||||
iohmStructuralWith
|
||||
:: (Ord k, Hashable k)
|
||||
=> (k -> ProdCons v -> StructuralCompatFormula ())
|
||||
-> ProdCons (IOHM.InsOrdHashMap k v)
|
||||
-> StructuralCompatFormula ()
|
||||
iohmStructuralWith f pc = do
|
||||
let ProdCons pEKeys cEKeys = S.fromList . IOHM.keys <$> pc
|
||||
if pEKeys == cEKeys
|
||||
then
|
||||
for_
|
||||
pEKeys
|
||||
(\eKey ->
|
||||
f eKey $ IOHM.lookupDefault (error "impossible") eKey <$> pc)
|
||||
else structuralIssue
|
||||
|
||||
class HasUnsupportedFeature x where
|
||||
hasUnsupportedFeature :: x -> Bool
|
||||
@ -137,6 +232,9 @@ runCompatFormula (Compose f) =
|
||||
issueAt :: Issuable l => Paths q r l -> Issue l -> CompatFormula' q AnIssue r a
|
||||
issueAt xs issue = Compose $ pure $ anError $ AnItem xs $ AnIssue issue
|
||||
|
||||
structuralIssue :: StructuralCompatFormula a
|
||||
structuralIssue = Compose $ pure $ anError $ AnItem (step UnitQuiver) Proxy
|
||||
|
||||
anyOfAt
|
||||
:: Issuable l
|
||||
=> Paths q r l
|
||||
|
57
src/OpenAPI/Checker/Validate/Header.hs
Normal file
57
src/OpenAPI/Checker/Validate/Header.hs
Normal file
@ -0,0 +1,57 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module OpenAPI.Checker.Validate.Header
|
||||
(
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Foldable
|
||||
import Data.Functor
|
||||
import Data.Maybe
|
||||
import Data.OpenApi
|
||||
import OpenAPI.Checker.Behavior
|
||||
import OpenAPI.Checker.References ()
|
||||
import OpenAPI.Checker.Subtree
|
||||
import OpenAPI.Checker.Validate.Schema ()
|
||||
|
||||
instance Subtree Header where
|
||||
type SubtreeLevel Header = 'HeaderLevel
|
||||
type CheckEnv Header = '[ProdCons (Traced (Definitions Schema))]
|
||||
checkStructuralCompatibility env pc = do
|
||||
structuralEq $ _headerRequired <$> pc
|
||||
structuralEq $ _headerAllowEmptyValue <$> pc
|
||||
structuralEq $ _headerExplode <$> pc
|
||||
structuralMaybe env $ _headerSchema <$> pc
|
||||
pure ()
|
||||
checkSemanticCompatibility env beh (ProdCons p c) = do
|
||||
if (fromMaybe False $ _headerRequired $ extract c) && not (fromMaybe False $ _headerRequired $ extract p)
|
||||
then issueAt beh RequiredHeaderMissing
|
||||
else pure ()
|
||||
if not (fromMaybe False $ _headerAllowEmptyValue $ extract c) && (fromMaybe False $ _headerAllowEmptyValue $ extract p)
|
||||
then issueAt beh NonEmptyHeaderRequired
|
||||
else pure ()
|
||||
for_ (tracedSchema c) $ \consRef ->
|
||||
case tracedSchema p of
|
||||
Nothing -> issueAt beh HeaderSchemaRequired
|
||||
Just prodRef -> checkCompatibility env (beh >>> step InSchema) (ProdCons prodRef consRef)
|
||||
pure ()
|
||||
|
||||
instance Steppable Header (Referenced Schema) where
|
||||
data Step Header (Referenced Schema) = HeaderSchema
|
||||
deriving stock (Eq, Ord, Show)
|
||||
|
||||
tracedSchema :: Traced Header -> Maybe (Traced (Referenced Schema))
|
||||
tracedSchema hdr = _headerSchema (extract hdr) <&> traced (ask hdr >>> step HeaderSchema)
|
||||
|
||||
instance Issuable 'HeaderLevel where
|
||||
data Issue 'HeaderLevel
|
||||
= RequiredHeaderMissing
|
||||
| NonEmptyHeaderRequired
|
||||
| HeaderSchemaRequired
|
||||
deriving stock (Eq, Ord, Show)
|
||||
issueIsUnsupported _ = False
|
||||
|
||||
instance Behavable 'HeaderLevel 'SchemaLevel where
|
||||
data Behave 'HeaderLevel 'SchemaLevel
|
||||
= InSchema
|
||||
deriving stock (Eq, Ord, Show)
|
20
src/OpenAPI/Checker/Validate/Link.hs
Normal file
20
src/OpenAPI/Checker/Validate/Link.hs
Normal file
@ -0,0 +1,20 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module OpenAPI.Checker.Validate.Link () where
|
||||
|
||||
import Data.OpenApi
|
||||
import OpenAPI.Checker.Behavior
|
||||
import OpenAPI.Checker.Subtree
|
||||
|
||||
instance Subtree Link where
|
||||
type SubtreeLevel Link = 'LinkLevel
|
||||
type CheckEnv Link = '[]
|
||||
checkStructuralCompatibility _ _ = structuralIssue
|
||||
checkSemanticCompatibility _ bhv _ = issueAt bhv LinksUnsupported
|
||||
|
||||
instance Issuable 'LinkLevel where
|
||||
data Issue 'LinkLevel
|
||||
= LinksUnsupported
|
||||
deriving (Eq, Ord, Show)
|
||||
issueIsUnsupported = \case
|
||||
LinksUnsupported -> True
|
@ -17,6 +17,8 @@ import OpenAPI.Checker.Behavior
|
||||
import OpenAPI.Checker.Subtree
|
||||
import OpenAPI.Checker.Validate.Products
|
||||
import OpenAPI.Checker.Validate.Schema ()
|
||||
import OpenAPI.Checker.Validate.Header ()
|
||||
|
||||
|
||||
tracedSchema :: Traced MediaTypeObject -> Maybe (Traced (Referenced Schema))
|
||||
tracedSchema mto = _mediaTypeObjectSchema (extract mto) <&> traced (ask mto >>> step MediaTypeSchema)
|
||||
@ -47,8 +49,14 @@ instance Subtree MediaTypeObject where
|
||||
type CheckEnv MediaTypeObject =
|
||||
'[ MediaType
|
||||
, ProdCons (Traced (Definitions Schema))
|
||||
, ProdCons (Traced (Definitions Header))
|
||||
]
|
||||
checkCompatibility env beh prodCons@(ProdCons p c) = do
|
||||
checkStructuralCompatibility env pc = do
|
||||
structuralMaybe env $ _mediaTypeObjectSchema <$> pc
|
||||
structuralEq $ _mediaTypeObjectExample <$> pc
|
||||
iohmStructural env $ _mediaTypeObjectEncoding <$> pc
|
||||
pure ()
|
||||
checkSemanticCompatibility env beh prodCons@(ProdCons p c) = do
|
||||
if | "multipart" == mainType mediaType -> checkEncoding
|
||||
| "application" == mainType mediaType &&
|
||||
"x-www-form-urlencoded" == subType mediaType -> checkEncoding
|
||||
@ -74,14 +82,27 @@ instance Subtree MediaTypeObject where
|
||||
, required = True } )
|
||||
encProdCons = getEncoding <$> prodCons
|
||||
in checkProducts beh MediaEncodingMissing
|
||||
(const $ checkCompatibility HNil beh) encProdCons
|
||||
(const $ checkCompatibility env beh) encProdCons
|
||||
|
||||
instance Subtree Encoding where
|
||||
type SubtreeLevel Encoding = 'PayloadLevel
|
||||
type CheckEnv Encoding = '[]
|
||||
-- FIXME: Support only JSON body for now. Then Encoding is checked only for
|
||||
-- multipart/form-url-encoded
|
||||
checkCompatibility _env beh _pc =
|
||||
type
|
||||
CheckEnv Encoding =
|
||||
'[ ProdCons (Traced (Definitions Header))
|
||||
, ProdCons (Traced (Definitions Schema))
|
||||
]
|
||||
checkStructuralCompatibility env pc = do
|
||||
structuralEq $ _encodingContentType <$> pc
|
||||
iohmStructural env $ _encodingHeaders <$> pc
|
||||
structuralEq $ _encodingStyle <$> pc
|
||||
structuralEq $ _encodingExplode <$> pc
|
||||
structuralEq $ _encodingAllowReserved <$> pc
|
||||
pure ()
|
||||
|
||||
-- FIXME: Support only JSON body for now. Then Encoding is checked only for
|
||||
-- multipart/form-url-encoded
|
||||
-- https://github.com/typeable/openapi-diff/issues/54
|
||||
checkSemanticCompatibility _env beh _pc =
|
||||
issueAt beh EncodingNotSupported
|
||||
|
||||
instance Steppable MediaTypeObject (Referenced Schema) where
|
||||
|
@ -43,10 +43,16 @@ tracedSchemas :: Traced OpenApi -> Traced (Definitions Schema)
|
||||
tracedSchemas oa = traced (ask oa >>> step ComponentsSchema)
|
||||
(_componentsSchemas . _openApiComponents . extract $ oa)
|
||||
|
||||
tracedLinks :: Traced OpenApi -> Traced (Definitions Link)
|
||||
tracedLinks oa = traced (ask oa >>> step ComponentsLink)
|
||||
(_componentsLinks . _openApiComponents . extract $ oa)
|
||||
|
||||
instance Subtree OpenApi where
|
||||
type SubtreeLevel OpenApi = 'APILevel
|
||||
type CheckEnv OpenApi = '[]
|
||||
checkCompatibility _ beh prodCons = do
|
||||
-- There is no real reason to do a proper implementation
|
||||
checkStructuralCompatibility _ _ = structuralIssue
|
||||
checkSemanticCompatibility _ beh prodCons = do
|
||||
checkCompatibility @ProcessedPathItems
|
||||
((tracedRequestBodies <$> prodCons)
|
||||
`HCons` (tracedParameters <$> prodCons)
|
||||
@ -55,6 +61,7 @@ instance Subtree OpenApi where
|
||||
`HCons` (tracedHeaders <$> prodCons)
|
||||
`HCons` (tracedSchemas <$> prodCons)
|
||||
`HCons` (_openApiServers . extract <$> prodCons)
|
||||
`HCons` (tracedLinks <$> prodCons)
|
||||
`HCons` HNil)
|
||||
beh (tracedPaths <$> prodCons)
|
||||
|
||||
@ -85,3 +92,7 @@ instance Steppable OpenApi (Definitions Header) where
|
||||
instance Steppable OpenApi (Definitions Schema) where
|
||||
data Step OpenApi (Definitions Schema) = ComponentsSchema
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance Steppable OpenApi (Definitions Link) where
|
||||
data Step OpenApi (Definitions Link) = ComponentsLink
|
||||
deriving (Eq, Ord, Show)
|
||||
|
@ -1,12 +1,12 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
{-# OPTIONS_GHC -Wno-name-shadowing #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module OpenAPI.Checker.Validate.Operation
|
||||
( MatchedOperation (..)
|
||||
, OperationMethod(..)
|
||||
, OperationMethod (..)
|
||||
, pathItemMethod
|
||||
) where
|
||||
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Foldable as F
|
||||
import Data.Functor
|
||||
@ -15,8 +15,10 @@ import qualified Data.List as L
|
||||
import Data.Map.Strict as M
|
||||
import Data.Maybe
|
||||
import Data.OpenApi
|
||||
import qualified Data.OpenApi.Schema.Generator as G
|
||||
import Data.Text (Text)
|
||||
import OpenAPI.Checker.Behavior
|
||||
import OpenAPI.Checker.Common
|
||||
import OpenAPI.Checker.References
|
||||
import OpenAPI.Checker.Subtree
|
||||
import OpenAPI.Checker.Validate.MediaTypeObject
|
||||
@ -28,11 +30,11 @@ import OpenAPI.Checker.Validate.Server ()
|
||||
|
||||
data MatchedOperation = MatchedOperation
|
||||
{ operation :: !Operation
|
||||
, pathParams :: ![Traced Param]
|
||||
-- ^ Params from the PathItem
|
||||
, getPathFragments :: !([Traced Param] -> [Traced PathFragmentParam])
|
||||
-- ^ Path fragments traced from PathItem. Takes full list of
|
||||
-- operation-specific parameters
|
||||
, -- | Params from the PathItem
|
||||
pathParams :: ![Traced Param]
|
||||
, -- | Path fragments traced from PathItem. Takes full list of
|
||||
-- operation-specific parameters
|
||||
getPathFragments :: !([Traced Param] -> [Traced PathFragmentParam])
|
||||
}
|
||||
|
||||
type ParamKey = (ParamLocation, Text)
|
||||
@ -43,32 +45,32 @@ paramKey param = (_paramIn param, _paramName param)
|
||||
tracedParameters :: Traced MatchedOperation -> [Traced (Referenced Param)]
|
||||
tracedParameters oper =
|
||||
[ traced (ask oper >>> step (OperationParamsStep i)) x
|
||||
| (i, x) <- zip [0..] $ _operationParameters . operation $ extract oper
|
||||
| (i, x) <- zip [0 ..] $ _operationParameters . operation $ extract oper
|
||||
]
|
||||
|
||||
tracedRequestBody :: Traced MatchedOperation -> Maybe (Traced (Referenced RequestBody))
|
||||
tracedRequestBody oper = _operationRequestBody (operation $ extract oper) <&> traced (ask oper >>> step OperationRequestBodyStep)
|
||||
|
||||
tracedResponses :: Traced MatchedOperation -> Traced Responses
|
||||
tracedResponses oper = traced (ask oper >>> step OperationResponsesStep)
|
||||
$ _operationResponses . operation $ extract oper
|
||||
tracedResponses oper =
|
||||
traced (ask oper >>> step OperationResponsesStep) $
|
||||
_operationResponses . operation $ extract oper
|
||||
|
||||
tracedSecurity :: Traced MatchedOperation -> [Traced SecurityRequirement]
|
||||
tracedSecurity oper =
|
||||
[ traced (ask oper >>> step (OperationSecurityRequirementStep i)) x
|
||||
| (i, x) <- zip [0..] $ _operationSecurity . operation $ extract oper
|
||||
| (i, x) <- zip [0 ..] $ _operationSecurity . operation $ extract oper
|
||||
]
|
||||
|
||||
-- FIXME: https://github.com/typeable/openapi-diff/issues/28
|
||||
tracedServers
|
||||
getServers
|
||||
:: [Server] -- ^ Servers from env
|
||||
-> Traced MatchedOperation
|
||||
-> Traced [Server]
|
||||
tracedServers env oper =
|
||||
traced (ask oper >>> step OperationServersStep) $
|
||||
case _operationServers . operation $ extract oper of
|
||||
[] -> env
|
||||
ss -> ss
|
||||
-> MatchedOperation
|
||||
-> [Server]
|
||||
getServers env oper =
|
||||
case _operationServers . operation $ oper of
|
||||
[] -> env
|
||||
ss -> ss
|
||||
|
||||
instance Behavable 'OperationLevel 'PathFragmentLevel where
|
||||
data Behave 'OperationLevel 'PathFragmentLevel
|
||||
@ -83,16 +85,42 @@ instance Behavable 'OperationLevel 'RequestLevel where
|
||||
|
||||
instance Subtree MatchedOperation where
|
||||
type SubtreeLevel MatchedOperation = 'OperationLevel
|
||||
type CheckEnv MatchedOperation =
|
||||
'[ ProdCons (Traced (Definitions Param))
|
||||
, ProdCons (Traced (Definitions RequestBody))
|
||||
, ProdCons (Traced (Definitions SecurityScheme))
|
||||
, ProdCons (Traced (Definitions Response))
|
||||
, ProdCons (Traced (Definitions Header))
|
||||
, ProdCons (Traced (Definitions Schema))
|
||||
, ProdCons [Server]
|
||||
]
|
||||
checkCompatibility env beh prodCons = do
|
||||
type
|
||||
CheckEnv MatchedOperation =
|
||||
'[ ProdCons (Traced (Definitions Param))
|
||||
, ProdCons (Traced (Definitions RequestBody))
|
||||
, ProdCons (Traced (Definitions SecurityScheme))
|
||||
, ProdCons (Traced (Definitions Response))
|
||||
, ProdCons (Traced (Definitions Header))
|
||||
, ProdCons (Traced (Definitions Schema))
|
||||
, ProdCons [Server]
|
||||
, ProdCons (Traced (Definitions Link))
|
||||
]
|
||||
checkStructuralCompatibility env pc = do
|
||||
let pParams :: ProdCons [Param]
|
||||
pParams = do
|
||||
defs <- extract <$> getH @(ProdCons (Traced (Definitions Param))) env
|
||||
op' <- _operationParameters . operation <$> pc
|
||||
pp <- fmap extract . pathParams <$> pc
|
||||
pure $
|
||||
let o = M.fromList $ do
|
||||
param <- G.dereference defs <$> op'
|
||||
let key = paramKey param
|
||||
pure (key, param)
|
||||
p = M.fromList $ do
|
||||
param <- pp
|
||||
pure (paramKey param, param)
|
||||
in M.elems $ o <> p
|
||||
case zipAll (producer pParams) (consumer pParams) of
|
||||
Nothing -> structuralIssue
|
||||
Just xs -> for_ xs $ \(p, c) -> checkStructuralCompatibility env $ ProdCons p c
|
||||
structuralMaybe env $ _operationRequestBody . operation <$> pc
|
||||
checkStructuralCompatibility env $ _operationResponses . operation <$> pc
|
||||
checkStructuralCompatibility env $ getServers <$> getH env <*> pc
|
||||
-- TODO: Callbacks
|
||||
-- TODO: Security
|
||||
pure ()
|
||||
checkSemanticCompatibility env beh prodCons = do
|
||||
checkParameters
|
||||
checkRequestBodies
|
||||
checkResponses
|
||||
@ -102,97 +130,103 @@ instance Subtree MatchedOperation where
|
||||
pure ()
|
||||
where
|
||||
checkParameters = do
|
||||
let
|
||||
-- Merged parameters got from Operation and PathItem in one
|
||||
-- place. First element is path params, second is non-path params
|
||||
tracedParams :: ProdCons ([Traced Param], [Traced Param])
|
||||
tracedParams = getParams <$> paramDefs <*> prodCons
|
||||
getParams defs mp =
|
||||
let
|
||||
operationParamsMap :: Map ParamKey (Traced Param)
|
||||
operationParamsMap = M.fromList $ do
|
||||
paramRef <- tracedParameters mp
|
||||
let
|
||||
param = dereference defs paramRef
|
||||
key = paramKey . extract $ param
|
||||
pure (key, param)
|
||||
pathParamsMap :: Map ParamKey (Traced Param)
|
||||
pathParamsMap = M.fromList $ do
|
||||
param <- pathParams . extract $ mp
|
||||
pure (paramKey . extract $ param, param)
|
||||
params = M.elems $ M.union operationParamsMap pathParamsMap -- We prefer params from Operation
|
||||
splitted = L.partition
|
||||
(\p -> (_paramIn . extract $ p) == ParamPath) params
|
||||
in splitted
|
||||
let -- Merged parameters got from Operation and PathItem in one
|
||||
-- place. First element is path params, second is non-path params
|
||||
tracedParams :: ProdCons ([Traced Param], [Traced Param])
|
||||
tracedParams = getParams <$> paramDefs <*> prodCons
|
||||
getParams defs mp =
|
||||
let operationParamsMap :: Map ParamKey (Traced Param)
|
||||
operationParamsMap = M.fromList $ do
|
||||
paramRef <- tracedParameters mp
|
||||
let param = dereference defs paramRef
|
||||
key = paramKey . extract $ param
|
||||
pure (key, param)
|
||||
pathParamsMap :: Map ParamKey (Traced Param)
|
||||
pathParamsMap = M.fromList $ do
|
||||
param <- pathParams . extract $ mp
|
||||
pure (paramKey . extract $ param, param)
|
||||
params = M.elems $ M.union operationParamsMap pathParamsMap -- We prefer params from Operation
|
||||
splitted =
|
||||
L.partition
|
||||
(\p -> (_paramIn . extract $ p) == ParamPath)
|
||||
params
|
||||
in splitted
|
||||
checkNonPathParams $ snd <$> tracedParams
|
||||
checkPathParams $ fst <$> tracedParams
|
||||
pure ()
|
||||
checkNonPathParams :: ProdCons [Traced Param] -> CompatFormula ()
|
||||
checkNonPathParams :: ProdCons [Traced Param] -> SemanticCompatFormula ()
|
||||
checkNonPathParams params = do
|
||||
let
|
||||
elements = getEls <$> params
|
||||
getEls params = M.fromList $ do
|
||||
p <- params
|
||||
let
|
||||
k = (_paramIn . extract $ p, _paramName . extract $ p)
|
||||
v = ProductLike
|
||||
{ productValue = p
|
||||
, required = fromMaybe False . _paramRequired . extract $ p
|
||||
}
|
||||
pure (k, v)
|
||||
check (_, name) param = do
|
||||
checkCompatibility @Param (singletonH schemaDefs) (beh >>> step (InParam name)) param
|
||||
let elements = getEls <$> params
|
||||
getEls params = M.fromList $ do
|
||||
p <- params
|
||||
let k = (_paramIn . extract $ p, _paramName . extract $ p)
|
||||
v =
|
||||
ProductLike
|
||||
{ productValue = p
|
||||
, required = fromMaybe False . _paramRequired . extract $ p
|
||||
}
|
||||
pure (k, v)
|
||||
check (_, name) param = do
|
||||
checkCompatibility @Param (singletonH schemaDefs) (beh >>> step (InParam name)) param
|
||||
checkProducts beh (ParamNotMatched . snd) check elements
|
||||
checkPathParams :: ProdCons [Traced Param] -> CompatFormula ()
|
||||
checkPathParams :: ProdCons [Traced Param] -> SemanticCompatFormula ()
|
||||
checkPathParams pathParams = do
|
||||
let
|
||||
fragments :: ProdCons [Traced PathFragmentParam]
|
||||
fragments = getFragments <$> pathParams <*> prodCons
|
||||
getFragments params mop = getPathFragments (extract mop) params
|
||||
-- Feed path parameters to the fragments getter
|
||||
check idx frags = checkCompatibility @PathFragmentParam env (beh >>> step (InFragment idx)) frags
|
||||
elements = fragments <&> \frags -> M.fromList $ zip [0 :: Int ..] $ do
|
||||
frag <- frags
|
||||
pure $ ProductLike
|
||||
{ productValue = frag
|
||||
, required = True }
|
||||
let fragments :: ProdCons [Traced PathFragmentParam]
|
||||
fragments = getFragments <$> pathParams <*> prodCons
|
||||
getFragments params mop = getPathFragments (extract mop) params
|
||||
-- Feed path parameters to the fragments getter
|
||||
check idx frags = checkCompatibility @PathFragmentParam env (beh >>> step (InFragment idx)) frags
|
||||
elements =
|
||||
fragments <&> \frags -> M.fromList $
|
||||
zip [0 :: Int ..] $ do
|
||||
frag <- frags
|
||||
pure $
|
||||
ProductLike
|
||||
{ productValue = frag
|
||||
, required = True
|
||||
}
|
||||
checkProducts beh PathFragmentNotMatched check elements
|
||||
checkRequestBodies = do
|
||||
let
|
||||
check reqBody = checkCompatibility @RequestBody env (beh >>> step InRequest) reqBody
|
||||
elements = getReqBody <$> bodyDefs <*> prodCons
|
||||
getReqBody bodyDef mop = M.fromList $ do
|
||||
bodyRef <- F.toList . tracedRequestBody $ mop
|
||||
let
|
||||
body = dereference bodyDef bodyRef
|
||||
-- Single element map
|
||||
pure ((), ProductLike
|
||||
{ productValue = body
|
||||
, required = fromMaybe False . _requestBodyRequired . extract $ body
|
||||
})
|
||||
let check reqBody = checkCompatibility @RequestBody env (beh >>> step InRequest) reqBody
|
||||
elements = getReqBody <$> bodyDefs <*> prodCons
|
||||
getReqBody bodyDef mop = M.fromList $ do
|
||||
bodyRef <- F.toList . tracedRequestBody $ mop
|
||||
let body = dereference bodyDef bodyRef
|
||||
-- Single element map
|
||||
pure
|
||||
( ()
|
||||
, ProductLike
|
||||
{ productValue = body
|
||||
, required = fromMaybe False . _requestBodyRequired . extract $ body
|
||||
}
|
||||
)
|
||||
checkProducts beh (const NoRequestBody) (const check) elements
|
||||
checkResponses = do
|
||||
let
|
||||
respEnv = HCons (swapProdCons respDefs)
|
||||
$ HCons (swapProdCons headerDefs)
|
||||
$ HCons (swapProdCons schemaDefs) HNil
|
||||
resps = tracedResponses <$> prodCons
|
||||
let respEnv =
|
||||
HCons (swapProdCons respDefs) $
|
||||
HCons (swapProdCons headerDefs) $
|
||||
HCons (swapProdCons schemaDefs) $
|
||||
HCons (swapProdCons linkDefs) HNil
|
||||
resps = tracedResponses <$> prodCons
|
||||
checkCompatibility respEnv beh $ swapProdCons resps
|
||||
-- FIXME: https://github.com/typeable/openapi-diff/issues/27
|
||||
checkCallbacks = pure () -- (error "FIXME: not implemented")
|
||||
-- FIXME: https://github.com/typeable/openapi-diff/issues/28
|
||||
checkOperationSecurity = pure () -- (error "FIXME: not implemented")
|
||||
checkServers =
|
||||
checkCompatibility env beh $
|
||||
tracedServers <$> getH @(ProdCons [Server]) env <*> prodCons
|
||||
checkCompatibility env beh $ do
|
||||
x <- prodCons
|
||||
se <- getH @(ProdCons [Server]) env
|
||||
pure $ Traced (ask x >>> step OperationServersStep) (getServers se (extract x))
|
||||
bodyDefs = getH @(ProdCons (Traced (Definitions RequestBody))) env
|
||||
respDefs = getH @(ProdCons (Traced (Definitions Response))) env
|
||||
headerDefs = getH @(ProdCons (Traced (Definitions Header))) env
|
||||
headerDefs = getH @(ProdCons (Traced (Definitions Header))) env
|
||||
schemaDefs = getH @(ProdCons (Traced (Definitions Schema))) env
|
||||
paramDefs = getH @(ProdCons (Traced (Definitions Param))) env
|
||||
linkDefs = getH @(ProdCons (Traced (Definitions Link))) env
|
||||
|
||||
data OperationMethod =
|
||||
GetMethod
|
||||
data OperationMethod
|
||||
= GetMethod
|
||||
| PutMethod
|
||||
| PostMethod
|
||||
| DeleteMethod
|
||||
|
@ -71,7 +71,17 @@ instance Behavable 'PathFragmentLevel 'SchemaLevel where
|
||||
instance Subtree Param where
|
||||
type SubtreeLevel Param = 'PathFragmentLevel
|
||||
type CheckEnv Param = '[ProdCons (Traced (Definitions Schema))]
|
||||
checkCompatibility env beh pc@(ProdCons p c) = do
|
||||
checkStructuralCompatibility env pc = do
|
||||
structuralEq $ _paramName <$> pc
|
||||
structuralEq $ _paramRequired <$> pc
|
||||
structuralEq $ _paramIn <$> pc
|
||||
structuralEq $ _paramAllowEmptyValue <$> pc
|
||||
structuralEq $ _paramAllowReserved <$> pc
|
||||
structuralMaybe env $ _paramSchema <$> pc
|
||||
structuralEq $ _paramStyle <$> pc
|
||||
structuralEq $ _paramExplode <$> pc
|
||||
pure ()
|
||||
checkSemanticCompatibility env beh pc@(ProdCons p c) = do
|
||||
when (_paramName (extract p) /= _paramName (extract c))
|
||||
$ issueAt beh ParamNameMismatch
|
||||
when ((fromMaybe False . _paramRequired . extract $ c) &&
|
||||
|
@ -63,10 +63,12 @@ instance Subtree PathFragmentParam where
|
||||
type SubtreeLevel PathFragmentParam = 'PathFragmentLevel
|
||||
type CheckEnv PathFragmentParam =
|
||||
'[ ProdCons (Traced (Definitions Schema)) ]
|
||||
-- Not much to compare at this level
|
||||
checkStructuralCompatibility _ _ = structuralIssue
|
||||
-- This case isn't strictly needed. It is here for optimization.
|
||||
checkCompatibility _ beh (ProdCons (extract -> StaticPath x) (extract -> StaticPath y))
|
||||
checkSemanticCompatibility _ beh (ProdCons (extract -> StaticPath x) (extract -> StaticPath y))
|
||||
= if x == y
|
||||
then pure ()
|
||||
else issueAt beh (PathFragmentsDontMatch x y)
|
||||
checkCompatibility env beh prodCons = do
|
||||
checkSemanticCompatibility env beh prodCons = do
|
||||
checkCompatibility env beh (tracedPathFragmentParam <$> prodCons)
|
||||
|
@ -33,13 +33,14 @@ import OpenAPI.Checker.Validate.Sums
|
||||
data ProcessedPathItem = ProcessedPathItem
|
||||
{ path :: FilePath
|
||||
, item :: PathItem
|
||||
}
|
||||
} deriving stock (Eq, Show)
|
||||
|
||||
processPathItems :: [(FilePath, PathItem)] -> ProcessedPathItems
|
||||
processPathItems = ProcessedPathItems . fmap (uncurry ProcessedPathItem)
|
||||
|
||||
newtype ProcessedPathItems =
|
||||
ProcessedPathItems {unProcessedPathItems :: [ProcessedPathItem]}
|
||||
deriving newtype (Eq, Show)
|
||||
|
||||
instance Issuable 'APILevel where
|
||||
data Issue 'APILevel
|
||||
@ -65,8 +66,11 @@ instance Subtree ProcessedPathItems where
|
||||
, ProdCons (Traced (Definitions Header))
|
||||
, ProdCons (Traced (Definitions Schema))
|
||||
, ProdCons [Server]
|
||||
, ProdCons (Traced (Definitions Link))
|
||||
]
|
||||
checkCompatibility env beh pc@(ProdCons p c) = do
|
||||
-- No real way to check it at this level
|
||||
checkStructuralCompatibility _ _ = structuralIssue
|
||||
checkSemanticCompatibility env beh pc@(ProdCons p c) = do
|
||||
-- Each path generated by producer must be handled by consumer with exactly
|
||||
-- one way
|
||||
for_ (unProcessedPathItems . extract $ p) $ \ prodItem -> do
|
||||
@ -74,8 +78,7 @@ instance Subtree ProcessedPathItems where
|
||||
prodPath = path prodItem
|
||||
matchedItems = do
|
||||
consItem <- unProcessedPathItems . extract $ c
|
||||
matched <- F.toList $ matchingPathItems $ ProdCons prodItem consItem
|
||||
return matched
|
||||
F.toList $ matchingPathItems $ ProdCons prodItem consItem
|
||||
case matchedItems of
|
||||
[] -> issueAt beh $ NoPathsMatched prodPath
|
||||
[match] -> checkCompatibility env (beh >>> step (AtPath $ matchedPath <$> match)) (retraced <$> pc <*> match)
|
||||
@ -116,7 +119,7 @@ data MatchedPathItem = MatchedPathItem
|
||||
, matchedPath :: !FilePath
|
||||
, pathFragments :: ![PathFragment Text]
|
||||
-- ^ Pre-parsed path from PathItem
|
||||
}
|
||||
} deriving stock (Eq)
|
||||
|
||||
tracedParameters :: Traced MatchedPathItem -> [Traced (Referenced Param)]
|
||||
tracedParameters mpi =
|
||||
@ -158,8 +161,10 @@ instance Subtree MatchedPathItem where
|
||||
, ProdCons (Traced (Definitions Header))
|
||||
, ProdCons (Traced (Definitions Schema))
|
||||
, ProdCons [Server]
|
||||
, ProdCons (Traced (Definitions Link))
|
||||
]
|
||||
checkCompatibility env beh prodCons = do
|
||||
checkStructuralCompatibility _ _ = structuralIssue
|
||||
checkSemanticCompatibility env beh prodCons = do
|
||||
let
|
||||
paramDefs = getH @(ProdCons (Traced (Definitions Param))) env
|
||||
pathTracedParams = getPathParams <$> paramDefs <*> prodCons
|
||||
|
@ -17,8 +17,9 @@ import OpenAPI.Checker.Validate.MediaTypeObject
|
||||
import OpenAPI.Checker.Validate.Sums
|
||||
|
||||
tracedContent :: Traced RequestBody -> IOHM.InsOrdHashMap MediaType (Traced MediaTypeObject)
|
||||
tracedContent resp = IOHM.mapWithKey (\k -> traced (ask resp >>> step (RequestMediaTypeObject k)))
|
||||
$ _requestBodyContent $ extract resp
|
||||
tracedContent resp =
|
||||
IOHM.mapWithKey (\k -> traced (ask resp >>> step (RequestMediaTypeObject k))) $
|
||||
_requestBodyContent $ extract resp
|
||||
|
||||
instance Issuable 'RequestLevel where
|
||||
data Issue 'RequestLevel
|
||||
@ -34,19 +35,25 @@ instance Behavable 'RequestLevel 'PayloadLevel where
|
||||
|
||||
instance Subtree RequestBody where
|
||||
type SubtreeLevel RequestBody = 'RequestLevel
|
||||
type CheckEnv RequestBody =
|
||||
'[ ProdCons (Traced (Definitions Schema)) ]
|
||||
checkCompatibility env beh prodCons@(ProdCons p c) =
|
||||
type
|
||||
CheckEnv RequestBody =
|
||||
'[ ProdCons (Traced (Definitions Schema))
|
||||
, ProdCons (Traced (Definitions Header))
|
||||
]
|
||||
checkStructuralCompatibility env pc = do
|
||||
structuralEq $ _requestBodyRequired <$> pc
|
||||
iohmStructural env $ _requestBodyContent <$> pc
|
||||
pure ()
|
||||
checkSemanticCompatibility env beh prodCons@(ProdCons p c) =
|
||||
if not (fromMaybe False . _requestBodyRequired . extract $ p)
|
||||
&& (fromMaybe False . _requestBodyRequired . extract $ c)
|
||||
then issueAt beh RequestBodyRequired
|
||||
else
|
||||
-- Media type object are sums-like entities.
|
||||
let
|
||||
check mediaType pc = checkCompatibility @MediaTypeObject (HCons mediaType env) (beh >>> step InPayload) pc
|
||||
sumElts = getSum <$> prodCons
|
||||
getSum rb = M.fromList . IOHM.toList $ tracedContent rb
|
||||
in checkSums beh RequestMediaTypeNotFound check sumElts
|
||||
&& (fromMaybe False . _requestBodyRequired . extract $ c)
|
||||
then issueAt beh RequestBodyRequired
|
||||
else -- Media type object are sums-like entities.
|
||||
|
||||
let check mediaType pc = checkCompatibility @MediaTypeObject (HCons mediaType env) (beh >>> step InPayload) pc
|
||||
sumElts = getSum <$> prodCons
|
||||
getSum rb = M.fromList . IOHM.toList $ tracedContent rb
|
||||
in checkSums beh RequestMediaTypeNotFound check sumElts
|
||||
|
||||
instance Steppable RequestBody MediaTypeObject where
|
||||
data Step RequestBody MediaTypeObject = RequestMediaTypeObject MediaType
|
||||
|
@ -6,8 +6,6 @@ module OpenAPI.Checker.Validate.Responses
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Lens
|
||||
import Data.Foldable
|
||||
import Data.HList
|
||||
import Data.HashMap.Strict.InsOrd as IOHM
|
||||
import Data.Map.Strict as M
|
||||
@ -17,42 +15,54 @@ import Network.HTTP.Media (MediaType)
|
||||
import OpenAPI.Checker.Behavior
|
||||
import OpenAPI.Checker.References
|
||||
import OpenAPI.Checker.Subtree
|
||||
import OpenAPI.Checker.Validate.Header ()
|
||||
import OpenAPI.Checker.Validate.Link ()
|
||||
import OpenAPI.Checker.Validate.MediaTypeObject
|
||||
import OpenAPI.Checker.Validate.Products
|
||||
import OpenAPI.Checker.Validate.Schema ()
|
||||
import OpenAPI.Checker.Validate.Sums
|
||||
|
||||
tracedResponses :: Traced Responses -> IOHM.InsOrdHashMap HttpStatusCode (Traced (Referenced Response))
|
||||
tracedResponses resp = IOHM.mapWithKey (\k -> traced (ask resp >>> step (ResponseCodeStep k)))
|
||||
$ _responsesResponses $ extract resp
|
||||
tracedResponses resp =
|
||||
IOHM.mapWithKey (\k -> traced (ask resp >>> step (ResponseCodeStep k))) $
|
||||
_responsesResponses $ extract resp
|
||||
|
||||
instance Subtree Responses where
|
||||
type SubtreeLevel Responses = 'OperationLevel
|
||||
type CheckEnv Responses =
|
||||
'[ ProdCons (Traced (Definitions Response))
|
||||
, ProdCons (Traced (Definitions Header))
|
||||
, ProdCons (Traced (Definitions Schema))
|
||||
]
|
||||
type
|
||||
CheckEnv Responses =
|
||||
'[ ProdCons (Traced (Definitions Response))
|
||||
, ProdCons (Traced (Definitions Header))
|
||||
, ProdCons (Traced (Definitions Schema))
|
||||
, ProdCons (Traced (Definitions Link))
|
||||
]
|
||||
|
||||
checkStructuralCompatibility env pc = do
|
||||
structuralMaybe env $ _responsesDefault <$> pc
|
||||
iohmStructural env $ _responsesResponses <$> pc
|
||||
pure ()
|
||||
|
||||
-- Roles are already swapped. Producer is a server and consumer is a
|
||||
-- client. Response codes are sum-like entity because we can answer with only
|
||||
-- one element
|
||||
checkCompatibility env beh prodCons = do
|
||||
let
|
||||
defs = getH @(ProdCons (Traced (Definitions Response))) env
|
||||
check code resps = checkCompatibility @Response env (beh >>> step (WithStatusCode code)) resps
|
||||
elements = getEls <$> defs <*> prodCons
|
||||
getEls respDef resps = M.fromList $ do
|
||||
(code, respRef) <- IOHM.toList $ tracedResponses resps
|
||||
pure (code, dereference respDef respRef)
|
||||
checkSemanticCompatibility env beh prodCons = do
|
||||
let defs = getH @(ProdCons (Traced (Definitions Response))) env
|
||||
check code resps = checkCompatibility @Response env (beh >>> step (WithStatusCode code)) resps
|
||||
elements = getEls <$> defs <*> prodCons
|
||||
getEls respDef resps = M.fromList $ do
|
||||
(code, respRef) <- IOHM.toList $ tracedResponses resps
|
||||
pure (code, dereference respDef respRef)
|
||||
checkSums beh ResponseCodeNotFound check elements
|
||||
|
||||
tracedContent :: Traced Response -> IOHM.InsOrdHashMap MediaType (Traced MediaTypeObject)
|
||||
tracedContent resp = IOHM.mapWithKey (\k -> traced (ask resp >>> step (ResponseMediaObject k)))
|
||||
$ _responseContent $ extract resp
|
||||
tracedContent resp =
|
||||
IOHM.mapWithKey (\k -> traced (ask resp >>> step (ResponseMediaObject k))) $
|
||||
_responseContent $ extract resp
|
||||
|
||||
tracedHeaders :: Traced Response -> IOHM.InsOrdHashMap HeaderName (Traced (Referenced Header))
|
||||
tracedHeaders resp = IOHM.mapWithKey (\k -> traced (ask resp >>> step (ResponseHeader k)))
|
||||
$ _responseHeaders $ extract resp
|
||||
tracedHeaders resp =
|
||||
IOHM.mapWithKey (\k -> traced (ask resp >>> step (ResponseHeader k))) $
|
||||
_responseHeaders $ extract resp
|
||||
|
||||
instance Issuable 'ResponseLevel where
|
||||
data Issue 'ResponseLevel
|
||||
@ -73,11 +83,18 @@ instance Behavable 'ResponseLevel 'HeaderLevel where
|
||||
|
||||
instance Subtree Response where
|
||||
type SubtreeLevel Response = 'ResponseLevel
|
||||
type CheckEnv Response =
|
||||
'[ ProdCons (Traced (Definitions Header))
|
||||
, ProdCons (Traced (Definitions Schema))
|
||||
]
|
||||
checkCompatibility env beh prodCons = do
|
||||
type
|
||||
CheckEnv Response =
|
||||
'[ ProdCons (Traced (Definitions Header))
|
||||
, ProdCons (Traced (Definitions Schema))
|
||||
, ProdCons (Traced (Definitions Link))
|
||||
]
|
||||
checkStructuralCompatibility env pc = do
|
||||
iohmStructural env $ _responseContent <$> pc
|
||||
iohmStructural env $ _responseHeaders <$> pc
|
||||
iohmStructural env $ _responseLinks <$> pc
|
||||
pure ()
|
||||
checkSemanticCompatibility env beh prodCons = do
|
||||
-- Roles are already swapped. Producer is a server and consumer is a client
|
||||
checkMediaTypes
|
||||
checkHeaders
|
||||
@ -85,71 +102,38 @@ instance Subtree Response where
|
||||
where
|
||||
checkMediaTypes = do
|
||||
-- Media types are sum-like entity
|
||||
let
|
||||
check mediaType mtObj =
|
||||
let mtEnv = HCons mediaType $ env
|
||||
in checkCompatibility @MediaTypeObject mtEnv (beh >>> step ResponsePayload) mtObj
|
||||
elements = getEls <$> prodCons
|
||||
getEls resp = M.fromList . IOHM.toList $ tracedContent resp
|
||||
let check mediaType mtObj =
|
||||
let mtEnv = HCons mediaType $ env
|
||||
in checkCompatibility @MediaTypeObject mtEnv (beh >>> step ResponsePayload) mtObj
|
||||
elements = getEls <$> prodCons
|
||||
getEls resp = M.fromList . IOHM.toList $ tracedContent resp
|
||||
checkSums beh ResponseMediaTypeMissing check elements
|
||||
|
||||
checkHeaders = do
|
||||
-- Headers are product-like entities
|
||||
let
|
||||
check name hdrs = checkCompatibility @Header env (beh >>> step (InHeader name)) hdrs
|
||||
elements = getEls <$> headerDefs <*> prodCons
|
||||
getEls headerDef resp = M.fromList $ do
|
||||
(hname, headerRef) <- IOHM.toList $ tracedHeaders resp
|
||||
let header = dereference headerDef headerRef
|
||||
pure (hname, ProductLike
|
||||
{ productValue = header
|
||||
, required = fromMaybe False . _headerRequired . extract $ header
|
||||
})
|
||||
let check name hdrs = checkCompatibility @Header env (beh >>> step (InHeader name)) hdrs
|
||||
elements = getEls <$> headerDefs <*> prodCons
|
||||
getEls headerDef resp = M.fromList $ do
|
||||
(hname, headerRef) <- IOHM.toList $ tracedHeaders resp
|
||||
let header = dereference headerDef headerRef
|
||||
pure
|
||||
( hname
|
||||
, ProductLike
|
||||
{ productValue = header
|
||||
, required = fromMaybe False . _headerRequired . extract $ header
|
||||
}
|
||||
)
|
||||
checkProducts beh ResponseHeaderMissing check elements
|
||||
headerDefs = getH @(ProdCons (Traced (Definitions Header))) env
|
||||
|
||||
tracedSchema :: Traced Header -> Maybe (Traced (Referenced Schema))
|
||||
tracedSchema hdr = _headerSchema (extract hdr) <&> traced (ask hdr >>> step HeaderSchema)
|
||||
|
||||
instance Issuable 'HeaderLevel where
|
||||
data Issue 'HeaderLevel
|
||||
= RequiredHeaderMissing
|
||||
| NonEmptyHeaderRequired
|
||||
| HeaderSchemaRequired
|
||||
deriving stock (Eq, Ord, Show)
|
||||
issueIsUnsupported _ = False
|
||||
|
||||
instance Behavable 'HeaderLevel 'SchemaLevel where
|
||||
data Behave 'HeaderLevel 'SchemaLevel
|
||||
= InSchema
|
||||
deriving stock (Eq, Ord, Show)
|
||||
|
||||
instance Subtree Header where
|
||||
type SubtreeLevel Header = 'HeaderLevel
|
||||
type CheckEnv Header = '[ProdCons (Traced (Definitions Schema))]
|
||||
checkCompatibility env beh (ProdCons p c) = do
|
||||
if (fromMaybe False $ _headerRequired $ extract c) && not (fromMaybe False $ _headerRequired $ extract p)
|
||||
then issueAt beh RequiredHeaderMissing else pure ()
|
||||
if not (fromMaybe False $ _headerAllowEmptyValue $ extract c) && (fromMaybe False $ _headerAllowEmptyValue $ extract p)
|
||||
then issueAt beh NonEmptyHeaderRequired else pure ()
|
||||
for_ (tracedSchema c) $ \consRef ->
|
||||
case tracedSchema p of
|
||||
Nothing -> issueAt beh HeaderSchemaRequired
|
||||
Just prodRef -> checkCompatibility env (beh >>> step InSchema) (ProdCons prodRef consRef)
|
||||
pure ()
|
||||
|
||||
instance Steppable Responses (Referenced Response) where
|
||||
data Step Responses (Referenced Response) = ResponseCodeStep HttpStatusCode
|
||||
deriving stock (Eq, Ord, Show)
|
||||
|
||||
instance Steppable Header (Referenced Schema) where
|
||||
data Step Header (Referenced Schema) = HeaderSchema
|
||||
instance Steppable Response MediaTypeObject where
|
||||
data Step Response MediaTypeObject = ResponseMediaObject MediaType
|
||||
deriving stock (Eq, Ord, Show)
|
||||
|
||||
instance Steppable Response (Referenced Header) where
|
||||
data Step Response (Referenced Header) = ResponseHeader HeaderName
|
||||
deriving stock (Eq, Ord, Show)
|
||||
|
||||
instance Steppable Response MediaTypeObject where
|
||||
data Step Response MediaTypeObject = ResponseMediaObject MediaType
|
||||
deriving stock (Eq, Ord, Show)
|
||||
|
@ -38,6 +38,7 @@ import Data.Scientific
|
||||
import qualified Data.Set as S
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T hiding (singleton)
|
||||
import qualified Data.Text.Encoding as T
|
||||
import Data.Typeable
|
||||
import OpenAPI.Checker.Behavior
|
||||
import OpenAPI.Checker.Orphans ()
|
||||
@ -45,6 +46,7 @@ import OpenAPI.Checker.References
|
||||
import OpenAPI.Checker.Paths
|
||||
import qualified OpenAPI.Checker.PathsPrefixTree as P
|
||||
import OpenAPI.Checker.Subtree
|
||||
import Debug.Trace
|
||||
|
||||
-- | Type of a JSON value
|
||||
data JsonType
|
||||
@ -598,11 +600,11 @@ schemaToFormula
|
||||
schemaToFormula defs rs = runWriter . (`runReaderT` defs) $ processSchema rs
|
||||
|
||||
checkFormulas
|
||||
:: HasAll (CheckEnv Schema) xs
|
||||
:: (HasAll (CheckEnv Schema) xs)
|
||||
=> HList xs
|
||||
-> Behavior 'SchemaLevel
|
||||
-> ProdCons (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)
|
||||
-> CompatFormula ()
|
||||
-> SemanticCompatFormula ()
|
||||
checkFormulas env beh (ProdCons (fp, ep) (fc, ec)) =
|
||||
case P.toList ep ++ P.toList ec of
|
||||
issues@(_:_) -> F.for_ issues $ \(AnItem t (AnIssue e)) -> issueAt (beh >>> t) e
|
||||
@ -647,7 +649,7 @@ checkFormulas env beh (ProdCons (fp, ep) (fc, ec)) =
|
||||
checkContradiction
|
||||
:: Behavior 'TypedSchemaLevel
|
||||
-> [Condition t]
|
||||
-> CompatFormula ()
|
||||
-> SemanticCompatFormula ()
|
||||
checkContradiction beh _ = issueAt beh NoContradiction -- TODO
|
||||
|
||||
checkImplication
|
||||
@ -656,7 +658,7 @@ checkImplication
|
||||
-> Behavior 'TypedSchemaLevel
|
||||
-> [Condition t]
|
||||
-> Condition t
|
||||
-> CompatFormula ()
|
||||
-> SemanticCompatFormula ()
|
||||
checkImplication env beh prods cons = case findExactly prods of
|
||||
Just e
|
||||
| all (satisfiesTyped e) prods ->
|
||||
@ -803,15 +805,62 @@ instance Behavable 'TypedSchemaLevel 'SchemaLevel where
|
||||
instance Subtree Schema where
|
||||
type SubtreeLevel Schema = 'SchemaLevel
|
||||
type CheckEnv Schema = '[ProdCons (Traced (Definitions Schema))]
|
||||
checkCompatibility env beh schs = do
|
||||
checkStructuralCompatibility env pc = do
|
||||
traceShowM pc
|
||||
structuralEq $ _schemaRequired <$> pc
|
||||
structuralMaybeWith structuralEq $ _schemaNullable <$> pc
|
||||
structuralMaybeWith (structuralList env) $ _schemaAllOf <$> pc
|
||||
structuralMaybeWith (structuralList env) $ _schemaOneOf <$> pc
|
||||
structuralMaybe env $ _schemaNot <$> pc
|
||||
structuralMaybeWith (structuralList env) $ _schemaAnyOf <$> pc
|
||||
iohmStructural env $ _schemaProperties <$> pc
|
||||
structuralMaybeWith structuralAdditionalProperties $ _schemaAdditionalProperties <$> pc
|
||||
structuralMaybeWith structuralDiscriminator $ _schemaDiscriminator <$> pc
|
||||
structuralEq $ _schemaReadOnly <$> pc
|
||||
structuralEq $ _schemaWriteOnly <$> pc
|
||||
structuralEq $ _schemaXml <$> pc
|
||||
structuralEq $ _schemaMaxProperties <$> pc
|
||||
structuralEq $ _schemaMinProperties <$> pc
|
||||
structuralEq $ _schemaDefault <$> pc
|
||||
structuralEq $ _schemaType <$> pc
|
||||
structuralEq $ _schemaFormat <$> pc
|
||||
structuralMaybeWith structuralItems $ _schemaItems <$> pc
|
||||
structuralEq $ _schemaMaximum <$> pc
|
||||
structuralEq $ _schemaExclusiveMaximum <$> pc
|
||||
structuralEq $ _schemaMinimum <$> pc
|
||||
structuralEq $ _schemaExclusiveMinimum <$> pc
|
||||
structuralEq $ _schemaMaxLength <$> pc
|
||||
structuralEq $ _schemaMinLength <$> pc
|
||||
structuralEq $ _schemaPattern <$> pc
|
||||
structuralEq $ _schemaMaxItems <$> pc
|
||||
structuralEq $ _schemaMinItems <$> pc
|
||||
structuralEq $ _schemaUniqueItems <$> pc
|
||||
structuralEq $ _schemaEnum <$> pc
|
||||
structuralEq $ _schemaMultipleOf <$> pc
|
||||
pure ()
|
||||
where
|
||||
structuralAdditionalProperties
|
||||
(ProdCons (AdditionalPropertiesAllowed x) (AdditionalPropertiesAllowed y)) =
|
||||
structuralEq $ ProdCons x y
|
||||
structuralAdditionalProperties
|
||||
(ProdCons (AdditionalPropertiesSchema x) (AdditionalPropertiesSchema y)) =
|
||||
checkStructuralCompatibility env $ ProdCons x y
|
||||
structuralAdditionalProperties _ = structuralIssue
|
||||
structuralDiscriminator pc' = do
|
||||
structuralEq $ _discriminatorPropertyName <$> pc'
|
||||
iohmStructuralWith
|
||||
(\_ mappingPC -> case A.decodeStrict @(Referenced Schema) . T.encodeUtf8 <$> mappingPC of
|
||||
ProdCons (Just a) (Just b) -> checkStructuralCompatibility env $ ProdCons a b
|
||||
ProdCons Nothing Nothing -> structuralEq mappingPC
|
||||
_ -> structuralIssue
|
||||
)
|
||||
(_discriminatorMapping <$> pc')
|
||||
pure ()
|
||||
structuralItems (ProdCons (OpenApiItemsObject a) (OpenApiItemsObject b)) =
|
||||
checkStructuralCompatibility env $ ProdCons a b
|
||||
structuralItems (ProdCons (OpenApiItemsArray a) (OpenApiItemsArray b)) =
|
||||
structuralList env $ ProdCons a b
|
||||
structuralItems _ = structuralIssue
|
||||
checkSemanticCompatibility env beh schs = do
|
||||
let defs = getH env
|
||||
checkFormulas env beh $ schemaToFormula <$> defs <*> schs
|
||||
|
||||
instance Subtree (Referenced Schema) where
|
||||
type SubtreeLevel (Referenced Schema) = 'SchemaLevel
|
||||
type CheckEnv (Referenced Schema) = CheckEnv Schema
|
||||
checkCompatibility env beh refs = do
|
||||
let
|
||||
defs = getH env
|
||||
schs = dereference <$> defs <*> refs
|
||||
checkFormulas env beh $ schemaToFormula <$> defs <*> schs
|
||||
|
@ -2,7 +2,8 @@
|
||||
|
||||
module OpenAPI.Checker.Validate.SecurityRequirement
|
||||
( Issue (..)
|
||||
) where
|
||||
)
|
||||
where
|
||||
|
||||
import Data.OpenApi
|
||||
import OpenAPI.Checker.Behavior
|
||||
@ -20,4 +21,5 @@ instance Subtree SecurityRequirement where
|
||||
CheckEnv SecurityRequirement =
|
||||
'[ ProdCons (Traced (Definitions SecurityScheme))
|
||||
]
|
||||
checkCompatibility = undefined
|
||||
checkStructuralCompatibility = undefined
|
||||
checkSemanticCompatibility = undefined
|
||||
|
@ -6,6 +6,7 @@ module OpenAPI.Checker.Validate.Server
|
||||
where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Arrow ((&&&))
|
||||
import Control.Comonad
|
||||
import Control.Monad
|
||||
import Data.Attoparsec.Text
|
||||
@ -14,13 +15,16 @@ import Data.Foldable
|
||||
import Data.Function
|
||||
import Data.Functor
|
||||
import Data.HashMap.Strict.InsOrd as IOHM
|
||||
import qualified Data.HashSet.InsOrd as IOHM
|
||||
import qualified Data.HashSet.InsOrd as IOHS
|
||||
import Data.Maybe
|
||||
import Data.OpenApi
|
||||
import qualified Data.Set as S
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Traversable
|
||||
import OpenAPI.Checker.Behavior
|
||||
import OpenAPI.Checker.Common
|
||||
import OpenAPI.Checker.Paths
|
||||
import OpenAPI.Checker.Subtree
|
||||
import OpenAPI.Checker.Validate.MediaTypeObject
|
||||
@ -44,7 +48,14 @@ instance Behavable 'OperationLevel 'ServerLevel where
|
||||
instance Subtree [Server] where
|
||||
type SubtreeLevel [Server] = 'OperationLevel
|
||||
type CheckEnv [Server] = '[]
|
||||
checkCompatibility env beh pcServer = do
|
||||
checkStructuralCompatibility _ pc =
|
||||
structuralEq $ S.fromList . fmap reduceServer <$> pc
|
||||
where
|
||||
reducerServerVariable =
|
||||
fmap IOHM.toHashSet . _serverVariableEnum &&& _serverVariableDefault
|
||||
reduceServer =
|
||||
_serverUrl &&& fmap reducerServerVariable . IOHM.toHashMap . _serverVariables
|
||||
checkSemanticCompatibility env beh pcServer = do
|
||||
let (ProdCons (pErrs, pUrls) (cErrs, cUrls)) =
|
||||
pcServer
|
||||
<&> partitionEithers
|
||||
@ -74,12 +85,6 @@ unifyPart :: ServerUrlPart ServerVariable -> Maybe (IOHS.InsOrdHashSet Text)
|
||||
unifyPart (ServerUrlVariable v) = _serverVariableEnum v
|
||||
unifyPart (ServerUrlConstant c) = Just $ IOHS.singleton c
|
||||
|
||||
zipAll :: [a] -> [b] -> Maybe [(a, b)]
|
||||
zipAll [] [] = Just []
|
||||
zipAll (x : xs) (y : ys) = ((x, y) :) <$> zipAll xs ys
|
||||
zipAll (_ : _) [] = Nothing
|
||||
zipAll [] (_ : _) = Nothing
|
||||
|
||||
staticCompatiblePart :: ServerUrlPart x -> ServerUrlPart x -> Bool
|
||||
staticCompatiblePart (ServerUrlConstant x) (ServerUrlConstant y) = x == y
|
||||
staticCompatiblePart _ _ = True
|
||||
@ -90,7 +95,7 @@ staticCompatible a b = maybe False (all $ uncurry staticCompatiblePart) $ zipAll
|
||||
data ServerUrlPart var
|
||||
= ServerUrlVariable var
|
||||
| ServerUrlConstant Text
|
||||
deriving stock (Show, Functor, Foldable, Traversable)
|
||||
deriving stock (Eq, Show, Functor, Foldable, Traversable)
|
||||
|
||||
-- | This is super rough. Things like @{a|b}c@ will not match @ac@.
|
||||
-- FIXME: https://github.com/typeable/openapi-diff/issues/46
|
||||
@ -130,7 +135,12 @@ instance Issuable 'ServerLevel where
|
||||
instance Subtree ProcessedServer where
|
||||
type SubtreeLevel ProcessedServer = 'ServerLevel
|
||||
type CheckEnv ProcessedServer = '[]
|
||||
checkCompatibility _ beh pc =
|
||||
checkStructuralCompatibility _ pc =
|
||||
structuralEq $ (fmap . fmap . fmap) reducerServerVariable pc
|
||||
where
|
||||
reducerServerVariable =
|
||||
fmap IOHM.toHashSet . _serverVariableEnum &&& _serverVariableDefault
|
||||
checkSemanticCompatibility _ beh pc =
|
||||
-- traversing here is fine because we have already filtered for length
|
||||
for_ (zip [0 ..] $ zipProdCons . fmap (fmap unifyPart . extract) $ pc) $ \(i, pcPart) -> case pcPart of
|
||||
(Just x, Just y) -> for_ x $ \v -> unless (v `IOHS.member` y) (issueAt beh $ EnumValueNotConsumed i v)
|
||||
|
@ -1 +1 @@
|
||||
resolver: lts-17.4
|
||||
resolver: lts-17.11
|
||||
|
@ -6,7 +6,7 @@
|
||||
packages: []
|
||||
snapshots:
|
||||
- completed:
|
||||
size: 563103
|
||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/4.yaml
|
||||
sha256: f11e2153044f5f71ea7b1c9398f4721f517c9bd37642ed769647b896564021f3
|
||||
original: lts-17.4
|
||||
size: 567672
|
||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/11.yaml
|
||||
sha256: 03181cdbeb671eb605bbcf6f285bea4d094b6ac7433a0e14a9f1dd54ad995938
|
||||
original: lts-17.11
|
||||
|
Loading…
Reference in New Issue
Block a user