From 7df8b856239388b820762e859501262a3428a892 Mon Sep 17 00:00:00 2001 From: iko Date: Fri, 7 May 2021 17:54:54 +0300 Subject: [PATCH] Added server checking (#42) * Added server checking * Updated test * Made things work after rebase --- .hlint.yaml | 1 + src/OpenAPI/Checker/Subtree.hs | 20 ++- src/OpenAPI/Checker/Trace.hs | 7 +- src/OpenAPI/Checker/Validate/OpenApi.hs | 4 +- src/OpenAPI/Checker/Validate/Operation.hs | 29 ++-- .../Checker/Validate/ProcessedPathItem.hs | 2 + src/OpenAPI/Checker/Validate/Server.hs | 128 +++++++++++++++++- test/golden/common/servers/a.yaml | 38 ++++++ test/golden/common/servers/b.yaml | 34 +++++ test/golden/common/servers/trace-tree.yaml | 9 ++ 10 files changed, 253 insertions(+), 19 deletions(-) create mode 100644 .hlint.yaml create mode 100644 test/golden/common/servers/a.yaml create mode 100644 test/golden/common/servers/b.yaml create mode 100644 test/golden/common/servers/trace-tree.yaml diff --git a/.hlint.yaml b/.hlint.yaml new file mode 100644 index 0000000..a328774 --- /dev/null +++ b/.hlint.yaml @@ -0,0 +1 @@ +- ignore: { name: Redundant pure } diff --git a/src/OpenAPI/Checker/Subtree.hs b/src/OpenAPI/Checker/Subtree.hs index 5f3b8a3..afc1de4 100644 --- a/src/OpenAPI/Checker/Subtree.hs +++ b/src/OpenAPI/Checker/Subtree.hs @@ -5,6 +5,7 @@ module OpenAPI.Checker.Subtree , CompatFormula' , CompatFormula , ProdCons (..) + , anyOfSubtreeAt , HasUnsupportedFeature (..) , swapProdCons , SubtreeCheckIssue (..) @@ -13,6 +14,7 @@ module OpenAPI.Checker.Subtree , anyOfAt , issueAtTrace , issueAt + , tracedIssue , memo ) where @@ -64,6 +66,7 @@ newtype CompatM a = CompatM ) 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 @@ -144,6 +147,12 @@ issueAt -> CompatFormula' SubtreeCheckIssue r a issueAt x = issueAtTrace (ask x) +tracedIssue + :: (Subtree t, ComonadEnv (Trace r t) w) + => w (CheckIssue t) + -> CompatFormula' SubtreeCheckIssue r a +tracedIssue x = issueAtTrace (ask x) (extract x) + anyOfM :: Subtree t => Trace r t @@ -161,6 +170,15 @@ anyOfAt -> CompatFormula' SubtreeCheckIssue r a anyOfAt x = anyOfM (ask x) +anyOfSubtreeAt + :: (Subtree t, ComonadEnv (Trace r t) w) + => w x + -> CheckIssue t + -> [CompatFormula' SubtreeCheckIssue r a] + -> CompatFormula' SubtreeCheckIssue r a +anyOfSubtreeAt _ _ [x] = x +anyOfSubtreeAt f i fs = anyOfAt f i fs + fixpointKnot :: MonadState (MemoState VarRef) m => KnotTier (FormulaF f r ()) VarRef m @@ -175,5 +193,5 @@ memo :: (Typeable r, Subtree t) => (ProdCons (Traced r t) -> CompatFormula ()) -> (ProdCons (Traced r t) -> CompatFormula ()) -memo f pc = Compose $ do +memo f pc = Compose $ do memoWithKnot fixpointKnot (getCompose $ f pc) (ask <$> pc) diff --git a/src/OpenAPI/Checker/Trace.hs b/src/OpenAPI/Checker/Trace.hs index df3a74c..ea48355 100644 --- a/src/OpenAPI/Checker/Trace.hs +++ b/src/OpenAPI/Checker/Trace.hs @@ -10,6 +10,7 @@ module OpenAPI.Checker.Trace , AnItem (..) , step , Traced + , Traced' , traced -- * Reexports @@ -120,7 +121,9 @@ instance Typeable r => Ord (AnItem f r) where Root -> compare (someTypeRep xs) (someTypeRep ys) Snoc _ _ -> compare (someTypeRep xs) (someTypeRep ys) -type Traced r a = Env (Trace r a) a +type Traced r a = Traced' r a a -traced :: Trace r a -> a -> Traced r a +type Traced' r a b = Env (Trace r a) b + +traced :: Trace r a -> b -> Traced' r a b traced = env diff --git a/src/OpenAPI/Checker/Validate/OpenApi.hs b/src/OpenAPI/Checker/Validate/OpenApi.hs index b23c11b..1631919 100644 --- a/src/OpenAPI/Checker/Validate/OpenApi.hs +++ b/src/OpenAPI/Checker/Validate/OpenApi.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -fconstraint-solver-iterations=5 #-} -- Not compiles without +-- Does not compiles otherwise +{-# OPTIONS_GHC -fconstraint-solver-iterations=0 #-} module OpenAPI.Checker.Validate.OpenApi ( @@ -30,6 +31,7 @@ instance Subtree OpenApi where `HCons` (_componentsResponses <$> cs) `HCons` (_componentsHeaders <$> cs) `HCons` (_componentsSchemas <$> cs) + `HCons` (_openApiServers . extract <$> prodCons) `HCons` HNil) (tracedPaths <$> prodCons) diff --git a/src/OpenAPI/Checker/Validate/Operation.hs b/src/OpenAPI/Checker/Validate/Operation.hs index 8a2d867..b6bea98 100644 --- a/src/OpenAPI/Checker/Validate/Operation.hs +++ b/src/OpenAPI/Checker/Validate/Operation.hs @@ -25,6 +25,7 @@ import OpenAPI.Checker.Validate.PathFragment import OpenAPI.Checker.Validate.Products import OpenAPI.Checker.Validate.RequestBody import OpenAPI.Checker.Validate.Responses () +import OpenAPI.Checker.Validate.Server () data MatchedOperation = MatchedOperation { operation :: !Operation @@ -59,11 +60,16 @@ tracedSecurity oper = | (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 - ] +-- FIXME: https://github.com/typeable/openapi-diff/issues/28 +tracedServers + :: [Server] -- ^ Servers from env + -> Traced r MatchedOperation + -> Traced r [Server] +tracedServers env oper = + traced (ask oper >>> step OperationServersStep) $ + case _operationServers . operation $ extract oper of + [] -> env + ss -> ss instance Subtree MatchedOperation where type CheckEnv MatchedOperation = @@ -73,6 +79,7 @@ instance Subtree MatchedOperation where , ProdCons (Definitions Response) , ProdCons (Definitions Header) , ProdCons (Definitions Schema) + , ProdCons [Server] ] data CheckIssue MatchedOperation = OperationMissing OperationMethod @@ -165,9 +172,13 @@ instance Subtree MatchedOperation where $ HCons (swapProdCons schemaDefs) HNil resps = tracedResponses <$> prodCons checkCompatibility respEnv $ swapProdCons resps + -- FIXME: https://github.com/typeable/openapi-diff/issues/27 checkCallbacks = pure () -- (error "FIXME: not implemented") + -- FIXME: https://github.com/typeable/openapi-diff/issues/28 checkOperationSecurity = pure () -- (error "FIXME: not implemented") - checkServers = pure () -- (error "FIXME: not implemented") + checkServers = + checkCompatibility env $ + tracedServers <$> getH @(ProdCons [Server]) env <*> prodCons bodyDefs = getH @(ProdCons (Definitions RequestBody)) env respDefs = getH @(ProdCons (Definitions Response)) env headerDefs = getH @(ProdCons (Definitions Header)) env @@ -212,6 +223,8 @@ instance Steppable MatchedOperation SecurityRequirement where data Step MatchedOperation SecurityRequirement = OperationSecurityRequirementStep Int deriving (Eq, Ord, Show) -instance Steppable MatchedOperation Server where - data Step MatchedOperation Server = OperationServerStep Int +instance Steppable MatchedOperation [Server] where + data Step MatchedOperation [Server] + = OperationServersStep + | EnvServerStep deriving (Eq, Ord, Show) diff --git a/src/OpenAPI/Checker/Validate/ProcessedPathItem.hs b/src/OpenAPI/Checker/Validate/ProcessedPathItem.hs index 8a6a74c..a3b1abb 100644 --- a/src/OpenAPI/Checker/Validate/ProcessedPathItem.hs +++ b/src/OpenAPI/Checker/Validate/ProcessedPathItem.hs @@ -47,6 +47,7 @@ instance Subtree ProcessedPathItems where , ProdCons (Definitions Response) , ProdCons (Definitions Header) , ProdCons (Definitions Schema) + , ProdCons [Server] ] data CheckIssue ProcessedPathItems = NoPathsMatched FilePath @@ -132,6 +133,7 @@ instance Subtree MatchedPathItem where , ProdCons (Definitions Response) , ProdCons (Definitions Header) , ProdCons (Definitions Schema) + , ProdCons [Server] ] data CheckIssue MatchedPathItem deriving (Eq, Ord, Show) diff --git a/src/OpenAPI/Checker/Validate/Server.hs b/src/OpenAPI/Checker/Validate/Server.hs index c0da1fd..b8444fc 100644 --- a/src/OpenAPI/Checker/Validate/Server.hs +++ b/src/OpenAPI/Checker/Validate/Server.hs @@ -1,15 +1,129 @@ {-# OPTIONS_GHC -Wno-orphans #-} module OpenAPI.Checker.Validate.Server - ( CheckIssue(..) - ) where + ( CheckIssue (..) + ) +where +import Control.Applicative +import Control.Comonad +import Control.Monad +import Data.Attoparsec.Text +import Data.Either +import Data.Foldable +import Data.Function +import Data.Functor +import Data.HashMap.Strict.InsOrd as IOHM +import qualified Data.HashSet.InsOrd as IOHS +import Data.Maybe import Data.OpenApi +import Data.Text (Text) +import qualified Data.Text as T +import Data.Traversable import OpenAPI.Checker.Subtree +import OpenAPI.Checker.Trace +import Prelude as P -instance Subtree Server where - type CheckEnv Server = '[] - data CheckIssue Server - = ServerNotConsumed +tracedParsedServerUrlParts + :: Traced' r [Server] Server + -> Traced' r ProcessedServer (Either (CheckIssue ProcessedServer) ProcessedServer) +tracedParsedServerUrlParts s = + let rawURL = _serverUrl $ extract s + parsedUrl = parseServerUrl rawURL + serverVariables = _serverVariables $ extract s + in traced (ask s >>> step (ServerStep rawURL)) $ + parsedUrl + & (traverse . traverse) + (\var -> case IOHM.lookup var serverVariables of + Nothing -> Left VariableNotDefined + Just x -> Right x) + +instance Subtree [Server] where + type CheckEnv [Server] = '[] + data CheckIssue [Server] deriving (Eq, Ord, Show) - checkCompatibility = undefined + checkCompatibility env pcServer = do + let (ProdCons (pErrs, pUrls) (cErrs, cUrls)) = + pcServer <&> partitionEithers . fmap (bicosequence . tracedParsedServerUrlParts) . sequence + bicosequence :: Comonad f => f (Either a b) -> Either (f a) (f b) + bicosequence x = case extract x of + Left e -> Left $ x $> e + Right a -> Right $ x $> a + throwAllErrors = traverse_ tracedIssue + throwAllErrors pErrs + throwAllErrors cErrs + for_ pUrls $ \cUrl -> do + let potentiallyCompatible = P.filter ((staticCompatible `on` extract) cUrl) cUrls + anyOfSubtreeAt cUrl ServerNotMatched $ potentiallyCompatible <&> (checkCompatibility env . ProdCons cUrl) + pure () + +type ProcessedServer = [ServerUrlPart ServerVariable] + +-- | Nothing means "open variable" – can have any value +unifyPart :: ServerUrlPart ServerVariable -> Maybe (IOHS.InsOrdHashSet Text) +unifyPart (ServerUrlVariable v) = _serverVariableEnum v +unifyPart (ServerUrlConstant c) = Just $ IOHS.singleton c + +zipAll :: [a] -> [b] -> Maybe [(a, b)] +zipAll [] [] = Just [] +zipAll (x : xs) (y : ys) = ((x, y) :) <$> zipAll xs ys +zipAll (_ : _) [] = Nothing +zipAll [] (_ : _) = Nothing + +staticCompatiblePart :: ServerUrlPart x -> ServerUrlPart x -> Bool +staticCompatiblePart (ServerUrlConstant x) (ServerUrlConstant y) = x == y +staticCompatiblePart _ _ = True + +staticCompatible :: [ServerUrlPart x] -> [ServerUrlPart x] -> Bool +staticCompatible a b = maybe False (all $ uncurry staticCompatiblePart) $ zipAll a b + +data ServerUrlPart var + = ServerUrlVariable var + | ServerUrlConstant Text + deriving stock (Show, Functor, Foldable, Traversable) + +-- | This is super rough. Things like @{a|b}c@ will not match @ac@. +-- FIXME: https://github.com/typeable/openapi-diff/issues/46 +-- +-- NOTE: syntax is defined vaguely in the spec. +parseServerUrl :: Text -> [ServerUrlPart Text] +-- There really is no way it can fail +parseServerUrl = fromRight undefined . parseOnly (serverUrlParser <* endOfInput) + where + serverUrlParser :: Parser [ServerUrlPart Text] + serverUrlParser = many $ do + variableUrlParser <|> do + a <- anyChar + aa <- takeTill (== '{') + return (ServerUrlConstant $ T.cons a aa) + + variableUrlParser :: Parser (ServerUrlPart Text) + variableUrlParser = do + char '{' + res <- takeTill (== '}') + char '}' + return $ ServerUrlVariable res + +instance Steppable [Server] ProcessedServer where + data Step [Server] ProcessedServer = ServerStep Text + deriving (Eq, Ord, Show) + +instance Subtree ProcessedServer where + type CheckEnv ProcessedServer = '[] + data CheckIssue ProcessedServer + = VariableNotDefined + | ServerNotMatched + | EnumValueNotConsumed Int Text + | ConsumerNotOpen Int + deriving (Eq, Ord, Show) + checkCompatibility _ pc@(ProdCons p _) = + -- traversing here is fine because we have already filtered for length + for_ (zip [0 ..] $ zipProdCons . fmap (fmap unifyPart . extract) $ pc) $ \(i, pcPart) -> case pcPart of + (Just x, Just y) -> for_ x $ \v -> unless (v `IOHS.member` y) (issueAt p $ EnumValueNotConsumed i v) + -- Consumer can consume anything + (_, Nothing) -> pure () + -- Producer can produce anythings, but consumer has a finite enum ;( + (Nothing, Just _) -> issueAt p (ConsumerNotOpen i) + where + zipProdCons :: ProdCons [a] -> [(a, a)] + zipProdCons (ProdCons x y) = zip x y diff --git a/test/golden/common/servers/a.yaml b/test/golden/common/servers/a.yaml new file mode 100644 index 0000000..d3cc02a --- /dev/null +++ b/test/golden/common/servers/a.yaml @@ -0,0 +1,38 @@ +openapi: "3.0.0" +info: + version: 1.0.0 + title: Swagger Petstore +servers: + - url: http://petstore.swagger.io/v1 + variables: + variableThatDoesntDoAnything: + default: a + enum: + - a + - bbb + - url: http://missing.url + - url: http://{x}variable.path/{y}/{openVariable1}/{openVariable2} + variables: + x: + default: a + enum: + - a + - b + - c + y: + default: aa + enum: + - a + - aa + - aaa + openVariable1: + default: henlo + openVariable2: + default: henlo +paths: + /pets: + get: + responses: + "200": + description: A paged array of pets +components: {} diff --git a/test/golden/common/servers/b.yaml b/test/golden/common/servers/b.yaml new file mode 100644 index 0000000..a8ba043 --- /dev/null +++ b/test/golden/common/servers/b.yaml @@ -0,0 +1,34 @@ +openapi: "3.0.0" +info: + version: 1.0.0 + title: Swagger Petstore +servers: + - url: http://petstore.swagger.io/v1 + - url: http://{x}variable.path/{y}/{openVariable1}/{openVariable2} + variables: + x: + default: a + enum: + - b + - c + y: + default: aa + enum: + - a + - aa + - aaa + - bbb + openVariable1: + default: henlo + openVariable2: + default: henlo + enum: + - a + - aaa +paths: + /pets: + get: + responses: + "200": + description: A paged array of pets +components: {} diff --git a/test/golden/common/servers/trace-tree.yaml b/test/golden/common/servers/trace-tree.yaml new file mode 100644 index 0000000..27e50bf --- /dev/null +++ b/test/golden/common/servers/trace-tree.yaml @@ -0,0 +1,9 @@ +Left: + OpenApiPathsStep: + MatchedPathStep "/pets": + OperationMethodStep GetMethod: + OperationServersStep: + ServerStep "http://missing.url": ServerNotMatched + ServerStep "http://{x}variable.path/{y}/{openVariable1}/{openVariable2}": + - EnumValueNotConsumed 1 "a" + - ConsumerNotOpen 7