7df8b85 · compaREST · git.iko.soy

.hlint.yamlnew file+1

compare with master

unifiedsplit

@@ -0,0 +1 @@

1+- ignore: { name: Redundant pure }

src/OpenAPI/Checker/Subtree.hs+19−1

@@ -5,6 +5,7 @@ module OpenAPI.Checker.Subtree

5 , CompatFormula'

6 , CompatFormula

7 , ProdCons (..)

8+ , anyOfSubtreeAt

8 , HasUnsupportedFeature (..)

9 , HasUnsupportedFeature (..)

9 , swapProdCons

10 , swapProdCons

10 , SubtreeCheckIssue (..)

11 , SubtreeCheckIssue (..)

@@ -13,6 +14,7 @@ module OpenAPI.Checker.Subtree

13 , anyOfAt

14 , anyOfAt

14 , issueAtTrace

15 , issueAtTrace

15 , issueAt

16 , issueAt

17+ , tracedIssue

16 , memo

18 , memo

17 )

19 )

18where

20where

@@ -64,6 +66,7 @@ newtype CompatM a = CompatM

64 )

66 )

65

67

66type CompatFormula' f r = Compose CompatM (FormulaF f r)

68type CompatFormula' f r = Compose CompatM (FormulaF f r)

69+

67type CompatFormula = CompatFormula' SubtreeCheckIssue OpenApi

70type CompatFormula = CompatFormula' SubtreeCheckIssue OpenApi

68

71

69class (Typeable t, Ord (CheckIssue t), Show (CheckIssue t)) => Subtree (t :: Type) where

72class (Typeable t, Ord (CheckIssue t), Show (CheckIssue t)) => Subtree (t :: Type) where

@@ -144,6 +147,12 @@ issueAt

144 -> CompatFormula' SubtreeCheckIssue r a

147 -> CompatFormula' SubtreeCheckIssue r a

145issueAt x = issueAtTrace (ask x)

148issueAt x = issueAtTrace (ask x)

146

149

150+tracedIssue

151+ :: (Subtree t, ComonadEnv (Trace r t) w)

152+ => w (CheckIssue t)

153+ -> CompatFormula' SubtreeCheckIssue r a

154+tracedIssue x = issueAtTrace (ask x) (extract x)

155+

147anyOfM

156anyOfM

148 :: Subtree t

157 :: Subtree t

149 => Trace r t

158 => Trace r t

@@ -161,6 +170,15 @@ anyOfAt

161 -> CompatFormula' SubtreeCheckIssue r a

170 -> CompatFormula' SubtreeCheckIssue r a

162anyOfAt x = anyOfM (ask x)

171anyOfAt x = anyOfM (ask x)

163

172

173+anyOfSubtreeAt

174+ :: (Subtree t, ComonadEnv (Trace r t) w)

175+ => w x

176+ -> CheckIssue t

177+ -> [CompatFormula' SubtreeCheckIssue r a]

178+ -> CompatFormula' SubtreeCheckIssue r a

179+anyOfSubtreeAt _ _ [x] = x

180+anyOfSubtreeAt f i fs = anyOfAt f i fs

181+

164fixpointKnot

182fixpointKnot

165 :: MonadState (MemoState VarRef) m

183 :: MonadState (MemoState VarRef) m

166 => KnotTier (FormulaF f r ()) VarRef m

184 => KnotTier (FormulaF f r ()) VarRef m

@@ -175,5 +193,5 @@ memo

175 :: (Typeable r, Subtree t)

193 :: (Typeable r, Subtree t)

176 => (ProdCons (Traced r t) -> CompatFormula ())

194 => (ProdCons (Traced r t) -> CompatFormula ())

177 -> (ProdCons (Traced r t) -> CompatFormula ())

195 -> (ProdCons (Traced r t) -> CompatFormula ())

178−memo f pc = Compose $ do

196+memo f pc = Compose $ do

179 memoWithKnot fixpointKnot (getCompose $ f pc) (ask <$> pc)

197 memoWithKnot fixpointKnot (getCompose $ f pc) (ask <$> pc)

src/OpenAPI/Checker/Trace.hs+5−2

@@ -10,6 +10,7 @@ module OpenAPI.Checker.Trace

10 , AnItem (..)

11 , step

12 , Traced

13+ , Traced'

13 , traced

14 , traced

14

15

15 -- * Reexports

16 -- * Reexports

@@ -120,7 +121,9 @@ instance Typeable r => Ord (AnItem f r) where

120 Root -> compare (someTypeRep xs) (someTypeRep ys)

121 Root -> compare (someTypeRep xs) (someTypeRep ys)

121 Snoc _ _ -> compare (someTypeRep xs) (someTypeRep ys)

122 Snoc _ _ -> compare (someTypeRep xs) (someTypeRep ys)

122

123

123−type Traced r a = Env (Trace r a) a

124+type Traced r a = Traced' r a a

124

125

126+type Traced' r a b = Env (Trace r a) b

127+

125−traced :: Trace r a -> a -> Traced r a

128+traced :: Trace r a -> b -> Traced' r a b

126traced = env

129traced = env

src/OpenAPI/Checker/Validate/OpenApi.hs+3−1

@@ -1,5 +1,6 @@

1{-# OPTIONS_GHC -Wno-orphans #-}

2+-- Does not compiles otherwise

2−{-# OPTIONS_GHC -fconstraint-solver-iterations=5 #-} -- Not compiles without

3+{-# OPTIONS_GHC -fconstraint-solver-iterations=0 #-}

3

4

4module OpenAPI.Checker.Validate.OpenApi

5module OpenAPI.Checker.Validate.OpenApi

5 (

6 (

@@ -30,6 +31,7 @@ instance Subtree OpenApi where

30 `HCons` (_componentsResponses <$> cs)

31 `HCons` (_componentsResponses <$> cs)

31 `HCons` (_componentsHeaders <$> cs)

32 `HCons` (_componentsHeaders <$> cs)

32 `HCons` (_componentsSchemas <$> cs)

33 `HCons` (_componentsSchemas <$> cs)

34+ `HCons` (_openApiServers . extract <$> prodCons)

33 `HCons` HNil)

35 `HCons` HNil)

34 (tracedPaths <$> prodCons)

36 (tracedPaths <$> prodCons)

35

37

src/OpenAPI/Checker/Validate/Operation.hs+21−8

@@ -25,6 +25,7 @@ import OpenAPI.Checker.Validate.PathFragment

25import OpenAPI.Checker.Validate.Products

26import OpenAPI.Checker.Validate.RequestBody

27import OpenAPI.Checker.Validate.Responses ()

28+import OpenAPI.Checker.Validate.Server ()

28

29

29data MatchedOperation = MatchedOperation

30data MatchedOperation = MatchedOperation

30 { operation :: !Operation

31 { operation :: !Operation

@@ -59,11 +60,16 @@ tracedSecurity oper =

59 | (i, x) <- zip [0..] $ _operationSecurity . operation $ extract oper

60 | (i, x) <- zip [0..] $ _operationSecurity . operation $ extract oper

60 ]

61 ]

61

62

63+-- FIXME: https://github.com/typeable/openapi-diff/issues/28

64+tracedServers

65+ :: [Server] -- ^ Servers from env

62−tracedServers :: Traced r MatchedOperation -> [Traced r Server]

66+ -> Traced r MatchedOperation

67+ -> Traced r [Server]

63−tracedServers oper =

68+tracedServers env oper =

64− [ traced (ask oper >>> step (OperationServerStep i)) x

69+ traced (ask oper >>> step OperationServersStep) $

65− | (i, x) <- zip [0..] $ _operationServers . operation $ extract oper

70+ case _operationServers . operation $ extract oper of

66− ]

71+ [] -> env

72+ ss -> ss

67

73

68instance Subtree MatchedOperation where

74instance Subtree MatchedOperation where

69 type CheckEnv MatchedOperation =

75 type CheckEnv MatchedOperation =

@@ -73,6 +79,7 @@ instance Subtree MatchedOperation where

73 , ProdCons (Definitions Response)

79 , ProdCons (Definitions Response)

74 , ProdCons (Definitions Header)

80 , ProdCons (Definitions Header)

75 , ProdCons (Definitions Schema)

81 , ProdCons (Definitions Schema)

82+ , ProdCons [Server]

76 ]

83 ]

77 data CheckIssue MatchedOperation

84 data CheckIssue MatchedOperation

78 = OperationMissing OperationMethod

85 = OperationMissing OperationMethod

@@ -165,9 +172,13 @@ instance Subtree MatchedOperation where

165 $ HCons (swapProdCons schemaDefs) HNil

172 $ HCons (swapProdCons schemaDefs) HNil

166 resps = tracedResponses <$> prodCons

173 resps = tracedResponses <$> prodCons

167 checkCompatibility respEnv $ swapProdCons resps

174 checkCompatibility respEnv $ swapProdCons resps

175+ -- FIXME: https://github.com/typeable/openapi-diff/issues/27

168 checkCallbacks = pure () -- (error "FIXME: not implemented")

176 checkCallbacks = pure () -- (error "FIXME: not implemented")

177+ -- FIXME: https://github.com/typeable/openapi-diff/issues/28

169 checkOperationSecurity = pure () -- (error "FIXME: not implemented")

178 checkOperationSecurity = pure () -- (error "FIXME: not implemented")

170− checkServers = pure () -- (error "FIXME: not implemented")

179+ checkServers =

180+ checkCompatibility env $

181+ tracedServers <$> getH @(ProdCons [Server]) env <*> prodCons

171 bodyDefs = getH @(ProdCons (Definitions RequestBody)) env

182 bodyDefs = getH @(ProdCons (Definitions RequestBody)) env

172 respDefs = getH @(ProdCons (Definitions Response)) env

183 respDefs = getH @(ProdCons (Definitions Response)) env

173 headerDefs = getH @(ProdCons (Definitions Header)) env

184 headerDefs = getH @(ProdCons (Definitions Header)) env

@@ -212,6 +223,8 @@ instance Steppable MatchedOperation SecurityRequirement where

212 data Step MatchedOperation SecurityRequirement = OperationSecurityRequirementStep Int

223 data Step MatchedOperation SecurityRequirement = OperationSecurityRequirementStep Int

213 deriving (Eq, Ord, Show)

224 deriving (Eq, Ord, Show)

214

225

215−instance Steppable MatchedOperation Server where

226+instance Steppable MatchedOperation [Server] where

216− data Step MatchedOperation Server = OperationServerStep Int

227+ data Step MatchedOperation [Server]

228+ = OperationServersStep

229+ | EnvServerStep

217 deriving (Eq, Ord, Show)

230 deriving (Eq, Ord, Show)

src/OpenAPI/Checker/Validate/ProcessedPathItem.hs+2

@@ -47,6 +47,7 @@ instance Subtree ProcessedPathItems where

47 , ProdCons (Definitions Response)

48 , ProdCons (Definitions Header)

49 , ProdCons (Definitions Schema)

50+ , ProdCons [Server]

50 ]

51 ]

51 data CheckIssue ProcessedPathItems

52 data CheckIssue ProcessedPathItems

52 = NoPathsMatched FilePath

53 = NoPathsMatched FilePath

@@ -132,6 +133,7 @@ instance Subtree MatchedPathItem where

132 , ProdCons (Definitions Response)

133 , ProdCons (Definitions Response)

133 , ProdCons (Definitions Header)

134 , ProdCons (Definitions Header)

134 , ProdCons (Definitions Schema)

135 , ProdCons (Definitions Schema)

136+ , ProdCons [Server]

135 ]

137 ]

136 data CheckIssue MatchedPathItem

138 data CheckIssue MatchedPathItem

137 deriving (Eq, Ord, Show)

139 deriving (Eq, Ord, Show)

src/OpenAPI/Checker/Validate/Server.hs+121−7

@@ -1,15 +1,129 @@

1{-# OPTIONS_GHC -Wno-orphans #-}

2

3module OpenAPI.Checker.Validate.Server

4− ( CheckIssue(..)

4+ ( CheckIssue (..)

5+ )

5− ) where

6+where

6

7

8+import Control.Applicative

9+import Control.Comonad

10+import Control.Monad

11+import Data.Attoparsec.Text

12+import Data.Either

13+import Data.Foldable

14+import Data.Function

15+import Data.Functor

16+import Data.HashMap.Strict.InsOrd as IOHM

17+import qualified Data.HashSet.InsOrd as IOHS

18+import Data.Maybe

7import Data.OpenApi

19import Data.OpenApi

20+import Data.Text (Text)

21+import qualified Data.Text as T

22+import Data.Traversable

8import OpenAPI.Checker.Subtree

23import OpenAPI.Checker.Subtree

24+import OpenAPI.Checker.Trace

25+import Prelude as P

9

26

27+tracedParsedServerUrlParts

28+ :: Traced' r [Server] Server

29+ -> Traced' r ProcessedServer (Either (CheckIssue ProcessedServer) ProcessedServer)

30+tracedParsedServerUrlParts s =

31+ let rawURL = _serverUrl $ extract s

32+ parsedUrl = parseServerUrl rawURL

33+ serverVariables = _serverVariables $ extract s

34+ in traced (ask s >>> step (ServerStep rawURL)) $

35+ parsedUrl

36+ & (traverse . traverse)

37+ (\var -> case IOHM.lookup var serverVariables of

38+ Nothing -> Left VariableNotDefined

39+ Just x -> Right x)

40+

10−instance Subtree Server where

41+instance Subtree [Server] where

11− type CheckEnv Server = '[]

42+ type CheckEnv [Server] = '[]

12− data CheckIssue Server

43+ data CheckIssue [Server]

13− = ServerNotConsumed

44+ deriving (Eq, Ord, Show)

45+ checkCompatibility env pcServer = do

46+ let (ProdCons (pErrs, pUrls) (cErrs, cUrls)) =

47+ pcServer <&> partitionEithers . fmap (bicosequence . tracedParsedServerUrlParts) . sequence

48+ bicosequence :: Comonad f => f (Either a b) -> Either (f a) (f b)

49+ bicosequence x = case extract x of

50+ Left e -> Left $ x $> e

51+ Right a -> Right $ x $> a

52+ throwAllErrors = traverse_ tracedIssue

53+ throwAllErrors pErrs

54+ throwAllErrors cErrs

55+ for_ pUrls $ \cUrl -> do

56+ let potentiallyCompatible = P.filter ((staticCompatible `on` extract) cUrl) cUrls

57+ anyOfSubtreeAt cUrl ServerNotMatched $ potentiallyCompatible <&> (checkCompatibility env . ProdCons cUrl)

58+ pure ()

59+

60+type ProcessedServer = [ServerUrlPart ServerVariable]

61+

62+-- | Nothing means "open variable" – can have any value

63+unifyPart :: ServerUrlPart ServerVariable -> Maybe (IOHS.InsOrdHashSet Text)

64+unifyPart (ServerUrlVariable v) = _serverVariableEnum v

65+unifyPart (ServerUrlConstant c) = Just $ IOHS.singleton c

66+

67+zipAll :: [a] -> [b] -> Maybe [(a, b)]

68+zipAll [] [] = Just []

69+zipAll (x : xs) (y : ys) = ((x, y) :) <$> zipAll xs ys

70+zipAll (_ : _) [] = Nothing

71+zipAll [] (_ : _) = Nothing

72+

73+staticCompatiblePart :: ServerUrlPart x -> ServerUrlPart x -> Bool

74+staticCompatiblePart (ServerUrlConstant x) (ServerUrlConstant y) = x == y

75+staticCompatiblePart _ _ = True

76+

77+staticCompatible :: [ServerUrlPart x] -> [ServerUrlPart x] -> Bool

78+staticCompatible a b = maybe False (all $ uncurry staticCompatiblePart) $ zipAll a b

79+

80+data ServerUrlPart var

81+ = ServerUrlVariable var

82+ | ServerUrlConstant Text

83+ deriving stock (Show, Functor, Foldable, Traversable)

84+

85+-- | This is super rough. Things like @{a|b}c@ will not match @ac@.

86+-- FIXME: https://github.com/typeable/openapi-diff/issues/46

87+--

88+-- NOTE: syntax is defined vaguely in the spec.

89+parseServerUrl :: Text -> [ServerUrlPart Text]

90+-- There really is no way it can fail

91+parseServerUrl = fromRight undefined . parseOnly (serverUrlParser <* endOfInput)

92+ where

93+ serverUrlParser :: Parser [ServerUrlPart Text]

94+ serverUrlParser = many $ do

95+ variableUrlParser <|> do

96+ a <- anyChar

97+ aa <- takeTill (== '{')

98+ return (ServerUrlConstant $ T.cons a aa)

99+

100+ variableUrlParser :: Parser (ServerUrlPart Text)

101+ variableUrlParser = do

102+ char '{'

103+ res <- takeTill (== '}')

104+ char '}'

105+ return $ ServerUrlVariable res

106+

107+instance Steppable [Server] ProcessedServer where

108+ data Step [Server] ProcessedServer = ServerStep Text

109+ deriving (Eq, Ord, Show)

110+

111+instance Subtree ProcessedServer where

112+ type CheckEnv ProcessedServer = '[]

113+ data CheckIssue ProcessedServer

114+ = VariableNotDefined

115+ | ServerNotMatched

116+ | EnumValueNotConsumed Int Text

117+ | ConsumerNotOpen Int

14 deriving (Eq, Ord, Show)

118 deriving (Eq, Ord, Show)

15− checkCompatibility = undefined

119+ checkCompatibility _ pc@(ProdCons p _) =

120+ -- traversing here is fine because we have already filtered for length

121+ for_ (zip [0 ..] $ zipProdCons . fmap (fmap unifyPart . extract) $ pc) $ \(i, pcPart) -> case pcPart of

122+ (Just x, Just y) -> for_ x $ \v -> unless (v `IOHS.member` y) (issueAt p $ EnumValueNotConsumed i v)

123+ -- Consumer can consume anything

124+ (_, Nothing) -> pure ()

125+ -- Producer can produce anythings, but consumer has a finite enum ;(

126+ (Nothing, Just _) -> issueAt p (ConsumerNotOpen i)

127+ where

128+ zipProdCons :: ProdCons [a] -> [(a, a)]

129+ zipProdCons (ProdCons x y) = zip x y

test/golden/common/servers/a.yamlnew file+38

@@ -0,0 +1,38 @@

1+openapi: "3.0.0"

2+info:

3+ version: 1.0.0

4+ title: Swagger Petstore

5+servers:

6+ - url: http://petstore.swagger.io/v1

7+ variables:

8+ variableThatDoesntDoAnything:

9+ default: a

10+ enum:

11+ - a

12+ - bbb

13+ - url: http://missing.url

14+ - url: http://{x}variable.path/{y}/{openVariable1}/{openVariable2}

15+ variables:

16+ x:

17+ default: a

18+ enum:

19+ - a

20+ - b

21+ - c

22+ y:

23+ default: aa

24+ enum:

25+ - a

26+ - aa

27+ - aaa

28+ openVariable1:

29+ default: henlo

30+ openVariable2:

31+ default: henlo

32+paths:

33+ /pets:

34+ get:

35+ responses:

36+ "200":

37+ description: A paged array of pets

38+components: {}

test/golden/common/servers/b.yamlnew file+34

@@ -0,0 +1,34 @@

1+openapi: "3.0.0"

2+info:

3+ version: 1.0.0

4+ title: Swagger Petstore

5+servers:

6+ - url: http://petstore.swagger.io/v1

7+ - url: http://{x}variable.path/{y}/{openVariable1}/{openVariable2}

8+ variables:

9+ x:

10+ default: a

11+ enum:

12+ - b

13+ - c

14+ y:

15+ default: aa

16+ enum:

17+ - a

18+ - aa

19+ - aaa

20+ - bbb

21+ openVariable1:

22+ default: henlo

23+ openVariable2:

24+ default: henlo

25+ enum:

26+ - a

27+ - aaa

28+paths:

29+ /pets:

30+ get:

31+ responses:

32+ "200":

33+ description: A paged array of pets

34+components: {}

test/golden/common/servers/trace-tree.yamlnew file+9

@@ -0,0 +1,9 @@

1+Left:

2+ OpenApiPathsStep:

3+ MatchedPathStep "/pets":

4+ OperationMethodStep GetMethod:

5+ OperationServersStep:

6+ ServerStep "http://missing.url": ServerNotMatched

7+ ServerStep "http://{x}variable.path/{y}/{openVariable1}/{openVariable2}":

8+ - EnumValueNotConsumed 1 "a"

9+ - ConsumerNotOpen 7