mirror of
https://github.com/ilyakooo0/compaREST.git
synced 2024-08-15 17:30:23 +03:00
Turn Traced into a comonad (#41)
* Turn Traced into a comonad * tracedDePathFragment -> tracedPathFragmentParam * Fixed tracedOp Co-authored-by: iko <ilyakooo0@gmail.com>
This commit is contained in:
mniip
GitHub
parent
1d27fd17f3
commit
c2968fee75
@ -34,6 +34,7 @@ common common-options
|
||||
, attoparsec
|
||||
, bytestring
|
||||
, containers
|
||||
, comonad
|
||||
, deriving-aeson
|
||||
, generic-data
|
||||
, generic-monoid
|
||||
|
||||
@ -2,6 +2,7 @@
|
||||
|
||||
module OpenAPI.Checker.Orphans (Step (..)) where
|
||||
|
||||
import Control.Comonad.Env
|
||||
import Data.OpenApi
|
||||
import Data.Typeable
|
||||
import qualified Data.HashMap.Strict.InsOrd as IOHM
|
||||
@ -28,3 +29,7 @@ deriving stock instance Ord ParamLocation
|
||||
|
||||
instance (Ord k, Ord v) => Ord (IOHM.InsOrdHashMap k v) where
|
||||
compare xs ys = compare (IOHM.toList xs) (IOHM.toList ys)
|
||||
|
||||
deriving stock instance (Eq e, Eq (w a)) => Eq (EnvT e w a)
|
||||
deriving stock instance (Ord e, Ord (w a)) => Ord (EnvT e w a)
|
||||
deriving stock instance (Show e, Show (w a)) => Show (EnvT e w a)
|
||||
|
||||
@ -1,7 +1,6 @@
|
||||
module OpenAPI.Checker.References
|
||||
( TracedReferences
|
||||
, dereference
|
||||
, dereferenceTraced
|
||||
)
|
||||
where
|
||||
|
||||
@ -16,17 +15,12 @@ import OpenAPI.Checker.Trace
|
||||
type TracedReferences root a = Map Reference (Traced root a)
|
||||
|
||||
dereference
|
||||
:: Typeable a
|
||||
=> Definitions a
|
||||
-> Referenced a
|
||||
-> Traced (Referenced a) a
|
||||
dereference _ (Inline a) = Traced (step InlineStep) a
|
||||
dereference defs (Ref r@(Reference ref)) =
|
||||
Traced (step $ ReferencedStep r) (fromJust $ IOHM.lookup ref defs)
|
||||
|
||||
dereferenceTraced
|
||||
:: Typeable a
|
||||
=> Definitions a
|
||||
-> Traced r (Referenced a)
|
||||
-> Traced r a
|
||||
dereferenceTraced defs (Traced t x) = retrace t $ dereference defs x
|
||||
dereference defs x = case extract x of
|
||||
Inline a
|
||||
-> traced (ask x >>> step InlineStep) a
|
||||
Ref r@(Reference ref)
|
||||
-> traced (ask x >>> step (ReferencedStep r)) (fromJust $ IOHM.lookup ref defs)
|
||||
|
||||
@ -1,12 +1,12 @@
|
||||
module OpenAPI.Checker.Run (runChecker) where
|
||||
|
||||
import Control.Category
|
||||
import Data.Aeson
|
||||
import qualified Data.ByteString.Char8 as BSC
|
||||
import Data.HList
|
||||
import qualified Data.Yaml as Yaml
|
||||
import OpenAPI.Checker.Options
|
||||
import OpenAPI.Checker.Subtree
|
||||
import OpenAPI.Checker.Trace
|
||||
import OpenAPI.Checker.Validate.OpenApi ()
|
||||
import Prelude hiding (id, (.))
|
||||
|
||||
@ -24,7 +24,7 @@ runChecker = do
|
||||
fail "Exiting"
|
||||
Right s -> pure s
|
||||
Right s -> pure s
|
||||
a <- parseSchema (clientFile opts)
|
||||
b <- parseSchema (serverFile opts)
|
||||
let report = runCompatFormula (pure id) $ checkCompatibility HNil (ProdCons a b)
|
||||
a <- traced Root <$> parseSchema (clientFile opts)
|
||||
b <- traced Root <$> parseSchema (serverFile opts)
|
||||
let report = runCompatFormula $ checkCompatibility HNil (ProdCons a b)
|
||||
BSC.putStrLn $ Yaml.encode report
|
||||
|
||||
@ -2,19 +2,13 @@ module OpenAPI.Checker.Subtree
|
||||
( APIStep (..)
|
||||
, Subtree (..)
|
||||
, CompatM (..)
|
||||
, CompatFormula'
|
||||
, CompatFormula
|
||||
, ProdCons (..)
|
||||
, HasUnsupportedFeature (..)
|
||||
, swapRoles
|
||||
, swapProdCons
|
||||
, checkProdCons
|
||||
, SubtreeCheckIssue (..)
|
||||
, runCompatFormula
|
||||
, withTrace
|
||||
, localM
|
||||
, localTrace
|
||||
, localStep
|
||||
, localTrace'
|
||||
, anyOfM
|
||||
, anyOfAt
|
||||
, issueAtTrace
|
||||
@ -23,8 +17,8 @@ module OpenAPI.Checker.Subtree
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Comonad.Env
|
||||
import Control.Monad.Identity
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.State
|
||||
import Data.Aeson
|
||||
import Data.Functor.Compose
|
||||
@ -58,29 +52,19 @@ instance Applicative ProdCons where
|
||||
pure x = ProdCons x x
|
||||
ProdCons fp fc <*> ProdCons xp xc = ProdCons (fp xp) (fc xc)
|
||||
|
||||
newtype CompatM t a = CompatM
|
||||
newtype CompatM a = CompatM
|
||||
{ unCompatM
|
||||
:: ReaderT
|
||||
(ProdCons (Trace OpenApi t))
|
||||
(StateT (MemoState VarRef) Identity)
|
||||
a
|
||||
:: (StateT (MemoState VarRef) Identity) a
|
||||
}
|
||||
deriving newtype
|
||||
( Functor
|
||||
, Applicative
|
||||
, Monad
|
||||
, MonadReader (ProdCons (Trace OpenApi t))
|
||||
, MonadState (MemoState VarRef)
|
||||
)
|
||||
|
||||
type CompatFormula t = Compose (CompatM t) (FormulaF SubtreeCheckIssue OpenApi)
|
||||
|
||||
-- | Swaps roles of producer and consumer. Used when we check the @Response@ at
|
||||
-- least. In response producer and consumer swap their places because response
|
||||
-- is generated by consumer and parsed by producer.
|
||||
swapRoles :: CompatFormula t a -> CompatFormula t a
|
||||
swapRoles (Compose r) = Compose $ do
|
||||
local swapProdCons r
|
||||
type CompatFormula' f r = Compose CompatM (FormulaF f r)
|
||||
type CompatFormula = CompatFormula' SubtreeCheckIssue OpenApi
|
||||
|
||||
class (Typeable t, Ord (CheckIssue t), Show (CheckIssue t)) => Subtree (t :: Type) where
|
||||
type CheckEnv t :: [Type]
|
||||
@ -93,14 +77,14 @@ class (Typeable t, Ord (CheckIssue t), Show (CheckIssue t)) => Subtree (t :: Typ
|
||||
normalizeTrace :: Trace OpenApi t -> Trace OpenApi t
|
||||
normalizeTrace = id
|
||||
|
||||
checkCompatibility :: HasAll (CheckEnv t) xs => HList xs -> ProdCons t -> CompatFormula t ()
|
||||
checkCompatibility
|
||||
:: HasAll (CheckEnv t) xs
|
||||
=> HList xs
|
||||
-> ProdCons (Traced OpenApi t)
|
||||
-> CompatFormula ()
|
||||
|
||||
{-# WARNING normalizeTrace "It must be refactored. Does nothing for now" #-}
|
||||
|
||||
checkProdCons :: (Subtree t, HasAll (CheckEnv t) env) => HList env -> ProdCons (Traced r t) -> CompatFormula r ()
|
||||
checkProdCons env (ProdCons (Traced p x) (Traced c y)) =
|
||||
localTrace (ProdCons p c) $ checkCompatibility env $ ProdCons x y
|
||||
|
||||
class HasUnsupportedFeature x where
|
||||
hasUnsupportedFeature :: x -> Bool
|
||||
|
||||
@ -141,76 +125,41 @@ instance ToJSON (SubtreeCheckIssue t) where
|
||||
toJSON (SubtreeCheckIssue i) = toJSON i
|
||||
|
||||
runCompatFormula
|
||||
:: ProdCons (Trace OpenApi t)
|
||||
-> Compose (CompatM t) (FormulaF f r) a
|
||||
:: CompatFormula' f r a
|
||||
-> Either (T.TracePrefixTree f r) a
|
||||
runCompatFormula env (Compose f) =
|
||||
calculate . runIdentity . runMemo 0 . (`runReaderT` env) . unCompatM $ f
|
||||
|
||||
withTrace
|
||||
:: (ProdCons (Trace OpenApi a) -> Compose (CompatM a) (FormulaF f r) x)
|
||||
-> Compose (CompatM a) (FormulaF f r) x
|
||||
withTrace k = Compose $ do
|
||||
xs <- ask
|
||||
getCompose $ k xs
|
||||
|
||||
localM
|
||||
:: ProdCons (Trace a b)
|
||||
-> CompatM b x
|
||||
-> CompatM a x
|
||||
localM xs (CompatM k) =
|
||||
CompatM $ ReaderT $ \env -> runReaderT k ((>>>) <$> env <*> xs)
|
||||
|
||||
localTrace
|
||||
:: ProdCons (Trace a b)
|
||||
-> Compose (CompatM b) (FormulaF f r) x
|
||||
-> Compose (CompatM a) (FormulaF f r) x
|
||||
localTrace xs (Compose h) = Compose (localM xs h)
|
||||
|
||||
localStep
|
||||
:: Steppable a b
|
||||
=> Step a b
|
||||
-> Compose (CompatM b) (FormulaF f r) x
|
||||
-> Compose (CompatM a) (FormulaF f r) x
|
||||
localStep xs (Compose h) = Compose (localM (pure $ step xs) h)
|
||||
|
||||
localTrace'
|
||||
:: ProdCons (Trace OpenApi b)
|
||||
-> Compose (CompatM b) (FormulaF f r) x
|
||||
-> Compose (CompatM a) (FormulaF f r) x
|
||||
localTrace' xs (Compose (CompatM k)) = Compose $ CompatM$ ReaderT $ \_ -> runReaderT k xs
|
||||
runCompatFormula (Compose f) =
|
||||
calculate . runIdentity . runMemo 0 . unCompatM $ f
|
||||
|
||||
issueAtTrace
|
||||
:: Subtree t => Trace OpenApi t -> CheckIssue t -> CompatFormula s a
|
||||
:: Subtree t
|
||||
=> Trace r t
|
||||
-> CheckIssue t
|
||||
-> CompatFormula' SubtreeCheckIssue r a
|
||||
issueAtTrace xs issue = Compose $ pure $ anError $ AnItem xs $ SubtreeCheckIssue issue
|
||||
|
||||
issueAt
|
||||
:: Subtree t
|
||||
=> (forall x. ProdCons x -> x)
|
||||
:: (Subtree t, ComonadEnv (Trace r t) w)
|
||||
=> w x
|
||||
-> CheckIssue t
|
||||
-> CompatFormula t a
|
||||
issueAt f issue = Compose $ do
|
||||
xs <- asks f
|
||||
pure $ anError $ AnItem xs $ SubtreeCheckIssue issue
|
||||
-> CompatFormula' SubtreeCheckIssue r a
|
||||
issueAt x = issueAtTrace (ask x)
|
||||
|
||||
anyOfM
|
||||
:: Ord (f t)
|
||||
:: Subtree t
|
||||
=> Trace r t
|
||||
-> f t
|
||||
-> [Compose (CompatM t) (FormulaF f r) a]
|
||||
-> Compose (CompatM t) (FormulaF f r) a
|
||||
-> CheckIssue t
|
||||
-> [CompatFormula' SubtreeCheckIssue r a]
|
||||
-> CompatFormula' SubtreeCheckIssue r a
|
||||
anyOfM xs issue fs =
|
||||
Compose $ (`eitherOf` AnItem xs issue) <$> sequenceA (getCompose <$> fs)
|
||||
Compose $ (`eitherOf` AnItem xs (SubtreeCheckIssue issue)) <$> sequenceA (getCompose <$> fs)
|
||||
|
||||
anyOfAt
|
||||
:: Subtree t
|
||||
=> (forall x. ProdCons x -> x)
|
||||
:: (Subtree t, ComonadEnv (Trace r t) w)
|
||||
=> w x
|
||||
-> CheckIssue t
|
||||
-> [CompatFormula t a]
|
||||
-> CompatFormula t a
|
||||
anyOfAt f issue fs = Compose $ do
|
||||
xs <- asks f
|
||||
(`eitherOf` AnItem xs (SubtreeCheckIssue issue)) <$> sequenceA (getCompose <$> fs)
|
||||
-> [CompatFormula' SubtreeCheckIssue r a]
|
||||
-> CompatFormula' SubtreeCheckIssue r a
|
||||
anyOfAt x = anyOfM (ask x)
|
||||
|
||||
fixpointKnot
|
||||
:: MonadState (MemoState VarRef) m
|
||||
@ -222,7 +171,9 @@ fixpointKnot =
|
||||
, tieKnot = \i x -> pure $ maxFixpoint i x
|
||||
}
|
||||
|
||||
memo :: Subtree t => CompatFormula t () -> CompatFormula t ()
|
||||
memo (Compose f) = Compose $ do
|
||||
pxs <- asks (fmap normalizeTrace)
|
||||
memoWithKnot fixpointKnot f pxs
|
||||
memo
|
||||
:: (Typeable r, Subtree t)
|
||||
=> (ProdCons (Traced r t) -> CompatFormula ())
|
||||
-> (ProdCons (Traced r t) -> CompatFormula ())
|
||||
memo f pc = Compose $ do
|
||||
memoWithKnot fixpointKnot (getCompose $ f pc) (ask <$> pc)
|
||||
|
||||
@ -9,18 +9,21 @@ module OpenAPI.Checker.Trace
|
||||
, _DiffTrace
|
||||
, AnItem (..)
|
||||
, step
|
||||
, Traced (..)
|
||||
, mapTraced
|
||||
, retrace
|
||||
, deTraced
|
||||
, Traced
|
||||
, traced
|
||||
|
||||
-- * Reexports
|
||||
, (>>>)
|
||||
, (<<<)
|
||||
, extract
|
||||
, ask
|
||||
, asks
|
||||
, local
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Category
|
||||
import Control.Comonad.Env
|
||||
import Control.Lens
|
||||
import Data.Kind
|
||||
import Data.Type.Equality
|
||||
@ -117,20 +120,7 @@ instance Typeable r => Ord (AnItem f r) where
|
||||
Root -> compare (someTypeRep xs) (someTypeRep ys)
|
||||
Snoc _ _ -> compare (someTypeRep xs) (someTypeRep ys)
|
||||
|
||||
data Traced r a = Traced {getTrace :: Trace r a, getTraced :: a}
|
||||
deriving (Eq, Show)
|
||||
type Traced r a = Env (Trace r a) a
|
||||
|
||||
-- | Reverse lexicographical order, so that getTraced is a monotonous function
|
||||
instance Ord a => Ord (Traced r a) where
|
||||
compare (Traced t1 a1) (Traced t2 a2) = compare a1 a2 <> compare t1 t2
|
||||
|
||||
mapTraced :: (Trace r a -> Trace r b) -> (a -> b) -> Traced r a -> Traced r b
|
||||
mapTraced f g (Traced t a) = Traced (f t) (g a)
|
||||
|
||||
retrace :: Trace s r -> Traced r a -> Traced s a
|
||||
retrace xs (Traced t a) = Traced (xs >>> t) a
|
||||
|
||||
deTraced :: Traced r a -> (Trace r a, a)
|
||||
deTraced (Traced a b) = (a, b)
|
||||
|
||||
-- type APath = AnItem Proxy
|
||||
traced :: Trace r a -> a -> Traced r a
|
||||
traced = env
|
||||
|
||||
@ -1,9 +1,11 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module OpenAPI.Checker.Validate.MediaTypeObject () where
|
||||
module OpenAPI.Checker.Validate.MediaTypeObject
|
||||
( CheckIssue(..)
|
||||
) where
|
||||
|
||||
import Control.Lens
|
||||
import Data.Foldable as F
|
||||
import Data.Functor
|
||||
import Data.HList
|
||||
import Data.HashMap.Strict.InsOrd as IOHM
|
||||
import Data.Map.Strict as M
|
||||
@ -15,13 +17,21 @@ import OpenAPI.Checker.Trace
|
||||
import OpenAPI.Checker.Validate.Products
|
||||
import OpenAPI.Checker.Validate.Schema ()
|
||||
|
||||
tracedSchema :: Traced r MediaTypeObject -> Maybe (Traced r (Referenced Schema))
|
||||
tracedSchema mto = _mediaTypeObjectSchema (extract mto) <&> traced (ask mto >>> step MediaTypeSchema)
|
||||
|
||||
tracedEncoding :: Traced r MediaTypeObject -> InsOrdHashMap Text (Traced r Encoding)
|
||||
tracedEncoding mto = IOHM.mapWithKey (\k -> traced (ask mto >>> step (MediaTypeParamEncoding k)))
|
||||
$ _mediaTypeObjectEncoding $ extract mto
|
||||
|
||||
instance Subtree MediaTypeObject where
|
||||
type CheckEnv MediaTypeObject =
|
||||
'[ MediaType
|
||||
, ProdCons (Definitions Schema)
|
||||
]
|
||||
data CheckIssue MediaTypeObject
|
||||
= MediaEncodingMissing Text
|
||||
= RequestMediaTypeNotFound
|
||||
| ResponseMediaTypeMissing
|
||||
| MediaEncodingIncompat
|
||||
| MediaTypeSchemaRequired
|
||||
deriving (Eq, Ord, Show)
|
||||
@ -32,11 +42,10 @@ instance Subtree MediaTypeObject where
|
||||
| otherwise -> pure ()
|
||||
-- If consumer requires schema then producer must produce compatible
|
||||
-- request
|
||||
for_ (_mediaTypeObjectSchema c) $ \consRef ->
|
||||
case _mediaTypeObjectSchema p of
|
||||
Nothing -> issueAt producer MediaTypeSchemaRequired
|
||||
Just prodRef -> localStep MediaTypeSchema
|
||||
$ checkCompatibility env $ ProdCons prodRef consRef
|
||||
for_ (tracedSchema c) $ \consRef ->
|
||||
case tracedSchema p of
|
||||
Nothing -> issueAt p MediaTypeSchemaRequired
|
||||
Just prodRef -> checkCompatibility env $ ProdCons prodRef consRef
|
||||
pure ()
|
||||
where
|
||||
mediaType = getH @MediaType env
|
||||
@ -44,23 +53,25 @@ instance Subtree MediaTypeObject where
|
||||
let
|
||||
-- Parameters of the media type are product-like entities
|
||||
getEncoding mt = M.fromList
|
||||
$ (IOHM.toList $ _mediaTypeObjectEncoding mt) <&> \(k, enc) ->
|
||||
$ (IOHM.toList $ tracedEncoding mt) <&> \(k, enc) ->
|
||||
( k
|
||||
, ProductLike
|
||||
{ traced = Traced (step $ MediaTypeParamEncoding k) enc
|
||||
{ tracedValue = enc
|
||||
, required = True } )
|
||||
encProdCons = getEncoding <$> prodCons
|
||||
in checkProducts MediaEncodingMissing
|
||||
in checkProducts (const MediaEncodingMissing)
|
||||
(const $ checkCompatibility HNil) encProdCons
|
||||
|
||||
instance Subtree Encoding where
|
||||
type CheckEnv Encoding = '[]
|
||||
data CheckIssue Encoding = EncodingNotSupported
|
||||
data CheckIssue Encoding
|
||||
= MediaEncodingMissing
|
||||
| EncodingNotSupported
|
||||
-- FIXME: Support only JSON body for now. Then Encoding is checked only for
|
||||
-- multipart/form-url-encoded
|
||||
deriving (Eq, Ord, Show)
|
||||
checkCompatibility _env _prodCons =
|
||||
issueAt producer EncodingNotSupported
|
||||
checkCompatibility _env pc =
|
||||
issueAt (producer pc) EncodingNotSupported
|
||||
|
||||
instance Steppable MediaTypeObject (Referenced Schema) where
|
||||
data Step MediaTypeObject (Referenced Schema) = MediaTypeSchema
|
||||
|
||||
@ -13,22 +13,25 @@ import OpenAPI.Checker.Subtree
|
||||
import OpenAPI.Checker.Trace
|
||||
import OpenAPI.Checker.Validate.ProcessedPathItem
|
||||
|
||||
tracedPaths :: Traced r OpenApi -> Traced r ProcessedPathItems
|
||||
tracedPaths oa = traced (ask oa >>> step OpenApiPathsStep)
|
||||
(processPathItems . IOHM.toList . _openApiPaths . extract $ oa)
|
||||
|
||||
instance Subtree OpenApi where
|
||||
type CheckEnv OpenApi = '[]
|
||||
data CheckIssue OpenApi
|
||||
deriving (Eq, Ord, Show)
|
||||
checkCompatibility _ prodCons = do
|
||||
let cs = _openApiComponents <$> prodCons
|
||||
localStep OpenApiPathsStep $
|
||||
checkCompatibility
|
||||
((_componentsRequestBodies <$> cs)
|
||||
`HCons` (_componentsParameters <$> cs)
|
||||
`HCons` (_componentsSecuritySchemes <$> cs)
|
||||
`HCons` (_componentsResponses <$> cs)
|
||||
`HCons` (_componentsHeaders <$> cs)
|
||||
`HCons` (_componentsSchemas <$> cs)
|
||||
`HCons` HNil)
|
||||
(processPathItems . IOHM.toList . _openApiPaths <$> prodCons)
|
||||
let cs = _openApiComponents . extract <$> prodCons
|
||||
checkCompatibility @ProcessedPathItems
|
||||
((_componentsRequestBodies <$> cs)
|
||||
`HCons` (_componentsParameters <$> cs)
|
||||
`HCons` (_componentsSecuritySchemes <$> cs)
|
||||
`HCons` (_componentsResponses <$> cs)
|
||||
`HCons` (_componentsHeaders <$> cs)
|
||||
`HCons` (_componentsSchemas <$> cs)
|
||||
`HCons` HNil)
|
||||
(tracedPaths <$> prodCons)
|
||||
|
||||
instance Steppable OpenApi ProcessedPathItems where
|
||||
data Step OpenApi ProcessedPathItems = OpenApiPathsStep
|
||||
|
||||
@ -2,7 +2,10 @@
|
||||
{-# OPTIONS_GHC -Wno-name-shadowing #-}
|
||||
|
||||
module OpenAPI.Checker.Validate.Operation
|
||||
( MatchedOperation(..)
|
||||
( MatchedOperation (..)
|
||||
, CheckIssue (..)
|
||||
, OperationMethod(..)
|
||||
, pathItemMethod
|
||||
) where
|
||||
|
||||
|
||||
@ -17,15 +20,11 @@ import Data.Text (Text)
|
||||
import OpenAPI.Checker.References
|
||||
import OpenAPI.Checker.Subtree
|
||||
import OpenAPI.Checker.Trace
|
||||
import OpenAPI.Checker.Validate.Param ()
|
||||
import OpenAPI.Checker.Validate.Param
|
||||
import OpenAPI.Checker.Validate.PathFragment
|
||||
import OpenAPI.Checker.Validate.Products
|
||||
import OpenAPI.Checker.Validate.RequestBody ()
|
||||
import OpenAPI.Checker.Validate.RequestBody
|
||||
import OpenAPI.Checker.Validate.Responses ()
|
||||
import OpenAPI.Checker.Validate.SecurityRequirement ()
|
||||
import OpenAPI.Checker.Validate.Server ()
|
||||
|
||||
-- data ParamKey
|
||||
|
||||
data MatchedOperation = MatchedOperation
|
||||
{ operation :: !Operation
|
||||
@ -41,6 +40,31 @@ type ParamKey = (ParamLocation, Text)
|
||||
paramKey :: Param -> ParamKey
|
||||
paramKey param = (_paramIn param, _paramName param)
|
||||
|
||||
tracedParameters :: Traced r MatchedOperation -> [Traced r (Referenced Param)]
|
||||
tracedParameters oper =
|
||||
[ traced (ask oper >>> step (OperationParamsStep i)) x
|
||||
| (i, x) <- zip [0..] $ _operationParameters . operation $ extract oper
|
||||
]
|
||||
|
||||
tracedRequestBody :: Traced r MatchedOperation -> Maybe (Traced r (Referenced RequestBody))
|
||||
tracedRequestBody oper = _operationRequestBody (operation $ extract oper) <&> traced (ask oper >>> step OperationRequestBodyStep)
|
||||
|
||||
tracedResponses :: Traced r MatchedOperation -> Traced r Responses
|
||||
tracedResponses oper = traced (ask oper >>> step OperationResponsesStep)
|
||||
$ _operationResponses . operation $ extract oper
|
||||
|
||||
tracedSecurity :: Traced r MatchedOperation -> [Traced r SecurityRequirement]
|
||||
tracedSecurity oper =
|
||||
[ traced (ask oper >>> step (OperationSecurityRequirementStep i)) x
|
||||
| (i, x) <- zip [0..] $ _operationSecurity . operation $ extract oper
|
||||
]
|
||||
|
||||
tracedServers :: Traced r MatchedOperation -> [Traced r Server]
|
||||
tracedServers oper =
|
||||
[ traced (ask oper >>> step (OperationServerStep i)) x
|
||||
| (i, x) <- zip [0..] $ _operationServers . operation $ extract oper
|
||||
]
|
||||
|
||||
instance Subtree MatchedOperation where
|
||||
type CheckEnv MatchedOperation =
|
||||
'[ ProdCons (Definitions Param)
|
||||
@ -51,17 +75,11 @@ instance Subtree MatchedOperation where
|
||||
, ProdCons (Definitions Schema)
|
||||
]
|
||||
data CheckIssue MatchedOperation
|
||||
= ParamNotMatched ParamLocation Text
|
||||
-- ^ Non-path param has no pair
|
||||
| PathFragmentNotMatched Int
|
||||
-- ^ Path fragment with given position has no match
|
||||
| NoRequestBody
|
||||
= OperationMissing OperationMethod
|
||||
| CallbacksNotSupported
|
||||
| SecurityRequirementNotMet Int -- security indexs
|
||||
| ServerNotConsumed Int -- server index
|
||||
deriving (Eq, Ord, Show)
|
||||
checkCompatibility env prodCons = withTrace $ \myTrace -> do
|
||||
checkParameters myTrace
|
||||
checkCompatibility env prodCons = do
|
||||
checkParameters
|
||||
checkRequestBodies
|
||||
checkResponses
|
||||
checkCallbacks
|
||||
@ -69,88 +87,84 @@ instance Subtree MatchedOperation where
|
||||
checkServers
|
||||
pure ()
|
||||
where
|
||||
checkParameters myTrace = do
|
||||
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 OpenApi Param], [Traced OpenApi Param])
|
||||
tracedParams = getParams <$> myTrace <*> paramDefs <*> prodCons
|
||||
getParams root defs mp =
|
||||
tracedParams = getParams <$> paramDefs <*> prodCons
|
||||
getParams defs mp =
|
||||
let
|
||||
operationParamsMap :: Map ParamKey (Traced OpenApi Param)
|
||||
operationParamsMap = M.fromList $ do
|
||||
paramRef <- _operationParameters $ operation mp
|
||||
paramRef <- tracedParameters mp
|
||||
let
|
||||
tracedParam = retrace root
|
||||
$ dereferenceTraced defs
|
||||
$ Traced (step $ OperationParamsStep) paramRef
|
||||
key = paramKey $ getTraced tracedParam
|
||||
pure (key, tracedParam)
|
||||
param = dereference defs paramRef
|
||||
key = paramKey . extract $ param
|
||||
pure (key, param)
|
||||
pathParamsMap :: Map ParamKey (Traced OpenApi Param)
|
||||
pathParamsMap = M.fromList $ do
|
||||
param <- pathParams mp
|
||||
pure (paramKey $ getTraced param, param)
|
||||
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 $ getTraced p) == ParamPath) params
|
||||
(\p -> (_paramIn . extract $ p) == ParamPath) params
|
||||
in splitted
|
||||
checkNonPathParams $ snd <$> tracedParams
|
||||
checkPathParams $ fst <$> tracedParams
|
||||
pure ()
|
||||
checkNonPathParams :: ProdCons [Traced OpenApi Param] -> CompatFormula MatchedOperation ()
|
||||
checkNonPathParams :: ProdCons [Traced OpenApi Param] -> CompatFormula ()
|
||||
checkNonPathParams params = do
|
||||
let
|
||||
elements = getEls <$> params
|
||||
getEls traced = M.fromList $ do
|
||||
p <- traced
|
||||
getEls params = M.fromList $ do
|
||||
p <- params
|
||||
let
|
||||
param = getTraced p
|
||||
k = (_paramIn param, _paramName param)
|
||||
k = (_paramIn . extract $ p, _paramName . extract $ p)
|
||||
v = ProductLike
|
||||
{ traced = p
|
||||
, required = fromMaybe False $ _paramRequired param
|
||||
{ tracedValue = p
|
||||
, required = fromMaybe False . _paramRequired . extract $ p
|
||||
}
|
||||
pure (k, v)
|
||||
check _ param = do
|
||||
check param = do
|
||||
checkCompatibility @Param (singletonH schemaDefs) param
|
||||
checkProducts' (uncurry ParamNotMatched) check elements
|
||||
checkProducts (ParamNotMatched . snd) (const check) elements
|
||||
checkPathParams :: ProdCons [Traced OpenApi Param] -> CompatFormula ()
|
||||
checkPathParams pathParams = do
|
||||
let
|
||||
fragments :: ProdCons [Traced OpenApi PathFragmentParam]
|
||||
fragments = getFragments <$> pathParams <*> prodCons
|
||||
getFragments params mop = (getPathFragments mop) params
|
||||
getFragments params mop = getPathFragments (extract mop) params
|
||||
-- Feed path parameters to the fragments getter
|
||||
check _ frags = checkCompatibility @PathFragmentParam env frags
|
||||
elements = fragments <&> \frags -> M.fromList $ zip [0..] $ do
|
||||
check frags = checkCompatibility @PathFragmentParam env frags
|
||||
elements = fragments <&> \frags -> M.fromList $ zip [0 :: Int ..] $ do
|
||||
frag <- frags
|
||||
pure $ ProductLike
|
||||
{ traced = frag
|
||||
{ tracedValue = frag
|
||||
, required = True }
|
||||
checkProducts' PathFragmentNotMatched check elements
|
||||
checkProducts (const PathFragmentNotMatched) (const check) elements
|
||||
checkRequestBodies = do
|
||||
let
|
||||
check _ reqBody = checkCompatibility @RequestBody env reqBody
|
||||
check reqBody = checkCompatibility @RequestBody env reqBody
|
||||
elements = getReqBody <$> bodyDefs <*> prodCons
|
||||
getReqBody bodyDef mop = M.fromList $ do
|
||||
bodyRef <- F.toList $ _operationRequestBody $ operation mop
|
||||
bodyRef <- F.toList . tracedRequestBody $ mop
|
||||
let
|
||||
traced = dereferenceTraced bodyDef
|
||||
$ Traced (step $ OperationRequestBodyStep) bodyRef
|
||||
required = fromMaybe False
|
||||
$ _requestBodyRequired $ getTraced traced
|
||||
elt = ProductLike { traced, required }
|
||||
body = dereference bodyDef bodyRef
|
||||
-- Single element map
|
||||
pure ((), elt)
|
||||
checkProducts (const NoRequestBody) check elements
|
||||
pure ((), ProductLike
|
||||
{ tracedValue = body
|
||||
, required = fromMaybe False . _requestBodyRequired . extract $ body
|
||||
})
|
||||
checkProducts (const NoRequestBody) (const check) elements
|
||||
checkResponses = do
|
||||
let
|
||||
resps = (_operationResponses . operation) <$> prodCons
|
||||
respEnv = HCons (swapProdCons respDefs)
|
||||
$ HCons (swapProdCons headerDefs)
|
||||
$ HCons (swapProdCons schemaDefs) HNil
|
||||
localStep OperationResponsesStep
|
||||
$ swapRoles $ checkCompatibility respEnv $ swapProdCons resps
|
||||
resps = tracedResponses <$> prodCons
|
||||
checkCompatibility respEnv $ swapProdCons resps
|
||||
checkCallbacks = pure () -- (error "FIXME: not implemented")
|
||||
checkOperationSecurity = pure () -- (error "FIXME: not implemented")
|
||||
checkServers = pure () -- (error "FIXME: not implemented")
|
||||
@ -160,8 +174,30 @@ instance Subtree MatchedOperation where
|
||||
schemaDefs = getH @(ProdCons (Definitions Schema)) env
|
||||
paramDefs = getH @(ProdCons (Definitions Param)) env
|
||||
|
||||
data OperationMethod =
|
||||
GetMethod
|
||||
| PutMethod
|
||||
| PostMethod
|
||||
| DeleteMethod
|
||||
| OptionsMethod
|
||||
| HeadMethod
|
||||
| PatchMethod
|
||||
| TraceMethod
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
pathItemMethod :: OperationMethod -> PathItem -> Maybe Operation
|
||||
pathItemMethod = \case
|
||||
GetMethod -> _pathItemGet
|
||||
PutMethod -> _pathItemPut
|
||||
PostMethod -> _pathItemPost
|
||||
DeleteMethod -> _pathItemDelete
|
||||
OptionsMethod -> _pathItemOptions
|
||||
HeadMethod -> _pathItemHead
|
||||
PatchMethod -> _pathItemPatch
|
||||
TraceMethod -> _pathItemTrace
|
||||
|
||||
instance Steppable MatchedOperation (Referenced Param) where
|
||||
data Step MatchedOperation (Referenced Param) = OperationParamsStep
|
||||
data Step MatchedOperation (Referenced Param) = OperationParamsStep Int
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance Steppable MatchedOperation (Referenced RequestBody) where
|
||||
@ -173,9 +209,9 @@ instance Steppable MatchedOperation Responses where
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance Steppable MatchedOperation SecurityRequirement where
|
||||
data Step MatchedOperation SecurityRequirement = OperationSecurityRequirementStep
|
||||
data Step MatchedOperation SecurityRequirement = OperationSecurityRequirementStep Int
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance Steppable MatchedOperation Server where
|
||||
data Step MatchedOperation Server = OperationServerStep
|
||||
data Step MatchedOperation Server = OperationServerStep Int
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
@ -1,11 +1,15 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
||||
|
||||
module OpenAPI.Checker.Validate.Param () where
|
||||
module OpenAPI.Checker.Validate.Param
|
||||
( CheckIssue (..)
|
||||
) where
|
||||
|
||||
import Control.Lens
|
||||
import Control.Monad
|
||||
import Data.Maybe
|
||||
import Data.OpenApi
|
||||
import Data.Text
|
||||
import OpenAPI.Checker.Orphans
|
||||
import OpenAPI.Checker.Subtree
|
||||
import OpenAPI.Checker.Trace
|
||||
@ -38,10 +42,14 @@ paramEncoding p = EncodingStyle
|
||||
ParamQuery -> Just $ fromMaybe False $ _paramAllowReserved p
|
||||
_ -> Nothing
|
||||
|
||||
tracedSchema :: Traced r Param -> Maybe (Traced r (Referenced Schema))
|
||||
tracedSchema par = _paramSchema (extract par) <&> traced (ask par >>> step ParamSchema)
|
||||
|
||||
instance Subtree Param where
|
||||
type CheckEnv Param = '[ProdCons (Definitions Schema)]
|
||||
data CheckIssue Param
|
||||
= ParamNameMismatch
|
||||
= ParamNotMatched Text
|
||||
| ParamNameMismatch
|
||||
-- ^ Params have different names
|
||||
| ParamEmptinessIncompatible
|
||||
-- ^ Consumer requires non-empty param, but producer gives emptyable
|
||||
@ -53,28 +61,28 @@ instance Subtree Param where
|
||||
| ParamSchemaMismatch
|
||||
-- ^ One of schemas not presented
|
||||
deriving (Eq, Ord, Show)
|
||||
checkCompatibility env (ProdCons p c) = do
|
||||
when (_paramName p /= _paramName c)
|
||||
$ issueAt producer ParamNameMismatch
|
||||
when ((fromMaybe False $ _paramRequired c) &&
|
||||
not (fromMaybe False $ _paramRequired p))
|
||||
$ issueAt producer ParamRequired
|
||||
case (_paramIn p, _paramIn c) of
|
||||
checkCompatibility env pc@(ProdCons p c) = do
|
||||
when (_paramName (extract p) /= _paramName (extract c))
|
||||
$ issueAt p ParamNameMismatch
|
||||
when ((fromMaybe False . _paramRequired . extract $ c) &&
|
||||
not (fromMaybe False . _paramRequired . extract $ p))
|
||||
$ issueAt p ParamRequired
|
||||
case (_paramIn . extract $ p, _paramIn . extract $ c) of
|
||||
(ParamQuery, ParamQuery) -> do
|
||||
-- Emptiness is only for query params
|
||||
when ((fromMaybe False $ _paramAllowEmptyValue p)
|
||||
&& not (fromMaybe False $ _paramAllowEmptyValue c))
|
||||
$ issueAt producer ParamEmptinessIncompatible
|
||||
when ((fromMaybe False . _paramAllowEmptyValue . extract $ p)
|
||||
&& not (fromMaybe False . _paramAllowEmptyValue . extract $ c))
|
||||
$ issueAt p ParamEmptinessIncompatible
|
||||
(a, b) | a == b -> pure ()
|
||||
_ -> issueAt producer ParamPlaceIncompatible
|
||||
unless (paramEncoding p == paramEncoding c)
|
||||
$ issueAt producer ParamStyleMismatch
|
||||
case (_paramSchema p, _paramSchema c) of
|
||||
(Just prodSchema, Just consSchema) -> localStep ParamSchema
|
||||
$ checkCompatibility env (ProdCons prodSchema consSchema)
|
||||
(Nothing, Nothing) -> pure ()
|
||||
(Nothing, Just _consSchema) -> issueAt producer ParamSchemaMismatch
|
||||
(Just _prodSchema, Nothing) -> pure ()
|
||||
_ -> issueAt p ParamPlaceIncompatible
|
||||
unless (paramEncoding (extract p) == paramEncoding (extract c))
|
||||
$ issueAt p ParamStyleMismatch
|
||||
case tracedSchema <$> pc of
|
||||
ProdCons (Just prodSchema) (Just consSchema) -> do
|
||||
checkCompatibility env $ ProdCons prodSchema consSchema
|
||||
ProdCons Nothing Nothing -> pure ()
|
||||
ProdCons Nothing (Just _consSchema) -> issueAt p ParamSchemaMismatch
|
||||
ProdCons (Just _prodSchema) Nothing -> pure ()
|
||||
-- If consumer doesn't care then why we should?
|
||||
pure ()
|
||||
|
||||
|
||||
@ -2,6 +2,7 @@ module OpenAPI.Checker.Validate.PathFragment
|
||||
( parsePath
|
||||
, PathFragment (..)
|
||||
, PathFragmentParam
|
||||
, CheckIssue (..)
|
||||
)
|
||||
where
|
||||
|
||||
@ -40,32 +41,16 @@ instance (Typeable param) => Steppable (PathFragment param) Param where
|
||||
data Step (PathFragment param) Param = StaticPathParam Text
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance Subtree PathFragmentParam where
|
||||
type CheckEnv PathFragmentParam =
|
||||
'[ ProdCons (Definitions Schema) ]
|
||||
data CheckIssue PathFragmentParam =
|
||||
PathFragmentsDontMatch Text Text
|
||||
deriving (Eq, Ord, Show)
|
||||
-- This case isn't strictly needed. It is here for optimization.
|
||||
checkCompatibility _ ProdCons {producer = (StaticPath x), consumer = (StaticPath y)} =
|
||||
if x == y
|
||||
then pure ()
|
||||
else issueAt consumer (PathFragmentsDontMatch x y)
|
||||
checkCompatibility env prodCons = withTrace $ \myTrace -> do
|
||||
let
|
||||
tracedParams = dePathFragment <$> myTrace <*> prodCons
|
||||
dePathFragment root = \case
|
||||
StaticPath s -> retrace root $ Traced (step $ StaticPathParam s)
|
||||
$ mempty
|
||||
{ _paramRequired = Just True
|
||||
, _paramIn = ParamPath
|
||||
, _paramAllowEmptyValue = Just False
|
||||
, _paramAllowReserved = Just False
|
||||
, _paramSchema = Just $ Inline $ staticStringSchema s }
|
||||
DynamicPath p -> p
|
||||
params = getTraced <$> tracedParams
|
||||
paramTrace = getTrace <$> tracedParams
|
||||
localTrace' paramTrace $ checkCompatibility env params
|
||||
tracedPathFragmentParam :: Traced OpenApi PathFragmentParam -> Traced OpenApi Param
|
||||
tracedPathFragmentParam pfp = case extract pfp of
|
||||
StaticPath s -> traced (ask pfp >>> step (StaticPathParam s))
|
||||
$ mempty
|
||||
{ _paramRequired = Just True
|
||||
, _paramIn = ParamPath
|
||||
, _paramAllowEmptyValue = Just False
|
||||
, _paramAllowReserved = Just False
|
||||
, _paramSchema = Just $ Inline $ staticStringSchema s }
|
||||
DynamicPath p -> p
|
||||
|
||||
staticStringSchema :: Text -> Schema
|
||||
staticStringSchema t =
|
||||
@ -74,3 +59,18 @@ staticStringSchema t =
|
||||
, _schemaType = Just OpenApiString
|
||||
, _schemaEnum = Just [A.String t]
|
||||
}
|
||||
|
||||
instance Subtree PathFragmentParam where
|
||||
type CheckEnv PathFragmentParam =
|
||||
'[ ProdCons (Definitions Schema) ]
|
||||
data CheckIssue PathFragmentParam
|
||||
= PathFragmentNotMatched
|
||||
| PathFragmentsDontMatch Text Text
|
||||
deriving (Eq, Ord, Show)
|
||||
-- This case isn't strictly needed. It is here for optimization.
|
||||
checkCompatibility _ (ProdCons (extract -> StaticPath x) c@(extract -> StaticPath y))
|
||||
= if x == y
|
||||
then pure ()
|
||||
else issueAt c (PathFragmentsDontMatch x y)
|
||||
checkCompatibility env prodCons = do
|
||||
checkCompatibility env (tracedPathFragmentParam <$> prodCons)
|
||||
|
||||
@ -9,6 +9,7 @@ module OpenAPI.Checker.Validate.ProcessedPathItem
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Comonad.Env
|
||||
import Control.Monad
|
||||
import Data.Foldable as F
|
||||
import Data.Functor
|
||||
@ -52,29 +53,24 @@ instance Subtree ProcessedPathItems where
|
||||
| AllPathsFailed FilePath
|
||||
-- When several paths match given but all checks failed
|
||||
deriving (Eq, Ord, Show)
|
||||
checkCompatibility env (ProdCons p c) = do
|
||||
checkCompatibility env pc@(ProdCons p c) = do
|
||||
-- Each path generated by producer must be handled by consumer with exactly
|
||||
-- one way
|
||||
for_ (unProcessedPathItems p) $ \ prodItem -> do
|
||||
for_ (unProcessedPathItems . extract $ p) $ \ prodItem -> do
|
||||
let
|
||||
prodPath = path prodItem
|
||||
matchedItems = do
|
||||
consItem <- unProcessedPathItems c
|
||||
consItem <- unProcessedPathItems . extract $ c
|
||||
matched <- F.toList $ matchingPathItems $ ProdCons prodItem consItem
|
||||
return matched
|
||||
case matchedItems of
|
||||
[] -> issueAt producer $ NoPathsMatched prodPath
|
||||
[matched] -> do
|
||||
-- Checking exact match with no wrapper
|
||||
let trace = matchedTrace <$> matched
|
||||
localTrace trace $ checkCompatibility env matched
|
||||
matches -> anyOfAt consumer (AllPathsFailed prodPath) $ do
|
||||
[] -> issueAt p $ NoPathsMatched prodPath
|
||||
[match] -> checkCompatibility env (retraced <$> pc <*> match)
|
||||
matches -> anyOfAt c (AllPathsFailed prodPath) $ do
|
||||
match <- matches
|
||||
let trace = matchedTrace <$> match
|
||||
pure $ localTrace trace $ checkCompatibility env match
|
||||
pure $ checkCompatibility env (retraced <$> pc <*> match)
|
||||
where
|
||||
matchedTrace :: MatchedPathItem -> Trace ProcessedPathItems MatchedPathItem
|
||||
matchedTrace mpi = step $ MatchedPathStep $ matchedPath mpi
|
||||
retraced pc mpi = traced (ask pc >>> step (MatchedPathStep $ matchedPath mpi)) mpi
|
||||
|
||||
-- | Preliminary checks two paths for compatibility. Returns Nothing if two
|
||||
-- paths obviously do not match: static parts differ or count of path elements
|
||||
@ -109,6 +105,25 @@ data MatchedPathItem = MatchedPathItem
|
||||
-- ^ Pre-parsed path from PathItem
|
||||
}
|
||||
|
||||
tracedParameters :: Traced r MatchedPathItem -> [Traced r (Referenced Param)]
|
||||
tracedParameters mpi =
|
||||
[ traced (ask mpi >>> step (PathItemParam i)) x
|
||||
| (i, x) <- L.zip [0..] $ _pathItemParameters . pathItem $ extract mpi
|
||||
]
|
||||
|
||||
-- TODO: simplify?
|
||||
tracedFragments :: Traced r MatchedPathItem -> [Env (Trace r PathFragmentParam) (PathFragment Text)]
|
||||
tracedFragments mpi =
|
||||
[ env (ask mpi >>> step (PathFragmentStep i)) x
|
||||
| (i, x) <- L.zip [0..] $ pathFragments $ extract mpi
|
||||
]
|
||||
|
||||
tracedMethod
|
||||
:: OperationMethod
|
||||
-> Traced r MatchedPathItem
|
||||
-> Maybe (Env (Trace r MatchedOperation) Operation)
|
||||
tracedMethod s mpi = env (ask mpi >>> step (OperationMethodStep s)) <$> (pathItemMethod s . pathItem . extract $ mpi)
|
||||
|
||||
instance Subtree MatchedPathItem where
|
||||
type CheckEnv MatchedPathItem =
|
||||
'[ ProdCons (Definitions Param)
|
||||
@ -119,63 +134,46 @@ instance Subtree MatchedPathItem where
|
||||
, ProdCons (Definitions Schema)
|
||||
]
|
||||
data CheckIssue MatchedPathItem
|
||||
= OperationMissing (Step MatchedPathItem MatchedOperation)
|
||||
deriving (Eq, Ord, Show)
|
||||
checkCompatibility env prodCons = withTrace $ \rootTrace -> do
|
||||
checkCompatibility env prodCons = do
|
||||
let
|
||||
paramDefs = getH @(ProdCons (Definitions Param)) env
|
||||
pathTracedParams = getPathParams <$> rootTrace <*> paramDefs <*> prodCons
|
||||
pathTracedParams = getPathParams <$> paramDefs <*> prodCons
|
||||
getPathParams
|
||||
:: Trace OpenApi MatchedPathItem
|
||||
-> Definitions Param
|
||||
-> MatchedPathItem
|
||||
-> [Traced OpenApi Param]
|
||||
getPathParams root defs mpi = do
|
||||
paramRef <- _pathItemParameters $ pathItem mpi
|
||||
let
|
||||
traced = dereferenceTraced defs
|
||||
$ Traced (step PathItemParam) paramRef
|
||||
res = retrace root traced
|
||||
pure res
|
||||
pathTracedFragments = mkPathFragments <$> rootTrace <*> prodCons
|
||||
mkPathFragments myRoot mpi operationParams =
|
||||
:: Definitions Param
|
||||
-> Traced r MatchedPathItem
|
||||
-> [Traced r Param]
|
||||
getPathParams defs mpi = do
|
||||
paramRef <- tracedParameters mpi
|
||||
pure $ dereference defs paramRef
|
||||
pathTracedFragments = mkPathFragments <$> prodCons
|
||||
mkPathFragments mpi operationParams =
|
||||
-- operationParams will be known on Operation check stage, so we give a
|
||||
-- function, returning fragments
|
||||
let
|
||||
paramsMap :: Map Text (Traced OpenApi Param)
|
||||
paramsMap = M.fromList $ do
|
||||
tracedParam <- operationParams
|
||||
let pname = _paramName $ getTraced tracedParam
|
||||
let pname = _paramName . extract $ tracedParam
|
||||
pure (pname, tracedParam)
|
||||
fragments :: [PathFragmentParam]
|
||||
fragments = (pathFragments mpi) <&> \case
|
||||
convertFragment = \case
|
||||
StaticPath t -> StaticPath t
|
||||
DynamicPath pname -> DynamicPath
|
||||
$ fromMaybe (error $ "Param not found " <> T.unpack pname)
|
||||
$ M.lookup pname paramsMap
|
||||
tracedFragments :: [Traced OpenApi PathFragmentParam]
|
||||
tracedFragments = L.zip [0..] fragments <&> \(pos, frag) ->
|
||||
retrace myRoot $ Traced (step $ PathFragmentStep pos) frag
|
||||
in tracedFragments
|
||||
in tracedFragments mpi <&> fmap convertFragment
|
||||
operations = getOperations <$> pathTracedParams <*> pathTracedFragments <*> prodCons
|
||||
getOperations pathParams getPathFragments mpi = M.fromList $ do
|
||||
(getOp, s) <-
|
||||
[ (_pathItemGet, GetStep)
|
||||
, (_pathItemPut, PutStep)
|
||||
, (_pathItemPost, PostStep)
|
||||
, (_pathItemDelete, DeleteStep)
|
||||
, (_pathItemOptions, OptionsStep)
|
||||
, (_pathItemHead, HeadStep)
|
||||
, (_pathItemPatch, PatchStep)
|
||||
, (_pathItemTrace, TraceStep) ]
|
||||
operation <- F.toList $ getOp $ pathItem mpi
|
||||
(i, getOp) <- (\m -> (m, tracedMethod m)) <$>
|
||||
[GetMethod, PutMethod, PostMethod, DeleteMethod, OptionsMethod, HeadMethod, PatchMethod, DeleteMethod]
|
||||
operation <- F.toList $ getOp mpi
|
||||
-- Got only Justs here
|
||||
let mop = MatchedOperation { operation , pathParams, getPathFragments }
|
||||
pure (s, Traced (step s) mop)
|
||||
check _ pc = checkCompatibility @MatchedOperation env pc
|
||||
let retraced = \op -> MatchedOperation { operation = op, pathParams, getPathFragments }
|
||||
pure (i, retraced <$> operation)
|
||||
check pc = checkCompatibility @MatchedOperation env pc
|
||||
-- Operations are sum-like entities. Use step to operation as key because
|
||||
-- why not
|
||||
checkSums OperationMissing check operations
|
||||
checkSums OperationMissing (const check) operations
|
||||
|
||||
|
||||
instance Steppable ProcessedPathItems MatchedPathItem where
|
||||
@ -183,19 +181,11 @@ instance Steppable ProcessedPathItems MatchedPathItem where
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance Steppable MatchedPathItem MatchedOperation where
|
||||
data Step MatchedPathItem MatchedOperation
|
||||
= GetStep
|
||||
| PutStep
|
||||
| PostStep
|
||||
| DeleteStep
|
||||
| OptionsStep
|
||||
| HeadStep
|
||||
| PatchStep
|
||||
| TraceStep
|
||||
data Step MatchedPathItem MatchedOperation = OperationMethodStep OperationMethod
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance Steppable MatchedPathItem (Referenced Param) where
|
||||
data Step MatchedPathItem (Referenced Param) = PathItemParam
|
||||
data Step MatchedPathItem (Referenced Param) = PathItemParam Int
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance Steppable MatchedPathItem PathFragmentParam where
|
||||
|
||||
@ -14,58 +14,36 @@ This module abstracts this logic for arbitrary elements -}
|
||||
|
||||
module OpenAPI.Checker.Validate.Products
|
||||
( checkProducts
|
||||
, checkProducts'
|
||||
, ProductLike(..)
|
||||
) where
|
||||
|
||||
import Data.Foldable
|
||||
import Data.Functor
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.OpenApi.Internal
|
||||
import OpenAPI.Checker.Subtree
|
||||
import OpenAPI.Checker.Trace
|
||||
|
||||
-- | Some entity which is product-like
|
||||
data ProductLike root a = ProductLike
|
||||
{ traced :: Traced root a
|
||||
{ tracedValue :: Traced root a
|
||||
, required :: Bool
|
||||
}
|
||||
|
||||
checkProducts'
|
||||
:: forall k root t
|
||||
. (Subtree root, Ord k)
|
||||
=> (k -> CheckIssue root)
|
||||
checkProducts
|
||||
:: forall k r t
|
||||
. (Subtree t, Ord k)
|
||||
=> (k -> CheckIssue t)
|
||||
-- ^ No required element found
|
||||
-> (k -> ProdCons t -> CompatFormula t ())
|
||||
-> ProdCons (Map k (ProductLike OpenApi t))
|
||||
-> CompatFormula root ()
|
||||
checkProducts' noElt check (ProdCons p c) = for_ (M.toList c) $ \(key, consElt) ->
|
||||
-> (k -> ProdCons (Traced r t) -> CompatFormula' SubtreeCheckIssue r ())
|
||||
-> ProdCons (Map k (ProductLike r t))
|
||||
-> CompatFormula' SubtreeCheckIssue r ()
|
||||
checkProducts noElt check (ProdCons p c) = for_ (M.toList c) $ \(key, consElt) ->
|
||||
case M.lookup key p of
|
||||
Nothing -> case required consElt of
|
||||
True -> issueAt producer $ noElt key
|
||||
True -> issueAt (tracedValue consElt) $ noElt key
|
||||
False -> pure ()
|
||||
Just prodElt -> do
|
||||
let
|
||||
elts :: ProdCons (ProductLike OpenApi t)
|
||||
elts :: ProdCons (ProductLike r t)
|
||||
elts = ProdCons prodElt consElt
|
||||
trace = getTrace . traced <$> elts
|
||||
elements = getTraced . traced <$> elts
|
||||
localTrace' trace $ check key elements
|
||||
|
||||
checkProducts
|
||||
:: forall k root t
|
||||
. (Subtree root, Ord k)
|
||||
=> (k -> CheckIssue root)
|
||||
-- ^ No required element found
|
||||
-> (k -> ProdCons t -> CompatFormula t ())
|
||||
-> ProdCons (Map k (ProductLike root t))
|
||||
-> CompatFormula root ()
|
||||
checkProducts noElt check prodCons = withTrace $ \myTrace ->
|
||||
let
|
||||
retracedPC = retracePC <$> myTrace <*> prodCons
|
||||
retracePC rootTrace els = els <&> \productLike ->
|
||||
ProductLike
|
||||
{ traced = retrace rootTrace $ traced productLike
|
||||
, required = required productLike }
|
||||
in checkProducts' noElt check retracedPC
|
||||
check key (tracedValue <$> elts)
|
||||
|
||||
@ -1,11 +1,10 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module OpenAPI.Checker.Validate.RequestBody
|
||||
(
|
||||
( CheckIssue (..)
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Functor
|
||||
import Data.HList
|
||||
import Data.HashMap.Strict.InsOrd as IOHM
|
||||
import Data.Map.Strict as M
|
||||
@ -14,32 +13,31 @@ import Data.OpenApi
|
||||
import Network.HTTP.Media (MediaType)
|
||||
import OpenAPI.Checker.Subtree
|
||||
import OpenAPI.Checker.Trace
|
||||
import OpenAPI.Checker.Validate.MediaTypeObject ()
|
||||
import OpenAPI.Checker.Validate.MediaTypeObject
|
||||
import OpenAPI.Checker.Validate.Sums
|
||||
|
||||
tracedContent :: Traced r RequestBody -> IOHM.InsOrdHashMap MediaType (Traced r MediaTypeObject)
|
||||
tracedContent resp = IOHM.mapWithKey (\k -> traced (ask resp >>> step (RequestMediaTypeObject k)))
|
||||
$ _requestBodyContent $ extract resp
|
||||
|
||||
instance Subtree RequestBody where
|
||||
type CheckEnv RequestBody =
|
||||
'[ ProdCons (Definitions Schema) ]
|
||||
data CheckIssue RequestBody
|
||||
= RequestBodyRequired
|
||||
| RequestMediaTypeNotFound MediaType
|
||||
= NoRequestBody
|
||||
| RequestBodyRequired
|
||||
deriving (Eq, Ord, Show)
|
||||
checkCompatibility env prodCons@(ProdCons p c) =
|
||||
if not (fromMaybe False $ _requestBodyRequired p)
|
||||
&& (fromMaybe False $ _requestBodyRequired c)
|
||||
then issueAt producer RequestBodyRequired
|
||||
if not (fromMaybe False . _requestBodyRequired . extract $ p)
|
||||
&& (fromMaybe False . _requestBodyRequired . extract $ c)
|
||||
then issueAt p RequestBodyRequired
|
||||
else
|
||||
-- Media type object are sums-like entities.
|
||||
let
|
||||
check mediaType pc = checkCompatibility @MediaTypeObject (HCons mediaType env) pc
|
||||
sumElts = getSum <$> prodCons
|
||||
getSum rb = M.fromList
|
||||
$ (IOHM.toList $ _requestBodyContent rb) <&> \(mt, mto) ->
|
||||
( mt
|
||||
, Traced
|
||||
{ getTraced = mto
|
||||
, getTrace = step $ RequestMediaTypeObject mt })
|
||||
in checkSums RequestMediaTypeNotFound check sumElts
|
||||
getSum rb = M.fromList . IOHM.toList $ tracedContent rb
|
||||
in checkSums (const RequestMediaTypeNotFound) check sumElts
|
||||
|
||||
instance Steppable RequestBody MediaTypeObject where
|
||||
data Step RequestBody MediaTypeObject = RequestMediaTypeObject MediaType
|
||||
|
||||
@ -6,6 +6,7 @@ module OpenAPI.Checker.Validate.Responses
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Lens
|
||||
import Data.Foldable
|
||||
import Data.HList
|
||||
import Data.HashMap.Strict.InsOrd as IOHM
|
||||
@ -16,18 +17,22 @@ import Network.HTTP.Media (MediaType)
|
||||
import OpenAPI.Checker.References
|
||||
import OpenAPI.Checker.Subtree
|
||||
import OpenAPI.Checker.Trace
|
||||
import OpenAPI.Checker.Validate.MediaTypeObject ()
|
||||
import OpenAPI.Checker.Validate.MediaTypeObject
|
||||
import OpenAPI.Checker.Validate.Products
|
||||
import OpenAPI.Checker.Validate.Schema ()
|
||||
import OpenAPI.Checker.Validate.Sums
|
||||
|
||||
tracedResponses :: Traced r Responses -> IOHM.InsOrdHashMap HttpStatusCode (Traced r (Referenced Response))
|
||||
tracedResponses resp = IOHM.mapWithKey (\k -> traced (ask resp >>> step (ResponseCodeStep k)))
|
||||
$ _responsesResponses $ extract resp
|
||||
|
||||
instance Subtree Responses where
|
||||
type CheckEnv Responses =
|
||||
'[ ProdCons (Definitions Response)
|
||||
, ProdCons (Definitions Header)
|
||||
, ProdCons (Definitions Schema)
|
||||
]
|
||||
data CheckIssue Responses = ResponseCodeNotFound HttpStatusCode
|
||||
data CheckIssue Responses
|
||||
deriving (Eq, Ord, Show)
|
||||
-- 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
|
||||
@ -35,15 +40,20 @@ instance Subtree Responses where
|
||||
checkCompatibility env prodCons = do
|
||||
let
|
||||
defs = getH @(ProdCons (Definitions Response)) env
|
||||
check _ resps = checkCompatibility @Response env resps
|
||||
check resps = checkCompatibility @Response env resps
|
||||
elements = getEls <$> defs <*> prodCons
|
||||
getEls respDef resps = M.fromList $ do
|
||||
(code, respRef) <- IOHM.toList $ _responsesResponses resps
|
||||
let
|
||||
traced = dereferenceTraced respDef
|
||||
$ Traced (step $ ResponseCodeStep code) respRef
|
||||
pure (code, traced)
|
||||
checkSums ResponseCodeNotFound check elements
|
||||
(code, respRef) <- IOHM.toList $ tracedResponses resps
|
||||
pure (code, dereference respDef respRef)
|
||||
checkSums (const ResponseCodeNotFound) (const check) elements
|
||||
|
||||
tracedContent :: Traced r Response -> IOHM.InsOrdHashMap MediaType (Traced r MediaTypeObject)
|
||||
tracedContent resp = IOHM.mapWithKey (\k -> traced (ask resp >>> step (ResponseMediaObject k)))
|
||||
$ _responseContent $ extract resp
|
||||
|
||||
tracedHeaders :: Traced r Response -> IOHM.InsOrdHashMap HeaderName (Traced r (Referenced Header))
|
||||
tracedHeaders resp = IOHM.mapWithKey (\k -> traced (ask resp >>> step (ResponseHeader k)))
|
||||
$ _responseHeaders $ extract resp
|
||||
|
||||
instance Subtree Response where
|
||||
type CheckEnv Response =
|
||||
@ -51,8 +61,7 @@ instance Subtree Response where
|
||||
, ProdCons (Definitions Schema)
|
||||
]
|
||||
data CheckIssue Response
|
||||
= ResponseMediaTypeMissing MediaType
|
||||
| ResponseHeaderMissing HeaderName
|
||||
= ResponseCodeNotFound
|
||||
deriving (Eq, Ord, Show)
|
||||
checkCompatibility env prodCons = do
|
||||
-- Roles are already swapped. Producer is a server and consumer is a client
|
||||
@ -67,46 +76,44 @@ instance Subtree Response where
|
||||
let mtEnv = HCons mediaType $ env
|
||||
in checkCompatibility @MediaTypeObject mtEnv mtObj
|
||||
elements = getEls <$> prodCons
|
||||
getEls resp = M.fromList $ do
|
||||
(mediaType, mtObj) <- IOHM.toList $ _responseContent resp
|
||||
let traced = Traced (step $ ResponseMediaObject mediaType) mtObj
|
||||
pure (mediaType, traced)
|
||||
checkSums ResponseMediaTypeMissing check elements
|
||||
getEls resp = M.fromList . IOHM.toList $ tracedContent resp
|
||||
checkSums (const ResponseMediaTypeMissing) check elements
|
||||
|
||||
checkHeaders = do
|
||||
-- Headers are product-like entities
|
||||
let
|
||||
check _hname hdrs = checkCompatibility @Header env hdrs
|
||||
check hdrs = checkCompatibility @Header env hdrs
|
||||
elements = getEls <$> headerDefs <*> prodCons
|
||||
getEls headerDef resp = M.fromList $ do
|
||||
(hname, headerRef) <- IOHM.toList $ _responseHeaders resp
|
||||
let
|
||||
traced = dereferenceTraced headerDef
|
||||
$ Traced (step $ ResponseHeader hname) headerRef
|
||||
required = fromMaybe False $ _headerRequired $ getTraced traced
|
||||
elt = ProductLike { traced, required }
|
||||
pure (hname, elt)
|
||||
checkProducts ResponseHeaderMissing check elements
|
||||
(hname, headerRef) <- IOHM.toList $ tracedHeaders resp
|
||||
let header = dereference headerDef headerRef
|
||||
pure (hname, ProductLike
|
||||
{ tracedValue = header
|
||||
, required = fromMaybe False . _headerRequired . extract $ header
|
||||
})
|
||||
checkProducts (const ResponseHeaderMissing) (const check) elements
|
||||
headerDefs = getH @(ProdCons (Definitions Header)) env
|
||||
|
||||
tracedSchema :: Traced r Header -> Maybe (Traced r (Referenced Schema))
|
||||
tracedSchema hdr = _headerSchema (extract hdr) <&> traced (ask hdr >>> step HeaderSchema)
|
||||
|
||||
instance Subtree Header where
|
||||
type CheckEnv Header = '[ProdCons (Definitions Schema)]
|
||||
data CheckIssue Header
|
||||
= RequiredHeaderMissing
|
||||
= ResponseHeaderMissing
|
||||
| RequiredHeaderMissing
|
||||
| NonEmptyHeaderRequired
|
||||
| HeaderSchemaRequired
|
||||
deriving (Eq, Ord, Show)
|
||||
checkCompatibility env (ProdCons p c) = do
|
||||
if (fromMaybe False $ _headerRequired c) && not (fromMaybe False $ _headerRequired p)
|
||||
then issueAt producer RequiredHeaderMissing else pure ()
|
||||
if not (fromMaybe False $ _headerAllowEmptyValue c) && (fromMaybe False $ _headerAllowEmptyValue p)
|
||||
then issueAt producer NonEmptyHeaderRequired else pure ()
|
||||
for_ (_headerSchema c) $ \consRef ->
|
||||
case (_headerSchema p) of
|
||||
Nothing -> issueAt producer HeaderSchemaRequired
|
||||
Just prodRef -> do
|
||||
localStep HeaderSchema
|
||||
$ checkCompatibility env $ ProdCons prodRef consRef
|
||||
if (fromMaybe False $ _headerRequired $ extract c) && not (fromMaybe False $ _headerRequired $ extract p)
|
||||
then issueAt p RequiredHeaderMissing else pure ()
|
||||
if not (fromMaybe False $ _headerAllowEmptyValue $ extract c) && (fromMaybe False $ _headerAllowEmptyValue $ extract p)
|
||||
then issueAt p NonEmptyHeaderRequired else pure ()
|
||||
for_ (tracedSchema c) $ \consRef ->
|
||||
case tracedSchema p of
|
||||
Nothing -> issueAt p HeaderSchemaRequired
|
||||
Just prodRef -> checkCompatibility env (ProdCons prodRef consRef)
|
||||
pure ()
|
||||
|
||||
instance Steppable Responses (Referenced Response) where
|
||||
|
||||
@ -14,7 +14,11 @@ module OpenAPI.Checker.Validate.Schema
|
||||
|
||||
import Algebra.Lattice
|
||||
import Control.Applicative
|
||||
import Control.Monad.Reader
|
||||
import Control.Arrow
|
||||
import Control.Comonad.Env hiding (env)
|
||||
import Control.Lens hiding (cons)
|
||||
import Control.Monad.Reader hiding (ask)
|
||||
import qualified Control.Monad.Reader as R
|
||||
import Control.Monad.Writer
|
||||
import qualified Data.Aeson as A
|
||||
import Data.Coerce
|
||||
@ -154,7 +158,7 @@ deriving stock instance Ord (Condition t)
|
||||
deriving stock instance Show (Condition t)
|
||||
|
||||
data SomeCondition where
|
||||
SomeCondition :: Typeable t => Condition t -> SomeCondition
|
||||
SomeCondition :: Typeable t => Traced OpenApi (Condition t) -> SomeCondition
|
||||
|
||||
instance Eq SomeCondition where
|
||||
SomeCondition x == SomeCondition y = case cast x of
|
||||
@ -200,8 +204,8 @@ isSingleton s
|
||||
| otherwise = Nothing
|
||||
|
||||
pattern Conjunct :: [Traced r (Condition t)] -> M.Map (Condition t) (Trace r (Condition t))
|
||||
pattern Conjunct xs <- (map (uncurry $ flip Traced) . M.toList -> xs)
|
||||
where Conjunct xs = M.fromList [(x, t) | Traced t x <- xs]
|
||||
pattern Conjunct xs <- (map (uncurry $ flip traced) . M.toList -> xs)
|
||||
where Conjunct xs = M.fromList $ (extract &&& ask) <$> xs
|
||||
{-# COMPLETE Conjunct #-}
|
||||
|
||||
pattern SingleConjunct :: [Traced r (Condition t)] -> JsonFormula r t
|
||||
@ -218,19 +222,16 @@ instance BoundedJoinSemiLattice (JsonFormula r t) where
|
||||
instance BoundedMeetSemiLattice (JsonFormula r t) where
|
||||
top = TopFormula
|
||||
|
||||
singletonFormula :: Trace r (Condition t) -> Condition t -> JsonFormula r t
|
||||
singletonFormula t x = SingleConjunct [Traced t x]
|
||||
|
||||
foldLattice
|
||||
:: BoundedLattice l
|
||||
=> (Traced r (Condition t) -> l)
|
||||
-> JsonFormula r t
|
||||
-> l
|
||||
foldLattice f (DNF xss) = S.foldl' (\z w ->
|
||||
z \/ M.foldlWithKey' (\x y t -> x /\ f (Traced t y)) top w) bottom xss
|
||||
z \/ M.foldlWithKey' (\x y t -> x /\ f (traced t y)) top w) bottom xss
|
||||
|
||||
satisfiesFormula :: TypedValue t -> JsonFormula r t -> Bool
|
||||
satisfiesFormula val = foldLattice (satisfiesTyped val . getTraced)
|
||||
satisfiesFormula val = foldLattice (satisfiesTyped val . extract)
|
||||
|
||||
data ForeachType (f :: JsonType -> Type) = ForeachType
|
||||
{ forNull :: f 'Null
|
||||
@ -345,22 +346,52 @@ instance Steppable Schema (Referenced Schema) where
|
||||
= AllOfStep Int
|
||||
| OneOfStep Int
|
||||
| AnyOfStep Int
|
||||
| ItemsStep
|
||||
| ItemsObjectStep
|
||||
| ItemsArrayStep Int
|
||||
| AdditionalPropertiesStep
|
||||
| PropertiesStep Text
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
type ProcessM = ReaderT (Definitions Schema) (Writer (T.TracePrefixTree SubtreeCheckIssue OpenApi))
|
||||
|
||||
warn :: Subtree t => Trace OpenApi t -> CheckIssue t -> ProcessM ()
|
||||
warn t x = tell $ T.singleton $ AnItem t $ SubtreeCheckIssue x
|
||||
warn
|
||||
:: (Subtree t, ComonadEnv (Trace OpenApi t) w)
|
||||
=> w x -> CheckIssue t -> ProcessM ()
|
||||
warn t issue = tell $ T.singleton $ AnItem (ask t) $ SubtreeCheckIssue issue
|
||||
|
||||
processRefSchema
|
||||
:: Traced OpenApi (Referenced Schema)
|
||||
-> ProcessM (ForeachType (JsonFormula OpenApi))
|
||||
processRefSchema x = do
|
||||
defs <- ask
|
||||
processSchema $ dereferenceTraced defs x
|
||||
defs <- R.ask
|
||||
processSchema $ dereference defs x
|
||||
|
||||
tracedAllOf :: Traced r Schema -> Maybe [Traced r (Referenced Schema)]
|
||||
tracedAllOf sch = _schemaAllOf (extract sch) <&> \xs ->
|
||||
[ traced (ask sch >>> step (AllOfStep i)) x | (i, x) <- zip [0..] xs ]
|
||||
|
||||
tracedAnyOf :: Traced r Schema -> Maybe [Traced r (Referenced Schema)]
|
||||
tracedAnyOf sch = _schemaAnyOf (extract sch) <&> \xs ->
|
||||
[ traced (ask sch >>> step (AnyOfStep i)) x | (i, x) <- zip [0..] xs ]
|
||||
|
||||
tracedOneOf :: Traced r Schema -> Maybe [Traced r (Referenced Schema)]
|
||||
tracedOneOf sch = _schemaOneOf (extract sch) <&> \xs ->
|
||||
[ traced (ask sch >>> step (OneOfStep i)) x | (i, x) <- zip [0..] xs ]
|
||||
|
||||
tracedItems :: Traced r Schema -> Maybe (Either (Traced r (Referenced Schema)) [Traced r (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 ]
|
||||
|
||||
tracedAdditionalProperties :: Traced r Schema -> Maybe (Either Bool (Traced r (Referenced Schema)))
|
||||
tracedAdditionalProperties sch = _schemaAdditionalProperties (extract sch) <&> \case
|
||||
AdditionalPropertiesAllowed b -> Left b
|
||||
AdditionalPropertiesSchema x -> Right $ traced (ask sch >>> step AdditionalPropertiesStep) x
|
||||
|
||||
tracedProperties :: Traced r Schema -> IOHM.InsOrdHashMap Text (Traced r (Referenced Schema))
|
||||
tracedProperties sch = IOHM.mapWithKey (\k -> traced (ask sch >>> step (PropertiesStep 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
|
||||
@ -368,36 +399,33 @@ processRefSchema x = do
|
||||
processSchema
|
||||
:: Traced OpenApi Schema
|
||||
-> ProcessM (ForeachType (JsonFormula OpenApi))
|
||||
processSchema (Traced t Schema{..}) = do
|
||||
processSchema sch@(extract -> Schema{..}) = do
|
||||
let
|
||||
singletonFormula :: Typeable t => Step Schema (Condition t) -> Condition t -> JsonFormula OpenApi t
|
||||
singletonFormula t f = SingleConjunct [traced (ask sch >>> step t) f]
|
||||
|
||||
allClauses <- case _schemaAllOf of
|
||||
allClauses <- case tracedAllOf sch of
|
||||
Nothing -> pure []
|
||||
Just [] -> [] <$ warn t (InvalidSchema "no items in allOf")
|
||||
Just xs -> sequence
|
||||
[ processRefSchema (Traced (t `Snoc` AllOfStep i) rs)
|
||||
| (i, rs) <- zip [0..] xs ]
|
||||
Just [] -> [] <$ warn sch (InvalidSchema "no items in allOf")
|
||||
Just xs -> mapM processRefSchema xs
|
||||
|
||||
anyClause <- case _schemaAnyOf of
|
||||
anyClause <- case tracedAnyOf sch of
|
||||
Nothing -> pure top
|
||||
Just [] -> bottom <$ warn t (InvalidSchema "no items in anyOf")
|
||||
Just xs -> joins <$> sequence
|
||||
[ processRefSchema (Traced (t `Snoc` AnyOfStep i) rs)
|
||||
| (i, rs) <- zip [0..] xs ]
|
||||
Just [] -> bottom <$ warn sch (InvalidSchema "no items in anyOf")
|
||||
Just xs -> joins <$> mapM processRefSchema xs
|
||||
|
||||
oneClause <- case _schemaOneOf of
|
||||
oneClause <- case tracedOneOf sch of
|
||||
Nothing -> pure top
|
||||
Just [] -> bottom <$ warn t (InvalidSchema "no items in oneOf")
|
||||
Just [] -> bottom <$ warn sch (InvalidSchema "no items in oneOf")
|
||||
Just xs -> do
|
||||
checkOneOfDisjoint xs >>= \case
|
||||
True -> pure ()
|
||||
False -> warn t (NotSupported "Could not determine that oneOf branches are disjoint")
|
||||
joins <$> sequence
|
||||
[ processRefSchema (Traced (t `Snoc` OneOfStep i) rs)
|
||||
| (i, rs) <- zip [0..] xs ]
|
||||
False -> warn sch (NotSupported "Could not determine that oneOf branches are disjoint")
|
||||
joins <$> mapM processRefSchema xs
|
||||
|
||||
case _schemaNot of
|
||||
Nothing -> pure ()
|
||||
Just _ -> warn t (NotSupported "not clause is unsupported")
|
||||
Just _ -> warn sch (NotSupported "not clause is unsupported")
|
||||
|
||||
let
|
||||
typeClause = case _schemaType of
|
||||
@ -409,7 +437,7 @@ processSchema (Traced t Schema{..}) = do
|
||||
Just OpenApiNumber -> bottom
|
||||
{ forBoolean = top }
|
||||
Just OpenApiInteger -> bottom
|
||||
{ forNumber = singletonFormula (t `Snoc` IntegerType) $ MultipleOf 1 }
|
||||
{ forNumber = singletonFormula IntegerType $ MultipleOf 1 }
|
||||
Just OpenApiString -> bottom
|
||||
{ forString = top }
|
||||
Just OpenApiArray -> bottom
|
||||
@ -419,27 +447,27 @@ processSchema (Traced t Schema{..}) = do
|
||||
|
||||
let
|
||||
valueEnum A.Null = bottom
|
||||
{ forNull = singletonFormula (t `Snoc` EnumField) $ Exactly TNull }
|
||||
{ forNull = singletonFormula EnumField $ Exactly TNull }
|
||||
valueEnum (A.Bool b) = bottom
|
||||
{ forBoolean = singletonFormula (t `Snoc` EnumField) $ Exactly $ TBool b }
|
||||
{ forBoolean = singletonFormula EnumField $ Exactly $ TBool b }
|
||||
valueEnum (A.Number n) = bottom
|
||||
{ forNumber = singletonFormula (t `Snoc` EnumField) $ Exactly $ TNumber n }
|
||||
{ forNumber = singletonFormula EnumField $ Exactly $ TNumber n }
|
||||
valueEnum (A.String s) = bottom
|
||||
{ forString = singletonFormula (t `Snoc` EnumField) $ Exactly $ TString s }
|
||||
{ forString = singletonFormula EnumField $ Exactly $ TString s }
|
||||
valueEnum (A.Array a) = bottom
|
||||
{ forArray = singletonFormula (t `Snoc` EnumField) $ Exactly $ TArray a }
|
||||
{ forArray = singletonFormula EnumField $ Exactly $ TArray a }
|
||||
valueEnum (A.Object o) = bottom
|
||||
{ forObject = singletonFormula (t `Snoc` EnumField) $ Exactly $ TObject o }
|
||||
{ forObject = singletonFormula EnumField $ Exactly $ TObject o }
|
||||
enumClause <- case _schemaEnum of
|
||||
Nothing -> pure top
|
||||
Just [] -> bottom <$ warn t (InvalidSchema "no items in enum")
|
||||
Just [] -> bottom <$ warn sch (InvalidSchema "no items in enum")
|
||||
Just xs -> pure $ joins (valueEnum <$> xs)
|
||||
|
||||
let
|
||||
maximumClause = case _schemaMaximum of
|
||||
Nothing -> top
|
||||
Just n -> top
|
||||
{ forNumber = singletonFormula (t `Snoc` MaximumFields) $ Maximum $
|
||||
{ forNumber = singletonFormula MaximumFields $ Maximum $
|
||||
case _schemaExclusiveMaximum of
|
||||
Just True -> Exclusive n
|
||||
_ -> Inclusive n }
|
||||
@ -447,7 +475,7 @@ processSchema (Traced t Schema{..}) = do
|
||||
minimumClause = case _schemaMinimum of
|
||||
Nothing -> top
|
||||
Just n -> top
|
||||
{ forNumber = singletonFormula (t `Snoc` MinimumFields) $ Minimum $ Down $
|
||||
{ forNumber = singletonFormula MinimumFields $ Minimum $ Down $
|
||||
case _schemaExclusiveMinimum of
|
||||
Just True -> Exclusive $ Down n
|
||||
_ -> Inclusive $ Down n }
|
||||
@ -455,72 +483,68 @@ processSchema (Traced t Schema{..}) = do
|
||||
multipleOfClause = case _schemaMultipleOf of
|
||||
Nothing -> top
|
||||
Just n -> top
|
||||
{ forNumber = singletonFormula (t `Snoc` MultipleOfField) $ MultipleOf n }
|
||||
{ forNumber = singletonFormula MultipleOfField $ MultipleOf n }
|
||||
|
||||
formatClause <- case _schemaFormat of
|
||||
Nothing -> pure top
|
||||
Just f | f `elem` ["int32", "int64", "float", "double"] -> pure top
|
||||
{ forNumber = singletonFormula (t `Snoc` FormatField) $ NumberFormat f }
|
||||
{ forNumber = singletonFormula FormatField $ NumberFormat f }
|
||||
Just f | f `elem` ["byte", "binary", "date", "date-time", "password"] -> pure top
|
||||
{ forString = singletonFormula (t `Snoc` FormatField) $ StringFormat f }
|
||||
Just f -> top <$ warn t (NotSupported $ "Unknown format: " <> f)
|
||||
{ forString = singletonFormula FormatField $ StringFormat f }
|
||||
Just f -> top <$ warn sch (NotSupported $ "Unknown format: " <> f)
|
||||
|
||||
let
|
||||
maxLengthClause = case _schemaMaxLength of
|
||||
Nothing -> top
|
||||
Just n -> top
|
||||
{ forString = singletonFormula (t `Snoc` MaxLengthField) $ MaxLength n }
|
||||
{ forString = singletonFormula MaxLengthField $ MaxLength n }
|
||||
|
||||
minLengthClause = case _schemaMinLength of
|
||||
Nothing -> top
|
||||
Just n -> top
|
||||
{ forString = singletonFormula (t `Snoc` MinLengthField) $ MinLength n }
|
||||
{ forString = singletonFormula MinLengthField $ MinLength n }
|
||||
|
||||
patternClause = case _schemaPattern of
|
||||
Nothing -> top
|
||||
Just p -> top
|
||||
{ forString = singletonFormula (t `Snoc` PatternField) $ Pattern p }
|
||||
{ forString = singletonFormula PatternField $ Pattern p }
|
||||
|
||||
itemsClause <- case _schemaItems of
|
||||
itemsClause <- case tracedItems sch of
|
||||
Nothing -> pure top
|
||||
Just (OpenApiItemsObject rs) -> do
|
||||
let trs = Traced (t `Snoc` ItemsStep) rs
|
||||
f <- processRefSchema trs
|
||||
pure top { forArray = singletonFormula (t `Snoc` ItemsField) $ Items f trs }
|
||||
Just (OpenApiItemsArray _) -> top <$ warn t (NotSupported "array in items is not supported")
|
||||
Just (Left rs) -> do
|
||||
f <- processRefSchema rs
|
||||
pure top { forArray = singletonFormula ItemsField $ Items f rs }
|
||||
Just (Right _) -> top <$ warn sch (NotSupported "array in items is not supported")
|
||||
|
||||
let
|
||||
maxItemsClause = case _schemaMaxItems of
|
||||
Nothing -> top
|
||||
Just n -> top
|
||||
{ forArray = singletonFormula (t `Snoc` MaxItemsField) $ MaxItems n }
|
||||
{ forArray = singletonFormula MaxItemsField $ MaxItems n }
|
||||
|
||||
minItemsClause = case _schemaMinItems of
|
||||
Nothing -> top
|
||||
Just n -> top
|
||||
{ forArray = singletonFormula (t `Snoc` MinItemsField) $ MinItems n }
|
||||
{ forArray = singletonFormula MinItemsField $ MinItems n }
|
||||
|
||||
uniqueItemsClause = case _schemaUniqueItems of
|
||||
Just True -> top
|
||||
{ forArray = singletonFormula (t `Snoc` UniqueItemsField) UniqueItems }
|
||||
{ forArray = singletonFormula UniqueItemsField UniqueItems }
|
||||
_ -> top
|
||||
|
||||
(addProps, addPropSchema) <- case _schemaAdditionalProperties of
|
||||
Just (AdditionalPropertiesSchema rs) -> do
|
||||
let trs = Traced (t `Snoc` AdditionalPropertiesStep) rs
|
||||
(,Just trs) <$> processRefSchema trs
|
||||
Just (AdditionalPropertiesAllowed False) -> pure (bottom, Nothing)
|
||||
_ -> pure (top, Just $ Traced (t `Snoc` AdditionalPropertiesStep) $ Inline mempty)
|
||||
(addProps, addPropSchema) <- case tracedAdditionalProperties sch of
|
||||
Just (Right rs) -> (,Just rs) <$> processRefSchema rs
|
||||
Just (Left False) -> pure (bottom, Nothing)
|
||||
_ -> pure (top, Just $ traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty)
|
||||
propList <- forM (S.toList . S.fromList $ IOHM.keys _schemaProperties <> _schemaRequired) $ \k -> do
|
||||
(f, sch) <- case IOHM.lookup k _schemaProperties of
|
||||
Just rs -> do
|
||||
let trs = Traced (t `Snoc` PropertiesStep k) rs
|
||||
(,trs) <$> processRefSchema trs
|
||||
Nothing -> pure (addProps, fromMaybe (Traced (t `Snoc` AdditionalPropertiesStep) $ Inline mempty) addPropSchema)
|
||||
(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
|
||||
pure (k, Property (k `elem` _schemaRequired) f sch)
|
||||
in 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
|
||||
@ -537,21 +561,21 @@ processSchema (Traced t Schema{..}) = do
|
||||
= top -- if all fields are optional and have trivial schemata
|
||||
| otherwise
|
||||
= top
|
||||
{ forObject = singletonFormula (t `Snoc` PropertiesFields) $ Properties propMap addProps addPropSchema }
|
||||
{ forObject = singletonFormula PropertiesFields $ Properties propMap addProps addPropSchema }
|
||||
|
||||
maxPropertiesClause = case _schemaMaxProperties of
|
||||
Nothing -> top
|
||||
Just n -> top
|
||||
{ forObject = singletonFormula (t `Snoc` MaxPropertiesField) $ MaxProperties n }
|
||||
{ forObject = singletonFormula MaxPropertiesField $ MaxProperties n }
|
||||
|
||||
minPropertiesClause = case _schemaMinProperties of
|
||||
Nothing -> top
|
||||
Just n -> top
|
||||
{ forObject = singletonFormula (t `Snoc` MinPropertiesField) $ MinProperties n }
|
||||
{ forObject = singletonFormula MinPropertiesField $ MinProperties n }
|
||||
|
||||
nullableClause
|
||||
| Just True <- _schemaNullable = bottom
|
||||
{ forNull = singletonFormula (t `Snoc` NullableField) $ Exactly TNull }
|
||||
{ forNull = singletonFormula NullableField $ Exactly TNull }
|
||||
| otherwise = bottom
|
||||
|
||||
pure $ nullableClause \/ meets (allClauses <>
|
||||
@ -561,7 +585,7 @@ processSchema (Traced t Schema{..}) = do
|
||||
, uniqueItemsClause, propertiesClause, maxPropertiesClause, minPropertiesClause])
|
||||
{- TODO: ReadOnly/WriteOnly -}
|
||||
|
||||
checkOneOfDisjoint :: [Referenced Schema] -> ProcessM Bool
|
||||
checkOneOfDisjoint :: [Traced OpenApi (Referenced Schema)] -> ProcessM Bool
|
||||
checkOneOfDisjoint = const $ pure True -- TODO
|
||||
|
||||
schemaToFormula
|
||||
@ -575,7 +599,7 @@ checkFormulas
|
||||
=> HList xs
|
||||
-> Trace OpenApi Schema
|
||||
-> ProdCons (ForeachType (JsonFormula OpenApi), T.TracePrefixTree SubtreeCheckIssue OpenApi)
|
||||
-> CompatFormula Schema ()
|
||||
-> CompatFormula ()
|
||||
checkFormulas env tr (ProdCons (fp, ep) (fc, ec)) =
|
||||
case T.toList ep ++ T.toList ec of
|
||||
issues@(_:_) -> F.for_ issues $ \(AnItem t (SubtreeCheckIssue e)) -> issueAtTrace t e
|
||||
@ -613,13 +637,13 @@ checkFormulas env tr (ProdCons (fp, ep) (fc, ec)) =
|
||||
(DNF pss, SingleConjunct cs) -> F.for_ pss $ \(Conjunct ps) -> do
|
||||
F.for_ cs $ checkImplication env ps -- avoid disjuntion if there's only one conjunct
|
||||
(DNF pss, DNF css) -> F.for_ pss $ \(Conjunct ps) -> do
|
||||
anyOfM tr (SubtreeCheckIssue $ NoMatchingCondition $ SomeCondition . getTraced <$> ps)
|
||||
anyOfM tr (NoMatchingCondition $ SomeCondition <$> ps)
|
||||
[F.for_ cs $ checkImplication env ps | Conjunct cs <- S.toList css]
|
||||
|
||||
checkContradiction
|
||||
:: Trace OpenApi Schema
|
||||
-> [Traced OpenApi (Condition t)]
|
||||
-> CompatFormula s ()
|
||||
-> CompatFormula ()
|
||||
checkContradiction tr _ = issueAtTrace tr NoContradiction -- TODO
|
||||
|
||||
checkImplication
|
||||
@ -627,96 +651,93 @@ checkImplication
|
||||
=> HList xs
|
||||
-> [Traced OpenApi (Condition t)]
|
||||
-> Traced OpenApi (Condition t)
|
||||
-> CompatFormula s ()
|
||||
checkImplication env prods (Traced t cons) = case findExactly prods of
|
||||
-> CompatFormula ()
|
||||
checkImplication env prods cons = case findExactly prods of
|
||||
Just e
|
||||
| all (satisfiesTyped e) (getTraced <$> prods) ->
|
||||
if satisfiesTyped e cons then pure ()
|
||||
else issueAtTrace t (EnumDoesntSatisfy e)
|
||||
| all (satisfiesTyped e) (extract <$> prods) ->
|
||||
if satisfiesTyped e $ extract cons then pure ()
|
||||
else issueAt cons (EnumDoesntSatisfy e)
|
||||
| otherwise -> pure () -- vacuously true
|
||||
Nothing -> case cons of
|
||||
Nothing -> case extract cons of
|
||||
-- the above code didn't catch it, so there's no Exactly condition on the lhs
|
||||
Exactly e -> issueAtTrace t (NoMatchingEnum e)
|
||||
Exactly e -> issueAt cons (NoMatchingEnum e)
|
||||
Maximum m -> case findRelevant min (\case Maximum m' -> Just m'; _ -> Nothing) prods of
|
||||
Just m' -> if m' <= m then pure ()
|
||||
else issueAtTrace t (MatchingMaximumWeak m m')
|
||||
Nothing -> issueAtTrace t (NoMatchingMaximum m)
|
||||
else issueAt cons (MatchingMaximumWeak m m')
|
||||
Nothing -> issueAt cons (NoMatchingMaximum m)
|
||||
Minimum m -> case findRelevant max (\case Minimum m' -> Just m'; _ -> Nothing) prods of
|
||||
Just m' -> if m' >= m then pure ()
|
||||
else issueAtTrace t (MatchingMinimumWeak (coerce m) (coerce m'))
|
||||
Nothing -> issueAtTrace t (NoMatchingMinimum (coerce m))
|
||||
else issueAt cons (MatchingMinimumWeak (coerce m) (coerce m'))
|
||||
Nothing -> issueAt cons (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 issueAtTrace t (MatchingMultipleOfWeak m m')
|
||||
Nothing -> issueAtTrace t (NoMatchingMultipleOf m)
|
||||
NumberFormat f -> if any (\case NumberFormat f' -> f == f'; _ -> False) $ getTraced <$> prods
|
||||
then pure () else issueAtTrace t (NoMatchingFormat f)
|
||||
else issueAt cons (MatchingMultipleOfWeak m m')
|
||||
Nothing -> issueAt cons (NoMatchingMultipleOf m)
|
||||
NumberFormat f -> if any (\case NumberFormat f' -> f == f'; _ -> False) $ extract <$> prods
|
||||
then pure () else issueAt cons (NoMatchingFormat f)
|
||||
MaxLength m -> case findRelevant min (\case MaxLength m' -> Just m'; _ -> Nothing) prods of
|
||||
Just m' -> if m' <= m then pure ()
|
||||
else issueAtTrace t (MatchingMaxLengthWeak m m')
|
||||
Nothing -> issueAtTrace t (NoMatchingMaxLength m)
|
||||
else issueAt cons (MatchingMaxLengthWeak m m')
|
||||
Nothing -> issueAt cons (NoMatchingMaxLength m)
|
||||
MinLength m -> case findRelevant max (\case MinLength m' -> Just m'; _ -> Nothing) prods of
|
||||
Just m' -> if m' >= m then pure ()
|
||||
else issueAtTrace t (MatchingMinLengthWeak m m')
|
||||
Nothing -> issueAtTrace t (NoMatchingMinLength m)
|
||||
Pattern p -> if any (\case Pattern p' -> p == p'; _ -> False) $ getTraced <$> prods
|
||||
then pure () else issueAtTrace t (NoMatchingPattern p)
|
||||
StringFormat f -> if any (\case StringFormat f' -> f == f'; _ -> False) $ getTraced <$> prods
|
||||
then pure () else issueAtTrace t (NoMatchingFormat f)
|
||||
Items _ (Traced t' cons') -> case findRelevant (<>) (\case Items _ rs -> Just (rs NE.:| []); _ -> Nothing) prods of
|
||||
Just (rs NE.:| []) -> localTrace' (ProdCons (getTrace rs) t') $ checkCompatibility env $ ProdCons (getTraced rs) cons'
|
||||
else issueAt cons (MatchingMinLengthWeak m m')
|
||||
Nothing -> issueAt cons (NoMatchingMinLength m)
|
||||
Pattern p -> if any (\case Pattern p' -> p == p'; _ -> False) $ extract <$> prods
|
||||
then pure () else issueAt cons (NoMatchingPattern p)
|
||||
StringFormat f -> if any (\case StringFormat f' -> f == f'; _ -> False) $ extract <$> prods
|
||||
then pure () else issueAt cons (NoMatchingFormat f)
|
||||
Items _ cons' -> case findRelevant (<>) (\case Items _ rs -> Just (rs NE.:| []); _ -> Nothing) prods of
|
||||
Just (rs NE.:| []) -> checkCompatibility env $ ProdCons rs cons'
|
||||
Just rs -> do
|
||||
let sch = Inline mempty { _schemaAllOf = Just . NE.toList $ getTraced <$> rs }
|
||||
localTrace' (pure t' {- TODO: what? -}) $ checkCompatibility env $ ProdCons sch cons'
|
||||
Nothing -> issueAtTrace t NoMatchingItems
|
||||
let sch = Inline mempty { _schemaAllOf = Just . NE.toList $ extract <$> rs }
|
||||
checkCompatibility env $ ProdCons (traced (ask $ NE.head rs) sch) cons' -- TODO: bad trace
|
||||
Nothing -> issueAt cons NoMatchingItems
|
||||
MaxItems m -> case findRelevant min (\case MaxItems m' -> Just m'; _ -> Nothing) prods of
|
||||
Just m' -> if m' <= m then pure ()
|
||||
else issueAtTrace t (MatchingMaxItemsWeak m m')
|
||||
Nothing -> issueAtTrace t (NoMatchingMaxItems m)
|
||||
else issueAt cons (MatchingMaxItemsWeak m m')
|
||||
Nothing -> issueAt cons (NoMatchingMaxItems m)
|
||||
MinItems m -> case findRelevant max (\case MinItems m' -> Just m'; _ -> Nothing) prods of
|
||||
Just m' -> if m' >= m then pure ()
|
||||
else issueAtTrace t (MatchingMinItemsWeak m m')
|
||||
Nothing -> issueAtTrace t (NoMatchingMinItems m)
|
||||
UniqueItems -> if any ((== UniqueItems) . getTraced) prods then pure ()
|
||||
else issueAtTrace t NoMatchingUniqueItems
|
||||
else issueAt cons (MatchingMinItemsWeak m m')
|
||||
Nothing -> issueAt cons (NoMatchingMinItems m)
|
||||
UniqueItems -> if any (== UniqueItems) $ extract <$> prods then pure ()
|
||||
else issueAt cons 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
|
||||
let
|
||||
go sch' sch = let schs = ProdCons sch' sch
|
||||
in localTrace' (getTrace <$> schs) $ checkCompatibility env $ getTraced <$> schs
|
||||
let go sch sch' = checkCompatibility env (ProdCons sch sch')
|
||||
case (M.lookup k props', madd', M.lookup k props, madd) of
|
||||
(Nothing, Nothing, _, _) -> pure () -- vacuously
|
||||
(_, _, Nothing, Nothing) -> issueAtTrace t (UnexpectedProperty k)
|
||||
(_, _, Nothing, Nothing) -> issueAt cons (UnexpectedProperty k)
|
||||
(Just p', _, Just p, _) -> go (propRefSchema p') (propRefSchema p)
|
||||
(Nothing, Just add', Just p, _) -> go add' (propRefSchema p)
|
||||
(Just p', _, Nothing, Just add) -> go (propRefSchema p') add
|
||||
(Nothing, Just _, Nothing, Just _) -> pure ()
|
||||
case (maybe False propRequired $ M.lookup k props', maybe False propRequired $ M.lookup k props) of
|
||||
(False, True) -> issueAtTrace t (PropertyNowRequired k)
|
||||
(False, True) -> issueAt cons (PropertyNowRequired k)
|
||||
_ -> pure ()
|
||||
pure ()
|
||||
case (madd', madd) of
|
||||
(Nothing, _) -> pure () -- vacuously
|
||||
(_, Nothing) -> issueAtTrace t NoAdditionalProperties
|
||||
(Just add', Just add) -> let schs = ProdCons add' add
|
||||
in localTrace' (getTrace <$> schs) $ checkCompatibility env $ getTraced <$> schs
|
||||
(_, Nothing) -> issueAt cons NoAdditionalProperties
|
||||
(Just add', Just add) -> checkCompatibility env (ProdCons add' add)
|
||||
pure ()
|
||||
Nothing -> issueAtTrace t NoMatchingProperties
|
||||
Nothing -> issueAt cons NoMatchingProperties
|
||||
MaxProperties m -> case findRelevant min (\case MaxProperties m' -> Just m'; _ -> Nothing) prods of
|
||||
Just m' -> if m' <= m then pure ()
|
||||
else issueAtTrace t (MatchingMaxPropertiesWeak m m')
|
||||
Nothing -> issueAtTrace t (NoMatchingMaxProperties m)
|
||||
else issueAt cons (MatchingMaxPropertiesWeak m m')
|
||||
Nothing -> issueAt cons (NoMatchingMaxProperties m)
|
||||
MinProperties m -> case findRelevant max (\case MinProperties m' -> Just m'; _ -> Nothing) prods of
|
||||
Just m' -> if m' >= m then pure ()
|
||||
else issueAtTrace t (MatchingMinPropertiesWeak m m')
|
||||
Nothing -> issueAtTrace t (NoMatchingMinProperties m)
|
||||
else issueAt cons (MatchingMinPropertiesWeak m m')
|
||||
Nothing -> issueAt cons (NoMatchingMinProperties m)
|
||||
where
|
||||
findExactly (Traced _ (Exactly x):_) = Just x
|
||||
findExactly ((extract -> Exactly x):_) = Just x
|
||||
findExactly (_:xs) = findExactly xs
|
||||
findExactly [] = Nothing
|
||||
findRelevant combine extract
|
||||
= fmap (foldr1 combine) . NE.nonEmpty . mapMaybe (extract . getTraced)
|
||||
findRelevant combine extr
|
||||
= fmap (foldr1 combine) . NE.nonEmpty . mapMaybe (extr . extract)
|
||||
lcmScientific (toRational -> a) (toRational -> b)
|
||||
= fromRational $ lcm (numerator a) (numerator b) % gcd (denominator a) (denominator b)
|
||||
|
||||
@ -753,9 +774,7 @@ instance Typeable t => Subtree (Condition t) where
|
||||
deriving stock (Eq, Ord, Show)
|
||||
type CheckEnv (Condition t) = CheckEnv Schema
|
||||
normalizeTrace = undefined
|
||||
checkCompatibility env conds = withTrace $ \traces -> do
|
||||
case Traced <$> traces <*> conds of
|
||||
ProdCons prod cons -> checkImplication env [prod] cons
|
||||
checkCompatibility env pc = checkImplication env [producer pc] (consumer pc)
|
||||
|
||||
instance Subtree Schema where
|
||||
data CheckIssue Schema
|
||||
@ -765,18 +784,16 @@ instance Subtree Schema where
|
||||
| NoContradiction
|
||||
deriving stock (Eq, Ord, Show)
|
||||
type CheckEnv Schema = '[ProdCons (Definitions Schema)]
|
||||
checkCompatibility env schs = withTrace $ \traces -> do
|
||||
checkCompatibility env schs = do
|
||||
let defs = getH env
|
||||
checkFormulas env (producer traces) $ schemaToFormula <$> defs <*> (Traced <$> traces <*> schs)
|
||||
checkFormulas env (ask $ producer schs) $ schemaToFormula <$> defs <*> schs
|
||||
|
||||
instance Subtree (Referenced Schema) where
|
||||
data CheckIssue (Referenced Schema)
|
||||
deriving stock (Eq, Ord, Show)
|
||||
type CheckEnv (Referenced Schema) = CheckEnv Schema
|
||||
checkCompatibility env refs = withTrace $ \traces -> do
|
||||
checkCompatibility env refs = do
|
||||
let
|
||||
defs = getH env
|
||||
schs = dereference <$> defs <*> refs
|
||||
schs' = retrace <$> traces <*> schs
|
||||
localTrace (getTrace <$> schs) $ do
|
||||
checkFormulas env (producer $ getTrace <$> schs') $ schemaToFormula <$> defs <*> schs'
|
||||
checkFormulas env (ask $ producer schs) $ schemaToFormula <$> defs <*> schs
|
||||
|
||||
@ -1,9 +1,8 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module OpenAPI.Checker.Validate.SecurityRequirement
|
||||
(
|
||||
)
|
||||
where
|
||||
( CheckIssue (..)
|
||||
) where
|
||||
|
||||
import Data.OpenApi
|
||||
import OpenAPI.Checker.Subtree
|
||||
@ -14,5 +13,6 @@ instance Subtree SecurityRequirement where
|
||||
'[ ProdCons (Definitions SecurityScheme)
|
||||
]
|
||||
data CheckIssue SecurityRequirement
|
||||
= SecurityRequirementNotMet
|
||||
deriving (Eq, Ord, Show)
|
||||
checkCompatibility = undefined
|
||||
|
||||
@ -1,9 +1,8 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module OpenAPI.Checker.Validate.Server
|
||||
(
|
||||
)
|
||||
where
|
||||
( CheckIssue(..)
|
||||
) where
|
||||
|
||||
import Data.OpenApi
|
||||
import OpenAPI.Checker.Subtree
|
||||
@ -11,5 +10,6 @@ import OpenAPI.Checker.Subtree
|
||||
instance Subtree Server where
|
||||
type CheckEnv Server = '[]
|
||||
data CheckIssue Server
|
||||
= ServerNotConsumed
|
||||
deriving (Eq, Ord, Show)
|
||||
checkCompatibility = undefined
|
||||
|
||||
@ -10,19 +10,17 @@ import OpenAPI.Checker.Trace
|
||||
|
||||
|
||||
checkSums
|
||||
:: forall k root t
|
||||
. (Ord k, Subtree root)
|
||||
=> (k -> CheckIssue root)
|
||||
-> (k -> ProdCons t -> CompatFormula t ())
|
||||
-> ProdCons (Map k (Traced root t))
|
||||
-> CompatFormula root ()
|
||||
:: forall k r t
|
||||
. (Ord k, Subtree t)
|
||||
=> (k -> CheckIssue t)
|
||||
-> (k -> ProdCons (Traced r t) -> CompatFormula' SubtreeCheckIssue r ())
|
||||
-> ProdCons (Map k (Traced r t))
|
||||
-> CompatFormula' SubtreeCheckIssue r ()
|
||||
checkSums noElt check (ProdCons p c) = for_ (M.toList p) $ \(key, prodElt) ->
|
||||
case M.lookup key c of
|
||||
Nothing -> issueAt consumer $ noElt key
|
||||
Nothing -> issueAt prodElt $ noElt key
|
||||
Just consElt ->
|
||||
let
|
||||
sumElts :: ProdCons (Traced root t)
|
||||
sumElts :: ProdCons (Traced r t)
|
||||
sumElts = ProdCons prodElt consElt
|
||||
trace = getTrace <$> sumElts
|
||||
elements = getTraced <$> sumElts
|
||||
in localTrace trace $ check key elements
|
||||
in check key sumElts
|
||||
|
||||
@ -7,6 +7,7 @@ import Control.Category
|
||||
import Data.HList
|
||||
import qualified Data.Yaml as Yaml
|
||||
import OpenAPI.Checker.Subtree
|
||||
import OpenAPI.Checker.Trace
|
||||
import OpenAPI.Checker.Validate.OpenApi ()
|
||||
import Spec.Golden.Extra
|
||||
import Test.Tasty (TestTree)
|
||||
@ -20,4 +21,4 @@ tests =
|
||||
"trace-tree.yaml"
|
||||
("a.yaml", "b.yaml")
|
||||
Yaml.decodeFileThrow
|
||||
(runCompatFormula (pure id) . checkCompatibility HNil . uncurry ProdCons)
|
||||
(runCompatFormula . checkCompatibility HNil . fmap (traced Root) . uncurry ProdCons)
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
Left:
|
||||
OpenApiPathsStep:
|
||||
MatchedPathStep "/test":
|
||||
PostStep:
|
||||
OperationMethodStep PostMethod:
|
||||
OperationRequestBodyStep:
|
||||
InlineStep:
|
||||
RequestMediaTypeObject application/json:
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
Left:
|
||||
OpenApiPathsStep:
|
||||
MatchedPathStep "/test":
|
||||
PostStep:
|
||||
OperationParamsStep:
|
||||
OperationMethodStep PostMethod:
|
||||
OperationParamsStep 0:
|
||||
InlineStep: ParamEmptinessIncompatible
|
||||
|
||||
@ -1,8 +1,8 @@
|
||||
Left:
|
||||
OpenApiPathsStep:
|
||||
MatchedPathStep "/test":
|
||||
PostStep:
|
||||
OperationParamsStep:
|
||||
OperationMethodStep PostMethod:
|
||||
OperationParamsStep 0:
|
||||
InlineStep:
|
||||
ParamSchema:
|
||||
InlineStep: NoContradiction
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
Left:
|
||||
OpenApiPathsStep:
|
||||
MatchedPathStep "/test":
|
||||
PostStep:
|
||||
OperationParamsStep:
|
||||
OperationMethodStep PostMethod:
|
||||
OperationParamsStep 0:
|
||||
InlineStep: ParamRequired
|
||||
|
||||
@ -1,4 +1,6 @@
|
||||
Left:
|
||||
OpenApiPathsStep:
|
||||
MatchedPathStep "/test":
|
||||
PostStep: ParamNotMatched ParamQuery "test2"
|
||||
OperationMethodStep PostMethod:
|
||||
OperationParamsStep 1:
|
||||
InlineStep: ParamNotMatched "test2"
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
Left:
|
||||
OpenApiPathsStep:
|
||||
MatchedPathStep "/test":
|
||||
PostStep:
|
||||
OperationMethodStep PostMethod:
|
||||
OperationRequestBodyStep:
|
||||
InlineStep:
|
||||
RequestMediaTypeObject application/json:
|
||||
|
||||
@ -1,6 +1,7 @@
|
||||
Left:
|
||||
OpenApiPathsStep:
|
||||
MatchedPathStep "/test":
|
||||
PostStep:
|
||||
OperationMethodStep PostMethod:
|
||||
OperationRequestBodyStep:
|
||||
InlineStep: RequestMediaTypeNotFound application/x-www-form-urlencoded
|
||||
InlineStep:
|
||||
RequestMediaTypeObject application/x-www-form-urlencoded: RequestMediaTypeNotFound
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
Left:
|
||||
OpenApiPathsStep:
|
||||
MatchedPathStep "/test":
|
||||
PostStep:
|
||||
OperationMethodStep PostMethod:
|
||||
OperationRequestBodyStep:
|
||||
InlineStep: RequestBodyRequired
|
||||
|
||||
@ -1,5 +1,7 @@
|
||||
Left:
|
||||
OpenApiPathsStep:
|
||||
MatchedPathStep "/test":
|
||||
PostStep:
|
||||
OperationResponsesStep: ResponseCodeNotFound 500
|
||||
OperationMethodStep PostMethod:
|
||||
OperationResponsesStep:
|
||||
ResponseCodeStep 500:
|
||||
InlineStep: ResponseCodeNotFound
|
||||
|
||||
@ -1,7 +1,9 @@
|
||||
Left:
|
||||
OpenApiPathsStep:
|
||||
MatchedPathStep "/test":
|
||||
PostStep:
|
||||
OperationMethodStep PostMethod:
|
||||
OperationResponsesStep:
|
||||
ResponseCodeStep 200:
|
||||
InlineStep: ResponseHeaderMissing "Test2"
|
||||
InlineStep:
|
||||
ResponseHeader "Test2":
|
||||
InlineStep: ResponseHeaderMissing
|
||||
|
||||
@ -1,7 +1,8 @@
|
||||
Left:
|
||||
OpenApiPathsStep:
|
||||
MatchedPathStep "/test":
|
||||
PostStep:
|
||||
OperationMethodStep PostMethod:
|
||||
OperationResponsesStep:
|
||||
ResponseCodeStep 200:
|
||||
InlineStep: ResponseMediaTypeMissing application/x-www-form-urlencoded
|
||||
InlineStep:
|
||||
ResponseMediaObject application/x-www-form-urlencoded: ResponseMediaTypeMissing
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
Left:
|
||||
OpenApiPathsStep:
|
||||
MatchedPathStep "/test":
|
||||
PostStep:
|
||||
OperationMethodStep PostMethod:
|
||||
OperationResponsesStep:
|
||||
ResponseCodeStep 200:
|
||||
InlineStep:
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
Left:
|
||||
OpenApiPathsStep:
|
||||
MatchedPathStep "/test":
|
||||
PostStep:
|
||||
OperationMethodStep PostMethod:
|
||||
OperationResponsesStep:
|
||||
ResponseCodeStep 200:
|
||||
InlineStep:
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
Left:
|
||||
OpenApiPathsStep:
|
||||
MatchedPathStep "/test":
|
||||
PostStep:
|
||||
OperationMethodStep PostMethod:
|
||||
OperationRequestBodyStep:
|
||||
InlineStep:
|
||||
RequestMediaTypeObject application/json:
|
||||
|
||||
Loading…
Reference in New Issue
Block a user