mirror of
https://github.com/ilyakooo0/compaREST.git
synced 2024-09-11 14:35:25 +03:00
Initial memoization (#56)
* Structural things now have traces and everything is now memoized * Memoization now doesn't confuse different keys * Accept tests
This commit is contained in:
parent
cbfeeedc1e
commit
4f254f4da1
@ -24,7 +24,7 @@ import Data.Type.Equality
|
||||
import Type.Reflection
|
||||
import Prelude hiding ((.))
|
||||
|
||||
type NiceQuiver q a b = (Typeable q, Typeable a, Typeable b, Ord (q a b), Show (q a b))
|
||||
type NiceQuiver (q :: k -> j -> Type) (a :: k) (b :: j) = (Typeable q, Typeable a, Typeable b, Ord (q a b), Show (q a b))
|
||||
|
||||
-- | All the possible ways to navigate between nodes in a heterogeneous tree
|
||||
-- form a quiver. The hom-sets of the free category constructed from this quiver
|
||||
|
@ -10,7 +10,6 @@ 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
|
||||
@ -19,10 +18,6 @@ instance Typeable a => Steppable (Referenced a) a where
|
||||
data Step (Referenced a) a = InlineStep
|
||||
deriving stock (Eq, Ord, Show)
|
||||
|
||||
instance Typeable a => Steppable (Definitions a) a where
|
||||
data Step (Definitions a) a = ReferencedStep Reference
|
||||
deriving stock (Eq, Ord, Show)
|
||||
|
||||
dereference
|
||||
:: Typeable a
|
||||
=> Traced (Definitions a)
|
||||
@ -31,8 +26,8 @@ dereference
|
||||
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)
|
||||
Ref (Reference ref) ->
|
||||
traced (ask defs >>> step (InsOrdHashMapKeyStep ref)) (fromJust $ IOHM.lookup ref $ extract defs)
|
||||
|
||||
instance Subtree a => Subtree (Referenced a) where
|
||||
type CheckEnv (Referenced a) = ProdCons (Traced (Definitions a)) ': CheckEnv a
|
||||
@ -41,9 +36,9 @@ instance Subtree a => Subtree (Referenced a) where
|
||||
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
|
||||
defs <- getH @(ProdCons (Traced (Definitions a))) env
|
||||
pure (dereference defs x)
|
||||
checkSubstructure env pc
|
||||
|
||||
checkSemanticCompatibility env bhv pc' = do
|
||||
let pc = do
|
||||
|
@ -2,13 +2,17 @@
|
||||
|
||||
module OpenAPI.Checker.Subtree
|
||||
( Steppable (..)
|
||||
, Step (..)
|
||||
, Trace
|
||||
, Traced
|
||||
, Traced'
|
||||
, pattern Traced
|
||||
, traced
|
||||
, retraced
|
||||
, stepTraced
|
||||
, Subtree (..)
|
||||
, checkCompatibility
|
||||
, checkSubstructure
|
||||
, CompatM (..)
|
||||
, CompatFormula'
|
||||
, SemanticCompatFormula
|
||||
@ -19,7 +23,6 @@ module OpenAPI.Checker.Subtree
|
||||
, issueAt
|
||||
, anyOfAt
|
||||
, structuralIssue
|
||||
, memo
|
||||
|
||||
-- * Structural helpers
|
||||
, structuralMaybe
|
||||
@ -59,7 +62,7 @@ import OpenAPI.Checker.Paths
|
||||
import qualified OpenAPI.Checker.PathsPrefixTree as P
|
||||
|
||||
class
|
||||
(Typeable a, Typeable b, Ord (Step a b), Show (Step a b)) =>
|
||||
NiceQuiver Step a b =>
|
||||
Steppable (a :: Type) (b :: Type)
|
||||
where
|
||||
-- | How to get from an @a@ node to a @b@ node
|
||||
@ -79,6 +82,12 @@ pattern Traced t x = EnvT t (Identity x)
|
||||
traced :: Trace a -> a -> Traced a
|
||||
traced = env
|
||||
|
||||
retraced :: (Trace a -> Trace a') -> Traced' a b -> Traced' a' b
|
||||
retraced f (Traced a b) = Traced (f a) b
|
||||
|
||||
stepTraced :: Steppable a a' => Step a a' -> Traced' a b -> Traced' a' b
|
||||
stepTraced s = retraced (>>> step s)
|
||||
|
||||
data ProdCons a = ProdCons
|
||||
{ producer :: a
|
||||
, consumer :: a
|
||||
@ -125,7 +134,7 @@ class (Typeable t, Issuable (SubtreeLevel t)) => Subtree (t :: Type) where
|
||||
checkStructuralCompatibility
|
||||
:: (HasAll (CheckEnv t) xs)
|
||||
=> HList xs
|
||||
-> ProdCons t
|
||||
-> ProdCons (Traced t)
|
||||
-> StructuralCompatFormula ()
|
||||
|
||||
checkSemanticCompatibility
|
||||
@ -135,23 +144,34 @@ class (Typeable t, Issuable (SubtreeLevel t)) => Subtree (t :: Type) where
|
||||
-> ProdCons (Traced t)
|
||||
-> SemanticCompatFormula ()
|
||||
|
||||
{-# WARNING checkStructuralCompatibility "You should not be calling this directly. Use 'checkSubstructure'" #-}
|
||||
|
||||
{-# WARNING checkSemanticCompatibility "You should not be calling this directly. Use 'checkCompatibility'" #-}
|
||||
|
||||
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
|
||||
checkCompatibility e bhv = memo SemanticMemoKey $ \pc ->
|
||||
case runCompatFormula $ checkSubstructure e pc of
|
||||
Left _ -> checkSemanticCompatibility e bhv pc
|
||||
Right () -> pure ()
|
||||
|
||||
checkSubstructure
|
||||
:: (HasAll (CheckEnv t) xs, Subtree t)
|
||||
=> HList xs
|
||||
-> ProdCons (Traced t)
|
||||
-> StructuralCompatFormula ()
|
||||
checkSubstructure e = memo SemanticMemoKey $ checkStructuralCompatibility e
|
||||
|
||||
structuralMaybe
|
||||
:: (Subtree a, HasAll (CheckEnv a) xs)
|
||||
=> HList xs
|
||||
-> ProdCons (Maybe a)
|
||||
-> ProdCons (Maybe (Traced a))
|
||||
-> StructuralCompatFormula ()
|
||||
structuralMaybe e = structuralMaybeWith (checkStructuralCompatibility e)
|
||||
structuralMaybe e = structuralMaybeWith (checkSubstructure e)
|
||||
|
||||
structuralMaybeWith
|
||||
:: (ProdCons a -> StructuralCompatFormula ())
|
||||
@ -163,38 +183,44 @@ structuralMaybeWith _ _ = structuralIssue
|
||||
|
||||
structuralList
|
||||
:: (Subtree a, HasAll (CheckEnv a) xs)
|
||||
=> HList xs -> ProdCons [a] -> StructuralCompatFormula ()
|
||||
=> HList xs
|
||||
-> ProdCons [Traced a]
|
||||
-> StructuralCompatFormula ()
|
||||
structuralList _ (ProdCons [] []) = pure ()
|
||||
structuralList e (ProdCons (a:aa) (b:bb)) = do
|
||||
checkStructuralCompatibility e $ ProdCons a b
|
||||
structuralList e (ProdCons (a : aa) (b : bb)) = do
|
||||
checkSubstructure 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
|
||||
structuralEq :: (Eq a, Comonad w) => ProdCons (w a) -> StructuralCompatFormula ()
|
||||
structuralEq (ProdCons a b) = if extract a == extract b then pure () else structuralIssue
|
||||
|
||||
iohmStructural
|
||||
:: (HasAll (CheckEnv v) (k ': xs), Ord k, Subtree v, Hashable k)
|
||||
:: (HasAll (CheckEnv v) (k ': xs), Ord k, Subtree v, Hashable k, Typeable k, Show k)
|
||||
=> HList xs
|
||||
-> ProdCons (IOHM.InsOrdHashMap k v)
|
||||
-> ProdCons (Traced (IOHM.InsOrdHashMap k v))
|
||||
-> StructuralCompatFormula ()
|
||||
iohmStructural e =
|
||||
iohmStructuralWith (\k -> checkStructuralCompatibility (k `HCons` e))
|
||||
iohmStructuralWith (\k -> checkSubstructure (k `HCons` e))
|
||||
|
||||
instance (Typeable k, Typeable v, Ord k, Show k) => Steppable (IOHM.InsOrdHashMap k v) v where
|
||||
data Step (IOHM.InsOrdHashMap k v) v = InsOrdHashMapKeyStep k
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
iohmStructuralWith
|
||||
:: (Ord k, Hashable k)
|
||||
=> (k -> ProdCons v -> StructuralCompatFormula ())
|
||||
-> ProdCons (IOHM.InsOrdHashMap k v)
|
||||
:: (Ord k, Hashable k, Typeable k, Typeable v, Show k)
|
||||
=> (k -> ProdCons (Traced v) -> StructuralCompatFormula ())
|
||||
-> ProdCons (Traced (IOHM.InsOrdHashMap k v))
|
||||
-> StructuralCompatFormula ()
|
||||
iohmStructuralWith f pc = do
|
||||
let ProdCons pEKeys cEKeys = S.fromList . IOHM.keys <$> pc
|
||||
let ProdCons pEKeys cEKeys = S.fromList . IOHM.keys . extract <$> pc
|
||||
if pEKeys == cEKeys
|
||||
then
|
||||
for_
|
||||
pEKeys
|
||||
(\eKey ->
|
||||
f eKey $ IOHM.lookupDefault (error "impossible") eKey <$> pc)
|
||||
f eKey $ stepTraced (InsOrdHashMapKeyStep eKey) . fmap (IOHM.lookupDefault (error "impossible") eKey) <$> pc)
|
||||
else structuralIssue
|
||||
|
||||
class HasUnsupportedFeature x where
|
||||
@ -256,8 +282,11 @@ fixpointKnot =
|
||||
}
|
||||
|
||||
memo
|
||||
:: (Typeable q, Typeable f, NiceQuiver p r t)
|
||||
=> (ProdCons (Env (Paths p r t) t) -> CompatFormula' q f r ())
|
||||
-> (ProdCons (Env (Paths p r t) t) -> CompatFormula' q f r ())
|
||||
memo f pc = Compose $ do
|
||||
memoWithKnot fixpointKnot (getCompose $ f pc) (ask <$> pc)
|
||||
:: (Typeable (r :: k), Typeable q, Typeable f, Typeable k, Typeable a)
|
||||
=> MemoKey
|
||||
-> (ProdCons (Traced a) -> CompatFormula' q f r ())
|
||||
-> (ProdCons (Traced a) -> CompatFormula' q f r ())
|
||||
memo k f pc = Compose $ memoWithKnot fixpointKnot (getCompose $ f pc) (k, ask <$> pc)
|
||||
|
||||
data MemoKey = SemanticMemoKey | StructuralMemoKey
|
||||
deriving stock (Eq, Ord)
|
||||
|
@ -18,10 +18,10 @@ 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
|
||||
structuralEq $ fmap _headerRequired <$> pc
|
||||
structuralEq $ fmap _headerAllowEmptyValue <$> pc
|
||||
structuralEq $ fmap _headerExplode <$> pc
|
||||
structuralMaybe env $ tracedSchema <$> pc
|
||||
pure ()
|
||||
checkSemanticCompatibility env beh (ProdCons p c) = do
|
||||
if (fromMaybe False $ _headerRequired $ extract c) && not (fromMaybe False $ _headerRequired $ extract p)
|
||||
|
@ -23,6 +23,7 @@ import OpenAPI.Checker.Validate.Header ()
|
||||
tracedSchema :: Traced MediaTypeObject -> Maybe (Traced (Referenced Schema))
|
||||
tracedSchema mto = _mediaTypeObjectSchema (extract mto) <&> traced (ask mto >>> step MediaTypeSchema)
|
||||
|
||||
-- FIXME: This should be done through 'MediaTypeEncodingMapping'
|
||||
tracedEncoding :: Traced MediaTypeObject -> InsOrdHashMap Text (Traced Encoding)
|
||||
tracedEncoding mto = IOHM.mapWithKey (\k -> traced (ask mto >>> step (MediaTypeParamEncoding k)))
|
||||
$ _mediaTypeObjectEncoding $ extract mto
|
||||
@ -52,9 +53,9 @@ instance Subtree MediaTypeObject where
|
||||
, ProdCons (Traced (Definitions Header))
|
||||
]
|
||||
checkStructuralCompatibility env pc = do
|
||||
structuralMaybe env $ _mediaTypeObjectSchema <$> pc
|
||||
structuralEq $ _mediaTypeObjectExample <$> pc
|
||||
iohmStructural env $ _mediaTypeObjectEncoding <$> pc
|
||||
structuralMaybe env $ tracedSchema <$> pc
|
||||
structuralEq $ fmap _mediaTypeObjectExample <$> pc
|
||||
iohmStructural env $ stepTraced MediaTypeEncodingMapping . fmap _mediaTypeObjectEncoding <$> pc
|
||||
pure ()
|
||||
checkSemanticCompatibility env beh prodCons@(ProdCons p c) = do
|
||||
if | "multipart" == mainType mediaType -> checkEncoding
|
||||
@ -92,11 +93,11 @@ instance Subtree Encoding where
|
||||
, ProdCons (Traced (Definitions Schema))
|
||||
]
|
||||
checkStructuralCompatibility env pc = do
|
||||
structuralEq $ _encodingContentType <$> pc
|
||||
iohmStructural env $ _encodingHeaders <$> pc
|
||||
structuralEq $ _encodingStyle <$> pc
|
||||
structuralEq $ _encodingExplode <$> pc
|
||||
structuralEq $ _encodingAllowReserved <$> pc
|
||||
structuralEq $ fmap _encodingContentType <$> pc
|
||||
iohmStructural env $ stepTraced EncodingHeaderStep . fmap _encodingHeaders <$> pc
|
||||
structuralEq $ fmap _encodingStyle <$> pc
|
||||
structuralEq $ fmap _encodingExplode <$> pc
|
||||
structuralEq $ fmap _encodingAllowReserved <$> pc
|
||||
pure ()
|
||||
|
||||
-- FIXME: Support only JSON body for now. Then Encoding is checked only for
|
||||
@ -109,10 +110,18 @@ instance Steppable MediaTypeObject (Referenced Schema) where
|
||||
data Step MediaTypeObject (Referenced Schema) = MediaTypeSchema
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance Steppable MediaTypeObject (Definitions Encoding) where
|
||||
data Step MediaTypeObject (Definitions Encoding) = MediaTypeEncodingMapping
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance Steppable MediaTypeObject Encoding where
|
||||
data Step MediaTypeObject Encoding = MediaTypeParamEncoding Text
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance Steppable Encoding (Definitions (Referenced Header)) where
|
||||
data Step Encoding (Definitions (Referenced Header)) = EncodingHeaderStep
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance Behavable 'OperationLevel 'ResponseLevel where
|
||||
data Behave 'OperationLevel 'ResponseLevel
|
||||
= WithStatusCode HttpStatusCode
|
||||
|
@ -15,10 +15,8 @@ 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
|
||||
@ -97,26 +95,27 @@ instance Subtree MatchedOperation where
|
||||
, ProdCons (Traced (Definitions Link))
|
||||
]
|
||||
checkStructuralCompatibility env pc = do
|
||||
let pParams :: ProdCons [Param]
|
||||
let pParams :: ProdCons [Traced Param]
|
||||
pParams = do
|
||||
defs <- extract <$> getH @(ProdCons (Traced (Definitions Param))) env
|
||||
op' <- _operationParameters . operation <$> pc
|
||||
pp <- fmap extract . pathParams <$> pc
|
||||
defs <- getH @(ProdCons (Traced (Definitions Param))) env
|
||||
op' <- tracedParameters <$> pc
|
||||
pp <- pathParams . extract <$> pc
|
||||
pure $
|
||||
let o = M.fromList $ do
|
||||
param <- G.dereference defs <$> op'
|
||||
let key = paramKey param
|
||||
param <- dereference defs <$> op'
|
||||
let key = paramKey . extract $ param
|
||||
pure (key, param)
|
||||
p = M.fromList $ do
|
||||
param <- pp
|
||||
pure (paramKey param, param)
|
||||
pure (paramKey . extract $ 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
|
||||
structuralList env pParams
|
||||
structuralMaybe env $ tracedRequestBody <$> pc
|
||||
checkSubstructure env $ tracedResponses <$> pc
|
||||
checkSubstructure env $ do
|
||||
x <- pc
|
||||
se <- getH @(ProdCons [Server]) env
|
||||
pure $ Traced (ask x >>> step OperationServersStep) (getServers se (extract x))
|
||||
-- TODO: Callbacks
|
||||
-- TODO: Security
|
||||
pure ()
|
||||
|
@ -72,14 +72,14 @@ instance Subtree Param where
|
||||
type SubtreeLevel Param = 'PathFragmentLevel
|
||||
type CheckEnv Param = '[ProdCons (Traced (Definitions Schema))]
|
||||
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
|
||||
structuralEq $ fmap _paramName <$> pc
|
||||
structuralEq $ fmap _paramRequired <$> pc
|
||||
structuralEq $ fmap _paramIn <$> pc
|
||||
structuralEq $ fmap _paramAllowEmptyValue <$> pc
|
||||
structuralEq $ fmap _paramAllowReserved <$> pc
|
||||
structuralMaybe env $ tracedSchema <$> pc
|
||||
structuralEq $ fmap _paramStyle <$> pc
|
||||
structuralEq $ fmap _paramExplode <$> pc
|
||||
pure ()
|
||||
checkSemanticCompatibility env beh pc@(ProdCons p c) = do
|
||||
when (_paramName (extract p) /= _paramName (extract c))
|
||||
|
@ -16,6 +16,7 @@ import OpenAPI.Checker.Subtree
|
||||
import OpenAPI.Checker.Validate.MediaTypeObject
|
||||
import OpenAPI.Checker.Validate.Sums
|
||||
|
||||
-- TODO: Use RequestMediaTypeObjectMapping
|
||||
tracedContent :: Traced RequestBody -> IOHM.InsOrdHashMap MediaType (Traced MediaTypeObject)
|
||||
tracedContent resp =
|
||||
IOHM.mapWithKey (\k -> traced (ask resp >>> step (RequestMediaTypeObject k))) $
|
||||
@ -41,8 +42,9 @@ instance Subtree RequestBody where
|
||||
, ProdCons (Traced (Definitions Header))
|
||||
]
|
||||
checkStructuralCompatibility env pc = do
|
||||
structuralEq $ _requestBodyRequired <$> pc
|
||||
iohmStructural env $ _requestBodyContent <$> pc
|
||||
structuralEq $ fmap _requestBodyRequired <$> pc
|
||||
iohmStructural env $
|
||||
stepTraced RequestMediaTypeObjectMapping . fmap _requestBodyContent <$> pc
|
||||
pure ()
|
||||
checkSemanticCompatibility env beh prodCons@(ProdCons p c) =
|
||||
if not (fromMaybe False . _requestBodyRequired . extract $ p)
|
||||
@ -58,3 +60,7 @@ instance Subtree RequestBody where
|
||||
instance Steppable RequestBody MediaTypeObject where
|
||||
data Step RequestBody MediaTypeObject = RequestMediaTypeObject MediaType
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance Steppable RequestBody (IOHM.InsOrdHashMap MediaType MediaTypeObject) where
|
||||
data Step RequestBody (IOHM.InsOrdHashMap MediaType MediaTypeObject) = RequestMediaTypeObjectMapping
|
||||
deriving (Eq, Ord, Show)
|
||||
|
@ -38,8 +38,8 @@ instance Subtree Responses where
|
||||
]
|
||||
|
||||
checkStructuralCompatibility env pc = do
|
||||
structuralMaybe env $ _responsesDefault <$> pc
|
||||
iohmStructural env $ _responsesResponses <$> pc
|
||||
structuralMaybe env $ sequence . stepTraced ResponseDefaultStep . fmap _responsesDefault <$> pc
|
||||
iohmStructural env $ stepTraced ResponsesStep . fmap _responsesResponses <$> pc
|
||||
pure ()
|
||||
|
||||
-- Roles are already swapped. Producer is a server and consumer is a
|
||||
@ -90,9 +90,9 @@ instance Subtree Response where
|
||||
, ProdCons (Traced (Definitions Link))
|
||||
]
|
||||
checkStructuralCompatibility env pc = do
|
||||
iohmStructural env $ _responseContent <$> pc
|
||||
iohmStructural env $ _responseHeaders <$> pc
|
||||
iohmStructural env $ _responseLinks <$> pc
|
||||
iohmStructural env $ stepTraced ResponseMediaObjects . fmap _responseContent <$> pc
|
||||
iohmStructural env $ stepTraced ResponseHeaders . fmap _responseHeaders <$> pc
|
||||
iohmStructural env $ stepTraced ResponseLinks . fmap _responseLinks <$> pc
|
||||
pure ()
|
||||
checkSemanticCompatibility env beh prodCons = do
|
||||
-- Roles are already swapped. Producer is a server and consumer is a client
|
||||
@ -127,13 +127,31 @@ instance Subtree Response where
|
||||
headerDefs = getH @(ProdCons (Traced (Definitions Header))) env
|
||||
|
||||
instance Steppable Responses (Referenced Response) where
|
||||
data Step Responses (Referenced Response) = ResponseCodeStep HttpStatusCode
|
||||
data Step Responses (Referenced Response)
|
||||
= ResponseCodeStep HttpStatusCode
|
||||
| ResponseDefaultStep
|
||||
deriving stock (Eq, Ord, Show)
|
||||
|
||||
instance Steppable Response MediaTypeObject where
|
||||
data Step Response MediaTypeObject = ResponseMediaObject MediaType
|
||||
deriving stock (Eq, Ord, Show)
|
||||
|
||||
instance Steppable Response (IOHM.InsOrdHashMap MediaType MediaTypeObject) where
|
||||
data Step Response (IOHM.InsOrdHashMap MediaType MediaTypeObject) = ResponseMediaObjects
|
||||
deriving stock (Eq, Ord, Show)
|
||||
|
||||
instance Steppable Response (Definitions (Referenced Header)) where
|
||||
data Step Response (Definitions (Referenced Header)) = ResponseHeaders
|
||||
deriving stock (Eq, Ord, Show)
|
||||
|
||||
instance Steppable Response (Definitions (Referenced Link)) where
|
||||
data Step Response (Definitions (Referenced Link)) = ResponseLinks
|
||||
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 Responses (IOHM.InsOrdHashMap HttpStatusCode (Referenced Response)) where
|
||||
data Step Responses (IOHM.InsOrdHashMap HttpStatusCode (Referenced Response)) = ResponsesStep
|
||||
deriving stock (Eq, Ord, Show)
|
||||
|
@ -1,4 +1,5 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module OpenAPI.Checker.Validate.Schema
|
||||
( JsonType (..)
|
||||
, ForeachType (..)
|
||||
@ -10,7 +11,7 @@ module OpenAPI.Checker.Validate.Schema
|
||||
, schemaToFormula
|
||||
, foldLattice
|
||||
)
|
||||
where
|
||||
where
|
||||
|
||||
import Algebra.Lattice
|
||||
import Control.Applicative
|
||||
@ -23,9 +24,9 @@ import Control.Monad.Writer
|
||||
import qualified Data.Aeson as A
|
||||
import Data.Coerce
|
||||
import qualified Data.Foldable as F
|
||||
import Data.HList
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.HashMap.Strict.InsOrd as IOHM
|
||||
import Data.HList
|
||||
import Data.Int
|
||||
import Data.Kind
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
@ -38,15 +39,13 @@ 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 ()
|
||||
import OpenAPI.Checker.References
|
||||
import OpenAPI.Checker.Paths
|
||||
import qualified OpenAPI.Checker.PathsPrefixTree as P
|
||||
import OpenAPI.Checker.References
|
||||
import OpenAPI.Checker.Subtree
|
||||
import Debug.Trace
|
||||
|
||||
-- | Type of a JSON value
|
||||
data JsonType
|
||||
@ -68,7 +67,9 @@ data TypedValue :: JsonType -> Type where
|
||||
TObject :: !A.Object -> TypedValue 'Object
|
||||
|
||||
deriving stock instance Eq (TypedValue t)
|
||||
|
||||
deriving stock instance Ord (TypedValue t)
|
||||
|
||||
deriving stock instance Show (TypedValue t)
|
||||
|
||||
untypeValue :: TypedValue t -> A.Value
|
||||
@ -100,8 +101,9 @@ data Property = Property
|
||||
data Condition :: JsonType -> Type where
|
||||
Exactly :: TypedValue t -> Condition t
|
||||
Maximum :: !(Bound Scientific) -> Condition 'Number
|
||||
Minimum :: !(Down (Bound (Down Scientific))) -> Condition 'Number
|
||||
-- ^ this has the right Ord
|
||||
Minimum
|
||||
:: !(Down (Bound (Down Scientific)))
|
||||
-> Condition 'Number -- ^ this has the right Ord
|
||||
MultipleOf :: !Scientific -> Condition 'Number
|
||||
NumberFormat :: !Format -> Condition 'Number
|
||||
MaxLength :: !Integer -> Condition 'String
|
||||
@ -117,10 +119,8 @@ data Condition :: JsonType -> Type where
|
||||
UniqueItems :: Condition 'Array
|
||||
Properties
|
||||
:: !(M.Map Text Property)
|
||||
-> !(ForeachType JsonFormula)
|
||||
-- ^ formula for additional properties
|
||||
-> !(Maybe (Traced (Referenced Schema)))
|
||||
-- ^ schema for additional properties, Nothing means bottom
|
||||
-> !(ForeachType JsonFormula) -- ^ formula for additional properties
|
||||
-> !(Maybe (Traced (Referenced Schema))) -- ^ schema for additional properties, Nothing means bottom
|
||||
-> Condition 'Object
|
||||
MaxProperties :: !Integer -> Condition 'Object
|
||||
MinProperties :: !Integer -> Condition 'Object
|
||||
@ -136,28 +136,34 @@ satisfiesTyped (TNumber n) (NumberFormat f) = checkNumberFormat f n
|
||||
satisfiesTyped (TString s) (MaxLength m) = fromIntegral (T.length s) <= m
|
||||
satisfiesTyped (TString s) (MinLength m) = fromIntegral (T.length s) >= m
|
||||
satisfiesTyped (TString s) (Pattern p) = undefined s p -- TODO: regex stuff
|
||||
satisfiesTyped (TString s) (StringFormat f) = undefined s f-- TODO: string format
|
||||
satisfiesTyped (TString s) (StringFormat f) = undefined s f -- TODO: string format
|
||||
satisfiesTyped (TArray a) (Items f _) = all (`satisfies` f) a
|
||||
satisfiesTyped (TArray a) (MaxItems m) = fromIntegral (F.length a) <= m
|
||||
satisfiesTyped (TArray a) (MinItems m) = fromIntegral (F.length a) >= m
|
||||
satisfiesTyped (TArray a) UniqueItems = S.size (S.fromList $ F.toList a) == F.length a -- TODO: could be better
|
||||
satisfiesTyped (TObject o) (Properties props additional _)
|
||||
= all (`HM.member` o) (M.keys (M.filter propRequired props))
|
||||
&& all (\(k, v) -> satisfies v $ maybe additional propFormula $ M.lookup k props) (HM.toList o)
|
||||
satisfiesTyped (TObject o) (Properties props additional _) =
|
||||
all (`HM.member` o) (M.keys (M.filter propRequired props))
|
||||
&& all (\(k, v) -> satisfies v $ maybe additional propFormula $ M.lookup k props) (HM.toList o)
|
||||
satisfiesTyped (TObject o) (MaxProperties m) = fromIntegral (HM.size o) <= m
|
||||
satisfiesTyped (TObject o) (MinProperties m) = fromIntegral (HM.size o) >= m
|
||||
|
||||
checkNumberFormat :: Format -> Scientific -> Bool
|
||||
checkNumberFormat "int32" (toRational -> n) = denominator n == 1
|
||||
&& n >= toRational (minBound :: Int32) && n <= toRational (maxBound :: Int32)
|
||||
checkNumberFormat "int64" (toRational -> n) = denominator n == 1
|
||||
&& n >= toRational (minBound :: Int64) && n <= toRational (maxBound :: Int64)
|
||||
checkNumberFormat "int32" (toRational -> n) =
|
||||
denominator n == 1
|
||||
&& n >= toRational (minBound :: Int32)
|
||||
&& n <= toRational (maxBound :: Int32)
|
||||
checkNumberFormat "int64" (toRational -> n) =
|
||||
denominator n == 1
|
||||
&& n >= toRational (minBound :: Int64)
|
||||
&& n <= toRational (maxBound :: Int64)
|
||||
checkNumberFormat "float" _n = True
|
||||
checkNumberFormat "double" _n = True
|
||||
checkNumberFormat f _n = error $ "Invalid number format: " <> T.unpack f
|
||||
|
||||
deriving stock instance Eq (Condition t)
|
||||
|
||||
deriving stock instance Ord (Condition t)
|
||||
|
||||
deriving stock instance Show (Condition t)
|
||||
|
||||
data SomeCondition where
|
||||
@ -192,12 +198,15 @@ disjAdd (DNF yss) xs
|
||||
|
||||
instance Lattice (JsonFormula t) where
|
||||
xss \/ DNF yss = S.foldl' disjAdd xss yss
|
||||
DNF xss /\ DNF yss = F.foldl' disjAdd bottom $
|
||||
liftA2 S.union (S.toList xss) (S.toList yss)
|
||||
DNF xss /\ DNF yss =
|
||||
F.foldl' disjAdd bottom $
|
||||
liftA2 S.union (S.toList xss) (S.toList yss)
|
||||
|
||||
pattern BottomFormula :: JsonFormula t
|
||||
pattern BottomFormula <- DNF (S.null -> True)
|
||||
where BottomFormula = DNF S.empty
|
||||
pattern BottomFormula <-
|
||||
DNF (S.null -> True)
|
||||
where
|
||||
BottomFormula = DNF S.empty
|
||||
|
||||
isSingleton :: S.Set a -> Maybe a
|
||||
isSingleton s
|
||||
@ -205,17 +214,24 @@ isSingleton s
|
||||
| otherwise = Nothing
|
||||
|
||||
pattern Conjunct :: [Condition t] -> S.Set (Condition t)
|
||||
pattern Conjunct xs <- (S.toList -> xs)
|
||||
where Conjunct = S.fromList
|
||||
pattern Conjunct xs <-
|
||||
(S.toList -> xs)
|
||||
where
|
||||
Conjunct = S.fromList
|
||||
|
||||
{-# COMPLETE Conjunct #-}
|
||||
|
||||
pattern SingleConjunct :: [Condition t] -> JsonFormula t
|
||||
pattern SingleConjunct xs <- DNF (isSingleton -> Just (Conjunct xs))
|
||||
where SingleConjunct xs = DNF $ S.singleton $ Conjunct xs
|
||||
pattern SingleConjunct xs <-
|
||||
DNF (isSingleton -> Just (Conjunct xs))
|
||||
where
|
||||
SingleConjunct xs = DNF $ S.singleton $ Conjunct xs
|
||||
|
||||
pattern TopFormula :: JsonFormula t
|
||||
pattern TopFormula <- DNF (isSingleton -> Just (S.null -> True))
|
||||
where TopFormula = DNF $ S.singleton S.empty
|
||||
pattern TopFormula <-
|
||||
DNF (isSingleton -> Just (S.null -> True))
|
||||
where
|
||||
TopFormula = DNF $ S.singleton S.empty
|
||||
|
||||
instance BoundedJoinSemiLattice (JsonFormula t) where
|
||||
bottom = BottomFormula
|
||||
@ -228,8 +244,12 @@ foldLattice
|
||||
=> (Condition t -> l)
|
||||
-> JsonFormula t
|
||||
-> l
|
||||
foldLattice f (DNF xss) = S.foldl' (\z w ->
|
||||
z \/ S.foldl' (\x y -> x /\ f y) top w) bottom xss
|
||||
foldLattice f (DNF xss) =
|
||||
S.foldl'
|
||||
(\z w ->
|
||||
z \/ S.foldl' (\x y -> x /\ f y) top w)
|
||||
bottom
|
||||
xss
|
||||
|
||||
satisfiesFormula :: TypedValue t -> JsonFormula t -> Bool
|
||||
satisfiesFormula val = foldLattice (satisfiesTyped val)
|
||||
@ -253,7 +273,9 @@ satisfies val p = case val of
|
||||
A.Object o -> satisfiesFormula (TObject o) $ forObject p
|
||||
|
||||
deriving stock instance (forall x. Typeable x => Eq (f x)) => Eq (ForeachType f)
|
||||
|
||||
deriving stock instance (forall x. Typeable x => Ord (f x)) => Ord (ForeachType f)
|
||||
|
||||
deriving stock instance (forall x. Typeable x => Show (f x)) => Show (ForeachType f)
|
||||
|
||||
foldType
|
||||
@ -261,12 +283,12 @@ foldType
|
||||
=> (forall x. Typeable x => JsonType -> (ForeachType f -> f x) -> m)
|
||||
-> m
|
||||
foldType k =
|
||||
k Null forNull <>
|
||||
k Boolean forBoolean <>
|
||||
k Number forNumber <>
|
||||
k String forString <>
|
||||
k Array forArray <>
|
||||
k Object forObject
|
||||
k Null forNull
|
||||
<> k Boolean forBoolean
|
||||
<> k Number forNumber
|
||||
<> k String forString
|
||||
<> k Array forArray
|
||||
<> k Object forObject
|
||||
|
||||
forType_
|
||||
:: Applicative m
|
||||
@ -282,44 +304,52 @@ forType_ k = do
|
||||
pure ()
|
||||
|
||||
instance (forall x. Lattice (f x)) => Lattice (ForeachType f) where
|
||||
f1 \/ f2 = ForeachType
|
||||
{ forNull = forNull f1 \/ forNull f2
|
||||
, forBoolean = forBoolean f1 \/ forBoolean f2
|
||||
, forNumber = forNumber f1 \/ forNumber f2
|
||||
, forString = forString f1 \/ forString f2
|
||||
, forArray = forArray f1 \/ forArray f2
|
||||
, forObject = forObject f1 \/ forObject f2
|
||||
}
|
||||
f1 /\ f2 = ForeachType
|
||||
{ forNull = forNull f1 /\ forNull f2
|
||||
, forBoolean = forBoolean f1 /\ forBoolean f2
|
||||
, forNumber = forNumber f1 /\ forNumber f2
|
||||
, forString = forString f1 /\ forString f2
|
||||
, forArray = forArray f1 /\ forArray f2
|
||||
, forObject = forObject f1 /\ forObject f2
|
||||
}
|
||||
f1 \/ f2 =
|
||||
ForeachType
|
||||
{ forNull = forNull f1 \/ forNull f2
|
||||
, forBoolean = forBoolean f1 \/ forBoolean f2
|
||||
, forNumber = forNumber f1 \/ forNumber f2
|
||||
, forString = forString f1 \/ forString f2
|
||||
, forArray = forArray f1 \/ forArray f2
|
||||
, forObject = forObject f1 \/ forObject f2
|
||||
}
|
||||
f1 /\ f2 =
|
||||
ForeachType
|
||||
{ forNull = forNull f1 /\ forNull f2
|
||||
, forBoolean = forBoolean f1 /\ forBoolean f2
|
||||
, forNumber = forNumber f1 /\ forNumber f2
|
||||
, forString = forString f1 /\ forString f2
|
||||
, forArray = forArray f1 /\ forArray f2
|
||||
, forObject = forObject f1 /\ forObject f2
|
||||
}
|
||||
|
||||
instance (forall x. BoundedJoinSemiLattice (f x))
|
||||
=> BoundedJoinSemiLattice (ForeachType f) where
|
||||
bottom = ForeachType
|
||||
{ forNull = bottom
|
||||
, forBoolean = bottom
|
||||
, forNumber = bottom
|
||||
, forString = bottom
|
||||
, forArray = bottom
|
||||
, forObject = bottom
|
||||
}
|
||||
instance
|
||||
(forall x. BoundedJoinSemiLattice (f x))
|
||||
=> BoundedJoinSemiLattice (ForeachType f)
|
||||
where
|
||||
bottom =
|
||||
ForeachType
|
||||
{ forNull = bottom
|
||||
, forBoolean = bottom
|
||||
, forNumber = bottom
|
||||
, forString = bottom
|
||||
, forArray = bottom
|
||||
, forObject = bottom
|
||||
}
|
||||
|
||||
instance (forall x. BoundedMeetSemiLattice (f x))
|
||||
=> BoundedMeetSemiLattice (ForeachType f) where
|
||||
top = ForeachType
|
||||
{ forNull = top
|
||||
, forBoolean = top
|
||||
, forNumber = top
|
||||
, forString = top
|
||||
, forArray = top
|
||||
, forObject = top
|
||||
}
|
||||
instance
|
||||
(forall x. BoundedMeetSemiLattice (f x))
|
||||
=> BoundedMeetSemiLattice (ForeachType f)
|
||||
where
|
||||
top =
|
||||
ForeachType
|
||||
{ forNull = top
|
||||
, forBoolean = top
|
||||
, forNumber = top
|
||||
, forString = top
|
||||
, forArray = top
|
||||
, forObject = top
|
||||
}
|
||||
|
||||
{- TODO: remove
|
||||
instance Typeable t => Steppable Schema (Condition t) where
|
||||
@ -356,9 +386,26 @@ instance Steppable Schema (Referenced Schema) where
|
||||
| ItemsObjectStep
|
||||
| ItemsArrayStep Int
|
||||
| AdditionalPropertiesStep
|
||||
| PropertiesStep Text
|
||||
| NotStep
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance Steppable Schema (Definitions (Referenced Schema)) where
|
||||
data Step Schema (Definitions (Referenced Schema)) = PropertiesStep
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance Steppable Schema Discriminator where
|
||||
data Step Schema Discriminator = DiscriminatorStep
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance Steppable Discriminator (Definitions (Referenced Schema)) where
|
||||
data Step Discriminator (Definitions (Referenced Schema)) = DiscriminatorMapping
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
parseDiscriminatorValue :: Text -> Referenced Schema
|
||||
parseDiscriminatorValue v = case A.fromJSON @(Referenced Schema) $ A.object ["$ref" A..= v] of
|
||||
A.Success x -> x
|
||||
A.Error _ -> Ref $ Reference v
|
||||
|
||||
type ProcessM = ReaderT (Traced (Definitions Schema)) (Writer (P.PathsPrefixTree Behave AnIssue 'SchemaLevel))
|
||||
|
||||
warn :: Issue 'SchemaLevel -> ProcessM ()
|
||||
@ -372,31 +419,42 @@ processRefSchema x = do
|
||||
processSchema $ dereference defs x
|
||||
|
||||
tracedAllOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]
|
||||
tracedAllOf sch = _schemaAllOf (extract sch) <&> \xs ->
|
||||
[ traced (ask sch >>> step (AllOfStep i)) x | (i, x) <- zip [0..] xs ]
|
||||
tracedAllOf sch =
|
||||
_schemaAllOf (extract sch) <&> \xs ->
|
||||
[traced (ask sch >>> step (AllOfStep i)) x | (i, x) <- zip [0 ..] xs]
|
||||
|
||||
tracedAnyOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]
|
||||
tracedAnyOf sch = _schemaAnyOf (extract sch) <&> \xs ->
|
||||
[ traced (ask sch >>> step (AnyOfStep i)) x | (i, x) <- zip [0..] xs ]
|
||||
tracedAnyOf sch =
|
||||
_schemaAnyOf (extract sch) <&> \xs ->
|
||||
[traced (ask sch >>> step (AnyOfStep i)) x | (i, x) <- zip [0 ..] xs]
|
||||
|
||||
tracedOneOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]
|
||||
tracedOneOf sch = _schemaOneOf (extract sch) <&> \xs ->
|
||||
[ traced (ask sch >>> step (OneOfStep i)) x | (i, x) <- zip [0..] xs ]
|
||||
tracedOneOf sch =
|
||||
_schemaOneOf (extract sch) <&> \xs ->
|
||||
[traced (ask sch >>> step (OneOfStep i)) x | (i, x) <- zip [0 ..] xs]
|
||||
|
||||
tracedItems :: Traced Schema -> Maybe (Either (Traced (Referenced Schema)) [Traced (Referenced Schema)])
|
||||
tracedItems sch = _schemaItems (extract sch) <&> \case
|
||||
OpenApiItemsObject x -> Left $ traced (ask sch >>> step ItemsObjectStep) x
|
||||
OpenApiItemsArray xs -> Right
|
||||
[ traced (ask sch >>> step (ItemsArrayStep i)) x | (i, x) <- zip [0..] xs ]
|
||||
tracedItems sch =
|
||||
_schemaItems (extract sch) <&> \case
|
||||
OpenApiItemsObject x -> Left $ traced (ask sch >>> step ItemsObjectStep) x
|
||||
OpenApiItemsArray xs ->
|
||||
Right
|
||||
[traced (ask sch >>> step (ItemsArrayStep i)) x | (i, x) <- zip [0 ..] xs]
|
||||
|
||||
tracedAdditionalProperties :: Traced Schema -> Maybe (Either Bool (Traced (Referenced Schema)))
|
||||
tracedAdditionalProperties sch = _schemaAdditionalProperties (extract sch) <&> \case
|
||||
AdditionalPropertiesAllowed b -> Left b
|
||||
AdditionalPropertiesSchema x -> Right $ traced (ask sch >>> step AdditionalPropertiesStep) x
|
||||
tracedAdditionalProperties sch =
|
||||
_schemaAdditionalProperties (extract sch) <&> \case
|
||||
AdditionalPropertiesAllowed b -> Left b
|
||||
AdditionalPropertiesSchema x -> Right $ traced (ask sch >>> step AdditionalPropertiesStep) x
|
||||
|
||||
tracedDiscriminator :: Traced Schema -> Maybe (Traced Discriminator)
|
||||
tracedDiscriminator = sequence . stepTraced DiscriminatorStep . fmap _schemaDiscriminator
|
||||
|
||||
tracedProperties :: Traced Schema -> IOHM.InsOrdHashMap Text (Traced (Referenced Schema))
|
||||
tracedProperties sch = IOHM.mapWithKey (\k -> traced (ask sch >>> step (PropertiesStep k)))
|
||||
$ _schemaProperties $ extract sch
|
||||
tracedProperties sch =
|
||||
IOHM.mapWithKey
|
||||
(\k -> traced (ask sch >>> step PropertiesStep >>> step (InsOrdHashMapKeyStep k)))
|
||||
(_schemaProperties $ extract sch)
|
||||
|
||||
-- | Turn a schema into a tuple of 'JsonFormula's that describes the condition
|
||||
-- for every possible type of a JSON value. The conditions are independent, and
|
||||
@ -404,10 +462,9 @@ tracedProperties sch = IOHM.mapWithKey (\k -> traced (ask sch >>> step (Properti
|
||||
processSchema
|
||||
:: Traced Schema
|
||||
-> ProcessM (ForeachType JsonFormula)
|
||||
processSchema sch@(extract -> Schema{..}) = do
|
||||
let
|
||||
singletonFormula :: Condition t -> JsonFormula t
|
||||
singletonFormula f = SingleConjunct [f]
|
||||
processSchema sch@(extract -> Schema {..}) = do
|
||||
let singletonFormula :: Condition t -> JsonFormula t
|
||||
singletonFormula f = SingleConjunct [f]
|
||||
|
||||
allClauses <- case tracedAllOf sch of
|
||||
Nothing -> pure []
|
||||
@ -432,110 +489,160 @@ processSchema sch@(extract -> Schema{..}) = do
|
||||
Nothing -> pure ()
|
||||
Just _ -> warn (NotSupported "not clause is unsupported")
|
||||
|
||||
let
|
||||
typeClause = case _schemaType of
|
||||
Nothing -> top
|
||||
Just OpenApiNull -> bottom
|
||||
{ forNull = top }
|
||||
Just OpenApiBoolean -> bottom
|
||||
{ forBoolean = top }
|
||||
Just OpenApiNumber -> bottom
|
||||
{ forBoolean = top }
|
||||
Just OpenApiInteger -> bottom
|
||||
{ forNumber = singletonFormula $ MultipleOf 1 }
|
||||
Just OpenApiString -> bottom
|
||||
{ forString = top }
|
||||
Just OpenApiArray -> bottom
|
||||
{ forArray = top }
|
||||
Just OpenApiObject -> bottom
|
||||
{ forObject = top }
|
||||
let typeClause = case _schemaType of
|
||||
Nothing -> top
|
||||
Just OpenApiNull ->
|
||||
bottom
|
||||
{ forNull = top
|
||||
}
|
||||
Just OpenApiBoolean ->
|
||||
bottom
|
||||
{ forBoolean = top
|
||||
}
|
||||
Just OpenApiNumber ->
|
||||
bottom
|
||||
{ forBoolean = top
|
||||
}
|
||||
Just OpenApiInteger ->
|
||||
bottom
|
||||
{ forNumber = singletonFormula $ MultipleOf 1
|
||||
}
|
||||
Just OpenApiString ->
|
||||
bottom
|
||||
{ forString = top
|
||||
}
|
||||
Just OpenApiArray ->
|
||||
bottom
|
||||
{ forArray = top
|
||||
}
|
||||
Just OpenApiObject ->
|
||||
bottom
|
||||
{ forObject = top
|
||||
}
|
||||
|
||||
let
|
||||
valueEnum A.Null = bottom
|
||||
{ forNull = singletonFormula $ Exactly TNull }
|
||||
valueEnum (A.Bool b) = bottom
|
||||
{ forBoolean = singletonFormula $ Exactly $ TBool b }
|
||||
valueEnum (A.Number n) = bottom
|
||||
{ forNumber = singletonFormula $ Exactly $ TNumber n }
|
||||
valueEnum (A.String s) = bottom
|
||||
{ forString = singletonFormula $ Exactly $ TString s }
|
||||
valueEnum (A.Array a) = bottom
|
||||
{ forArray = singletonFormula $ Exactly $ TArray a }
|
||||
valueEnum (A.Object o) = bottom
|
||||
{ forObject = singletonFormula $ Exactly $ TObject o }
|
||||
let valueEnum A.Null =
|
||||
bottom
|
||||
{ forNull = singletonFormula $ Exactly TNull
|
||||
}
|
||||
valueEnum (A.Bool b) =
|
||||
bottom
|
||||
{ forBoolean = singletonFormula $ Exactly $ TBool b
|
||||
}
|
||||
valueEnum (A.Number n) =
|
||||
bottom
|
||||
{ forNumber = singletonFormula $ Exactly $ TNumber n
|
||||
}
|
||||
valueEnum (A.String s) =
|
||||
bottom
|
||||
{ forString = singletonFormula $ Exactly $ TString s
|
||||
}
|
||||
valueEnum (A.Array a) =
|
||||
bottom
|
||||
{ forArray = singletonFormula $ Exactly $ TArray a
|
||||
}
|
||||
valueEnum (A.Object o) =
|
||||
bottom
|
||||
{ forObject = singletonFormula $ Exactly $ TObject o
|
||||
}
|
||||
enumClause <- case _schemaEnum of
|
||||
Nothing -> pure top
|
||||
Just [] -> bottom <$ warn (InvalidSchema "no items in enum")
|
||||
Just xs -> pure $ joins (valueEnum <$> xs)
|
||||
|
||||
let
|
||||
maximumClause = case _schemaMaximum of
|
||||
Nothing -> top
|
||||
Just n -> top
|
||||
{ forNumber = singletonFormula $ Maximum $
|
||||
case _schemaExclusiveMaximum of
|
||||
Just True -> Exclusive n
|
||||
_ -> Inclusive n }
|
||||
let maximumClause = case _schemaMaximum of
|
||||
Nothing -> top
|
||||
Just n ->
|
||||
top
|
||||
{ forNumber = singletonFormula $
|
||||
Maximum $
|
||||
case _schemaExclusiveMaximum of
|
||||
Just True -> Exclusive n
|
||||
_ -> Inclusive n
|
||||
}
|
||||
|
||||
minimumClause = case _schemaMinimum of
|
||||
Nothing -> top
|
||||
Just n -> top
|
||||
{ forNumber = singletonFormula $ Minimum $ Down $
|
||||
case _schemaExclusiveMinimum of
|
||||
Just True -> Exclusive $ Down n
|
||||
_ -> Inclusive $ Down n }
|
||||
minimumClause = case _schemaMinimum of
|
||||
Nothing -> top
|
||||
Just n ->
|
||||
top
|
||||
{ forNumber = singletonFormula $
|
||||
Minimum $
|
||||
Down $
|
||||
case _schemaExclusiveMinimum of
|
||||
Just True -> Exclusive $ Down n
|
||||
_ -> Inclusive $ Down n
|
||||
}
|
||||
|
||||
multipleOfClause = case _schemaMultipleOf of
|
||||
Nothing -> top
|
||||
Just n -> top
|
||||
{ forNumber = singletonFormula $ MultipleOf n }
|
||||
multipleOfClause = case _schemaMultipleOf of
|
||||
Nothing -> top
|
||||
Just n ->
|
||||
top
|
||||
{ forNumber = singletonFormula $ MultipleOf n
|
||||
}
|
||||
|
||||
formatClause <- case _schemaFormat of
|
||||
Nothing -> pure top
|
||||
Just f | f `elem` ["int32", "int64", "float", "double"] -> pure top
|
||||
{ forNumber = singletonFormula $ NumberFormat f }
|
||||
Just f | f `elem` ["byte", "binary", "date", "date-time", "password"] -> pure top
|
||||
{ forString = singletonFormula $ StringFormat f }
|
||||
Just f
|
||||
| f `elem` ["int32", "int64", "float", "double"] ->
|
||||
pure
|
||||
top
|
||||
{ forNumber = singletonFormula $ NumberFormat f
|
||||
}
|
||||
Just f
|
||||
| f `elem` ["byte", "binary", "date", "date-time", "password"] ->
|
||||
pure
|
||||
top
|
||||
{ forString = singletonFormula $ StringFormat f
|
||||
}
|
||||
Just f -> top <$ warn (NotSupported $ "Unknown format: " <> f)
|
||||
|
||||
let
|
||||
maxLengthClause = case _schemaMaxLength of
|
||||
Nothing -> top
|
||||
Just n -> top
|
||||
{ forString = singletonFormula $ MaxLength n }
|
||||
let maxLengthClause = case _schemaMaxLength of
|
||||
Nothing -> top
|
||||
Just n ->
|
||||
top
|
||||
{ forString = singletonFormula $ MaxLength n
|
||||
}
|
||||
|
||||
minLengthClause = case _schemaMinLength of
|
||||
Nothing -> top
|
||||
Just n -> top
|
||||
{ forString = singletonFormula $ MinLength n }
|
||||
minLengthClause = case _schemaMinLength of
|
||||
Nothing -> top
|
||||
Just n ->
|
||||
top
|
||||
{ forString = singletonFormula $ MinLength n
|
||||
}
|
||||
|
||||
patternClause = case _schemaPattern of
|
||||
Nothing -> top
|
||||
Just p -> top
|
||||
{ forString = singletonFormula $ Pattern p }
|
||||
patternClause = case _schemaPattern of
|
||||
Nothing -> top
|
||||
Just p ->
|
||||
top
|
||||
{ forString = singletonFormula $ Pattern p
|
||||
}
|
||||
|
||||
itemsClause <- case tracedItems sch of
|
||||
Nothing -> pure top
|
||||
Just (Left rs) -> do
|
||||
f <- processRefSchema rs
|
||||
pure top { forArray = singletonFormula $ Items f rs }
|
||||
pure top {forArray = singletonFormula $ Items f rs}
|
||||
Just (Right _) -> top <$ warn (NotSupported "array in items is not supported")
|
||||
|
||||
let
|
||||
maxItemsClause = case _schemaMaxItems of
|
||||
Nothing -> top
|
||||
Just n -> top
|
||||
{ forArray = singletonFormula $ MaxItems n }
|
||||
let maxItemsClause = case _schemaMaxItems of
|
||||
Nothing -> top
|
||||
Just n ->
|
||||
top
|
||||
{ forArray = singletonFormula $ MaxItems n
|
||||
}
|
||||
|
||||
minItemsClause = case _schemaMinItems of
|
||||
Nothing -> top
|
||||
Just n -> top
|
||||
{ forArray = singletonFormula $ MinItems n }
|
||||
minItemsClause = case _schemaMinItems of
|
||||
Nothing -> top
|
||||
Just n ->
|
||||
top
|
||||
{ forArray = singletonFormula $ MinItems n
|
||||
}
|
||||
|
||||
uniqueItemsClause = case _schemaUniqueItems of
|
||||
Just True -> top
|
||||
{ forArray = singletonFormula UniqueItems }
|
||||
_ -> top
|
||||
uniqueItemsClause = case _schemaUniqueItems of
|
||||
Just True ->
|
||||
top
|
||||
{ forArray = singletonFormula UniqueItems
|
||||
}
|
||||
_ -> top
|
||||
|
||||
(addProps, addPropSchema) <- case tracedAdditionalProperties sch of
|
||||
Just (Right rs) -> (,Just rs) <$> processRefSchema rs
|
||||
@ -544,50 +651,79 @@ processSchema sch@(extract -> Schema{..}) = do
|
||||
propList <- forM (S.toList . S.fromList $ IOHM.keys _schemaProperties <> _schemaRequired) $ \k -> do
|
||||
(f, psch) <- case IOHM.lookup k $ tracedProperties sch of
|
||||
Just rs -> (,rs) <$> processRefSchema rs
|
||||
Nothing -> let fakeSchema = traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty
|
||||
-- The mempty here is incorrect, but if addPropSchema was Nothing, then
|
||||
-- addProps is bottom, and k is in _schemaRequired. We handle this situation
|
||||
-- below and short-circuit the entire Properties condition to bottom
|
||||
in pure (addProps, fromMaybe fakeSchema addPropSchema)
|
||||
Nothing ->
|
||||
let fakeSchema = traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty
|
||||
in -- The mempty here is incorrect, but if addPropSchema was Nothing, then
|
||||
-- addProps is bottom, and k is in _schemaRequired. We handle this situation
|
||||
-- below and short-circuit the entire Properties condition to bottom
|
||||
pure (addProps, fromMaybe fakeSchema addPropSchema)
|
||||
pure (k, Property (k `elem` _schemaRequired) f psch)
|
||||
let
|
||||
allBottom f = getAll $ foldType $ \_ ty -> case ty f of
|
||||
BottomFormula -> All True
|
||||
_ -> All False
|
||||
allTop f = getAll $ foldType $ \_ ty -> case ty f of
|
||||
TopFormula -> All True
|
||||
_ -> All False
|
||||
-- remove optional fields whose schemata match that of additional props
|
||||
propMap = M.filter (\p -> propRequired p || propFormula p /= addProps) $ M.fromList propList
|
||||
propertiesClause
|
||||
| any (\p -> propRequired p && allBottom (propFormula p)) propMap
|
||||
= bottom -- if any required field has unsatisfiable schema
|
||||
| M.null propMap, allTop addProps
|
||||
= top -- if all fields are optional and have trivial schemata
|
||||
| otherwise
|
||||
= top
|
||||
{ forObject = singletonFormula $ Properties propMap addProps addPropSchema }
|
||||
let allBottom f = getAll $
|
||||
foldType $ \_ ty -> case ty f of
|
||||
BottomFormula -> All True
|
||||
_ -> All False
|
||||
allTop f = getAll $
|
||||
foldType $ \_ ty -> case ty f of
|
||||
TopFormula -> All True
|
||||
_ -> All False
|
||||
-- remove optional fields whose schemata match that of additional props
|
||||
propMap = M.filter (\p -> propRequired p || propFormula p /= addProps) $ M.fromList propList
|
||||
propertiesClause
|
||||
| any (\p -> propRequired p && allBottom (propFormula p)) propMap =
|
||||
bottom -- if any required field has unsatisfiable schema
|
||||
| M.null propMap
|
||||
, allTop addProps =
|
||||
top -- if all fields are optional and have trivial schemata
|
||||
| otherwise =
|
||||
top
|
||||
{ forObject = singletonFormula $ Properties propMap addProps addPropSchema
|
||||
}
|
||||
|
||||
maxPropertiesClause = case _schemaMaxProperties of
|
||||
Nothing -> top
|
||||
Just n -> top
|
||||
{ forObject = singletonFormula $ MaxProperties n }
|
||||
maxPropertiesClause = case _schemaMaxProperties of
|
||||
Nothing -> top
|
||||
Just n ->
|
||||
top
|
||||
{ forObject = singletonFormula $ MaxProperties n
|
||||
}
|
||||
|
||||
minPropertiesClause = case _schemaMinProperties of
|
||||
Nothing -> top
|
||||
Just n -> top
|
||||
{ forObject = singletonFormula $ MinProperties n }
|
||||
minPropertiesClause = case _schemaMinProperties of
|
||||
Nothing -> top
|
||||
Just n ->
|
||||
top
|
||||
{ forObject = singletonFormula $ MinProperties n
|
||||
}
|
||||
|
||||
nullableClause
|
||||
| Just True <- _schemaNullable =
|
||||
bottom
|
||||
{ forNull = singletonFormula $ Exactly TNull
|
||||
}
|
||||
| otherwise = bottom
|
||||
|
||||
pure $
|
||||
nullableClause
|
||||
| Just True <- _schemaNullable = bottom
|
||||
{ forNull = singletonFormula $ Exactly TNull }
|
||||
| otherwise = bottom
|
||||
\/ meets
|
||||
(allClauses
|
||||
<> [ anyClause
|
||||
, oneClause
|
||||
, typeClause
|
||||
, enumClause
|
||||
, maximumClause
|
||||
, minimumClause
|
||||
, multipleOfClause
|
||||
, formatClause
|
||||
, maxLengthClause
|
||||
, minLengthClause
|
||||
, patternClause
|
||||
, itemsClause
|
||||
, maxItemsClause
|
||||
, minItemsClause
|
||||
, uniqueItemsClause
|
||||
, propertiesClause
|
||||
, maxPropertiesClause
|
||||
, minPropertiesClause
|
||||
])
|
||||
|
||||
pure $ nullableClause \/ meets (allClauses <>
|
||||
[ anyClause, oneClause, typeClause, enumClause, maximumClause, minimumClause
|
||||
, multipleOfClause, formatClause, maxLengthClause, minLengthClause
|
||||
, patternClause, itemsClause, maxItemsClause, minItemsClause
|
||||
, uniqueItemsClause, propertiesClause, maxPropertiesClause, minPropertiesClause])
|
||||
{- TODO: ReadOnly/WriteOnly -}
|
||||
|
||||
checkOneOfDisjoint :: [Traced (Referenced Schema)] -> ProcessM Bool
|
||||
@ -607,7 +743,7 @@ checkFormulas
|
||||
-> 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
|
||||
issues@(_ : _) -> F.for_ issues $ \(AnItem t (AnIssue e)) -> issueAt (beh >>> t) e
|
||||
[] -> do
|
||||
-- We have the following isomorphisms:
|
||||
-- (A ⊂ X ∪ Y) = (A ⊂ X) \/ (A ⊂ Y)
|
||||
@ -643,7 +779,9 @@ checkFormulas env beh (ProdCons (fp, ep) (fc, ec)) =
|
||||
(DNF pss, SingleConjunct cs) -> F.for_ pss $ \(Conjunct ps) -> do
|
||||
F.for_ cs $ checkImplication env beh' ps -- avoid disjuntion if there's only one conjunct
|
||||
(DNF pss, DNF css) -> F.for_ pss $ \(Conjunct ps) -> do
|
||||
anyOfAt beh' (NoMatchingCondition $ SomeCondition <$> ps)
|
||||
anyOfAt
|
||||
beh'
|
||||
(NoMatchingCondition $ SomeCondition <$> ps)
|
||||
[F.for_ cs $ checkImplication env beh' ps | Conjunct cs <- S.toList css]
|
||||
|
||||
checkContradiction
|
||||
@ -662,54 +800,77 @@ checkImplication
|
||||
checkImplication env beh prods cons = case findExactly prods of
|
||||
Just e
|
||||
| all (satisfiesTyped e) prods ->
|
||||
if satisfiesTyped e cons then pure ()
|
||||
if satisfiesTyped e cons
|
||||
then pure ()
|
||||
else issueAt beh (EnumDoesntSatisfy $ untypeValue e)
|
||||
| otherwise -> pure () -- vacuously true
|
||||
Nothing -> case cons of
|
||||
-- the above code didn't catch it, so there's no Exactly condition on the lhs
|
||||
Exactly e -> issueAt beh (NoMatchingEnum $ untypeValue e)
|
||||
Maximum m -> case findRelevant min (\case Maximum m' -> Just m'; _ -> Nothing) prods of
|
||||
Just m' -> if m' <= m then pure ()
|
||||
else issueAt beh (MatchingMaximumWeak m m')
|
||||
Just m' ->
|
||||
if m' <= m
|
||||
then pure ()
|
||||
else issueAt beh (MatchingMaximumWeak m m')
|
||||
Nothing -> issueAt beh (NoMatchingMaximum m)
|
||||
Minimum m -> case findRelevant max (\case Minimum m' -> Just m'; _ -> Nothing) prods of
|
||||
Just m' -> if m' >= m then pure ()
|
||||
else issueAt beh (MatchingMinimumWeak (coerce m) (coerce m'))
|
||||
Just m' ->
|
||||
if m' >= m
|
||||
then pure ()
|
||||
else issueAt beh (MatchingMinimumWeak (coerce m) (coerce m'))
|
||||
Nothing -> issueAt beh (NoMatchingMinimum (coerce m))
|
||||
MultipleOf m -> case findRelevant lcmScientific (\case MultipleOf m' -> Just m'; _ -> Nothing) prods of
|
||||
Just m' -> if lcmScientific m m' == m' then pure ()
|
||||
else issueAt beh (MatchingMultipleOfWeak m m')
|
||||
Just m' ->
|
||||
if lcmScientific m m' == m'
|
||||
then pure ()
|
||||
else issueAt beh (MatchingMultipleOfWeak m m')
|
||||
Nothing -> issueAt beh (NoMatchingMultipleOf m)
|
||||
NumberFormat f -> if any (\case NumberFormat f' -> f == f'; _ -> False) prods
|
||||
then pure () else issueAt beh (NoMatchingFormat f)
|
||||
NumberFormat f ->
|
||||
if any (\case NumberFormat f' -> f == f'; _ -> False) prods
|
||||
then pure ()
|
||||
else issueAt beh (NoMatchingFormat f)
|
||||
MaxLength m -> case findRelevant min (\case MaxLength m' -> Just m'; _ -> Nothing) prods of
|
||||
Just m' -> if m' <= m then pure ()
|
||||
else issueAt beh (MatchingMaxLengthWeak m m')
|
||||
Just m' ->
|
||||
if m' <= m
|
||||
then pure ()
|
||||
else issueAt beh (MatchingMaxLengthWeak m m')
|
||||
Nothing -> issueAt beh (NoMatchingMaxLength m)
|
||||
MinLength m -> case findRelevant max (\case MinLength m' -> Just m'; _ -> Nothing) prods of
|
||||
Just m' -> if m' >= m then pure ()
|
||||
else issueAt beh (MatchingMinLengthWeak m m')
|
||||
Just m' ->
|
||||
if m' >= m
|
||||
then pure ()
|
||||
else issueAt beh (MatchingMinLengthWeak m m')
|
||||
Nothing -> issueAt beh (NoMatchingMinLength m)
|
||||
Pattern p -> if any (\case Pattern p' -> p == p'; _ -> False) prods
|
||||
then pure () else issueAt beh (NoMatchingPattern p) -- TODO: regex comparison
|
||||
StringFormat f -> if any (\case StringFormat f' -> f == f'; _ -> False) prods
|
||||
then pure () else issueAt beh (NoMatchingFormat f)
|
||||
Pattern p ->
|
||||
if any (\case Pattern p' -> p == p'; _ -> False) prods
|
||||
then pure ()
|
||||
else issueAt beh (NoMatchingPattern p) -- TODO: regex comparison
|
||||
StringFormat f ->
|
||||
if any (\case StringFormat f' -> f == f'; _ -> False) prods
|
||||
then pure ()
|
||||
else issueAt beh (NoMatchingFormat f)
|
||||
Items _ cons' -> case findRelevant (<>) (\case Items _ rs -> Just (rs NE.:| []); _ -> Nothing) prods of
|
||||
Just (rs NE.:| []) -> checkCompatibility env (beh >>> step InItems) $ ProdCons rs cons'
|
||||
Just rs -> do
|
||||
let sch = Inline mempty { _schemaAllOf = Just . NE.toList $ extract <$> rs }
|
||||
let sch = Inline mempty {_schemaAllOf = Just . NE.toList $ extract <$> rs}
|
||||
checkCompatibility env (beh >>> step InItems) $ ProdCons (traced (ask $ NE.head rs) sch) cons' -- TODO: bad trace
|
||||
Nothing -> issueAt beh NoMatchingItems
|
||||
MaxItems m -> case findRelevant min (\case MaxItems m' -> Just m'; _ -> Nothing) prods of
|
||||
Just m' -> if m' <= m then pure ()
|
||||
else issueAt beh (MatchingMaxItemsWeak m m')
|
||||
Just m' ->
|
||||
if m' <= m
|
||||
then pure ()
|
||||
else issueAt beh (MatchingMaxItemsWeak m m')
|
||||
Nothing -> issueAt beh (NoMatchingMaxItems m)
|
||||
MinItems m -> case findRelevant max (\case MinItems m' -> Just m'; _ -> Nothing) prods of
|
||||
Just m' -> if m' >= m then pure ()
|
||||
else issueAt beh (MatchingMinItemsWeak m m')
|
||||
Just m' ->
|
||||
if m' >= m
|
||||
then pure ()
|
||||
else issueAt beh (MatchingMinItemsWeak m m')
|
||||
Nothing -> issueAt beh (NoMatchingMinItems m)
|
||||
UniqueItems -> if any (== UniqueItems) $ prods then pure ()
|
||||
else issueAt beh NoMatchingUniqueItems
|
||||
UniqueItems ->
|
||||
if any (== UniqueItems) $ prods
|
||||
then pure ()
|
||||
else issueAt beh NoMatchingUniqueItems
|
||||
Properties props _ madd -> case findRelevant (<>) (\case Properties props' _ madd' -> Just $ (props', madd') NE.:| []; _ -> Nothing) prods of
|
||||
Just ((props', madd') NE.:| []) -> do
|
||||
F.for_ (S.fromList $ M.keys props <> M.keys props') $ \k -> do
|
||||
@ -732,21 +893,25 @@ checkImplication env beh prods cons = case findExactly prods of
|
||||
pure ()
|
||||
Nothing -> issueAt beh NoMatchingProperties
|
||||
MaxProperties m -> case findRelevant min (\case MaxProperties m' -> Just m'; _ -> Nothing) prods of
|
||||
Just m' -> if m' <= m then pure ()
|
||||
else issueAt beh (MatchingMaxPropertiesWeak m m')
|
||||
Just m' ->
|
||||
if m' <= m
|
||||
then pure ()
|
||||
else issueAt beh (MatchingMaxPropertiesWeak m m')
|
||||
Nothing -> issueAt beh (NoMatchingMaxProperties m)
|
||||
MinProperties m -> case findRelevant max (\case MinProperties m' -> Just m'; _ -> Nothing) prods of
|
||||
Just m' -> if m' >= m then pure ()
|
||||
else issueAt beh (MatchingMinPropertiesWeak m m')
|
||||
Just m' ->
|
||||
if m' >= m
|
||||
then pure ()
|
||||
else issueAt beh (MatchingMinPropertiesWeak m m')
|
||||
Nothing -> issueAt beh (NoMatchingMinProperties m)
|
||||
where
|
||||
findExactly (Exactly x:_) = Just x
|
||||
findExactly (_:xs) = findExactly xs
|
||||
findExactly (Exactly x : _) = Just x
|
||||
findExactly (_ : xs) = findExactly xs
|
||||
findExactly [] = Nothing
|
||||
findRelevant combine extr
|
||||
= fmap (foldr1 combine) . NE.nonEmpty . mapMaybe extr
|
||||
lcmScientific (toRational -> a) (toRational -> b)
|
||||
= fromRational $ lcm (numerator a) (numerator b) % gcd (denominator a) (denominator b)
|
||||
findRelevant combine extr =
|
||||
fmap (foldr1 combine) . NE.nonEmpty . mapMaybe extr
|
||||
lcmScientific (toRational -> a) (toRational -> b) =
|
||||
fromRational $ lcm (numerator a) (numerator b) % gcd (denominator a) (denominator b)
|
||||
|
||||
instance Issuable 'TypedSchemaLevel where
|
||||
data Issue 'TypedSchemaLevel
|
||||
@ -806,59 +971,52 @@ instance Subtree Schema where
|
||||
type SubtreeLevel Schema = 'SchemaLevel
|
||||
type CheckEnv Schema = '[ProdCons (Traced (Definitions Schema))]
|
||||
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
|
||||
structuralEq $ fmap _schemaRequired <$> pc
|
||||
structuralEq $ fmap _schemaNullable <$> pc
|
||||
structuralMaybeWith (structuralList env) $ tracedAllOf <$> pc
|
||||
structuralMaybeWith (structuralList env) $ tracedOneOf <$> pc
|
||||
structuralMaybe env $ sequence . stepTraced NotStep . fmap _schemaNot <$> pc
|
||||
structuralMaybeWith (structuralList env) $ tracedAnyOf <$> pc
|
||||
iohmStructural env $ stepTraced PropertiesStep . fmap _schemaProperties <$> pc
|
||||
structuralMaybeWith structuralAdditionalProperties $ tracedAdditionalProperties <$> pc
|
||||
structuralMaybeWith structuralDiscriminator $ tracedDiscriminator <$> pc
|
||||
structuralEq $ fmap _schemaReadOnly <$> pc
|
||||
structuralEq $ fmap _schemaWriteOnly <$> pc
|
||||
structuralEq $ fmap _schemaXml <$> pc
|
||||
structuralEq $ fmap _schemaMaxProperties <$> pc
|
||||
structuralEq $ fmap _schemaMinProperties <$> pc
|
||||
structuralEq $ fmap _schemaDefault <$> pc
|
||||
structuralEq $ fmap _schemaType <$> pc
|
||||
structuralEq $ fmap _schemaFormat <$> pc
|
||||
structuralMaybeWith structuralItems $ tracedItems <$> pc
|
||||
structuralEq $ fmap _schemaMaximum <$> pc
|
||||
structuralEq $ fmap _schemaExclusiveMaximum <$> pc
|
||||
structuralEq $ fmap _schemaMinimum <$> pc
|
||||
structuralEq $ fmap _schemaExclusiveMinimum <$> pc
|
||||
structuralEq $ fmap _schemaMaxLength <$> pc
|
||||
structuralEq $ fmap _schemaMinLength <$> pc
|
||||
structuralEq $ fmap _schemaPattern <$> pc
|
||||
structuralEq $ fmap _schemaMaxItems <$> pc
|
||||
structuralEq $ fmap _schemaMinItems <$> pc
|
||||
structuralEq $ fmap _schemaUniqueItems <$> pc
|
||||
structuralEq $ fmap _schemaEnum <$> pc
|
||||
structuralEq $ fmap _schemaMultipleOf <$> pc
|
||||
pure ()
|
||||
where
|
||||
structuralAdditionalProperties
|
||||
(ProdCons (AdditionalPropertiesAllowed x) (AdditionalPropertiesAllowed y)) =
|
||||
structuralEq $ ProdCons x y
|
||||
(ProdCons (Left x) (Left y)) = unless (x == y) structuralIssue
|
||||
structuralAdditionalProperties
|
||||
(ProdCons (AdditionalPropertiesSchema x) (AdditionalPropertiesSchema y)) =
|
||||
checkStructuralCompatibility env $ ProdCons x y
|
||||
(ProdCons (Right x) (Right y)) =
|
||||
checkSubstructure 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')
|
||||
structuralEq $ fmap _discriminatorPropertyName <$> pc'
|
||||
iohmStructural env $
|
||||
stepTraced DiscriminatorMapping . fmap (fmap parseDiscriminatorValue . _discriminatorMapping) <$> pc'
|
||||
pure ()
|
||||
structuralItems (ProdCons (OpenApiItemsObject a) (OpenApiItemsObject b)) =
|
||||
checkStructuralCompatibility env $ ProdCons a b
|
||||
structuralItems (ProdCons (OpenApiItemsArray a) (OpenApiItemsArray b)) =
|
||||
structuralItems (ProdCons (Left a) (Left b)) =
|
||||
checkSubstructure env $ ProdCons a b
|
||||
structuralItems (ProdCons (Right a) (Right b)) =
|
||||
structuralList env $ ProdCons a b
|
||||
structuralItems _ = structuralIssue
|
||||
checkSemanticCompatibility env beh schs = do
|
||||
|
@ -49,7 +49,7 @@ instance Subtree [Server] where
|
||||
type SubtreeLevel [Server] = 'OperationLevel
|
||||
type CheckEnv [Server] = '[]
|
||||
checkStructuralCompatibility _ pc =
|
||||
structuralEq $ S.fromList . fmap reduceServer <$> pc
|
||||
structuralEq $ fmap S.fromList . (fmap . fmap) reduceServer <$> pc
|
||||
where
|
||||
reducerServerVariable =
|
||||
fmap IOHM.toHashSet . _serverVariableEnum &&& _serverVariableDefault
|
||||
@ -136,7 +136,7 @@ instance Subtree ProcessedServer where
|
||||
type SubtreeLevel ProcessedServer = 'ServerLevel
|
||||
type CheckEnv ProcessedServer = '[]
|
||||
checkStructuralCompatibility _ pc =
|
||||
structuralEq $ (fmap . fmap . fmap) reducerServerVariable pc
|
||||
structuralEq $ (fmap . fmap . fmap . fmap) reducerServerVariable pc
|
||||
where
|
||||
reducerServerVariable =
|
||||
fmap IOHM.toHashSet . _serverVariableEnum &&& _serverVariableDefault
|
||||
|
@ -9,7 +9,7 @@ main = defaultMain =<< tests
|
||||
tests :: IO TestTree
|
||||
tests = do
|
||||
goldenReportTree <- Spec.Golden.TraceTree.tests
|
||||
return $
|
||||
return . localOption (mkTimeout 1000000) $
|
||||
testGroup
|
||||
"Golden tests"
|
||||
[ goldenReportTree
|
||||
|
44
test/golden/common/json/recursive/a.yaml
Normal file
44
test/golden/common/json/recursive/a.yaml
Normal file
@ -0,0 +1,44 @@
|
||||
openapi: 3.0.0
|
||||
info:
|
||||
title: ""
|
||||
version: ""
|
||||
servers:
|
||||
- url: /
|
||||
paths:
|
||||
/api/foo:
|
||||
get:
|
||||
responses:
|
||||
200:
|
||||
description: ""
|
||||
content:
|
||||
application/json;charset=utf-8:
|
||||
schema:
|
||||
$ref: '#/components/schemas/Tree'
|
||||
components:
|
||||
schemas:
|
||||
Tree:
|
||||
type: object
|
||||
properties:
|
||||
node:
|
||||
required:
|
||||
- children
|
||||
type: object
|
||||
properties:
|
||||
children:
|
||||
type: array
|
||||
items:
|
||||
$ref: '#/components/schemas/Tree'
|
||||
leaf:
|
||||
required:
|
||||
- value
|
||||
type: object
|
||||
properties:
|
||||
value:
|
||||
$ref: '#/components/schemas/Item'
|
||||
Item:
|
||||
required:
|
||||
- foo
|
||||
type: object
|
||||
properties:
|
||||
foo:
|
||||
type: string
|
44
test/golden/common/json/recursive/b.yaml
Normal file
44
test/golden/common/json/recursive/b.yaml
Normal file
@ -0,0 +1,44 @@
|
||||
openapi: 3.0.0
|
||||
info:
|
||||
title: ""
|
||||
version: ""
|
||||
servers:
|
||||
- url: /
|
||||
paths:
|
||||
/api/foo:
|
||||
get:
|
||||
responses:
|
||||
200:
|
||||
description: ""
|
||||
content:
|
||||
application/json;charset=utf-8:
|
||||
schema:
|
||||
$ref: '#/components/schemas/Tree'
|
||||
components:
|
||||
schemas:
|
||||
Tree:
|
||||
type: object
|
||||
properties:
|
||||
node:
|
||||
required:
|
||||
- children
|
||||
type: object
|
||||
properties:
|
||||
children:
|
||||
type: array
|
||||
items:
|
||||
$ref: '#/components/schemas/Tree'
|
||||
leaf:
|
||||
required:
|
||||
- value
|
||||
type: object
|
||||
properties:
|
||||
value:
|
||||
$ref: '#/components/schemas/Item'
|
||||
Item:
|
||||
required:
|
||||
- foo
|
||||
type: object
|
||||
properties:
|
||||
foo:
|
||||
type: string
|
1
test/golden/common/json/recursive/trace-tree.yaml
Normal file
1
test/golden/common/json/recursive/trace-tree.yaml
Normal file
@ -0,0 +1 @@
|
||||
Right: []
|
@ -5,7 +5,3 @@ Left:
|
||||
InPayload:
|
||||
PayloadSchema:
|
||||
OfType Object: UnexpectedProperty "property2"
|
||||
WithStatusCode 200:
|
||||
ResponsePayload:
|
||||
PayloadSchema:
|
||||
OfType Object: PropertyNowRequired "property2"
|
||||
|
Loading…
Reference in New Issue
Block a user