28519f1 · compaREST · git.iko.soy

.github/workflows/haskell.yml+4−14

compare with master

unifiedsplit

@@ -29,23 +29,13 @@ jobs:

29 run: stack build --ghc-options="-O3 -j" --local-bin-path out --copy-bins --flag openapi-diff:Static

30 - name: Test

31 run: stack test --test-arguments='--hide-successes --no-create'

32− - name: Upload artifact

32+

33− uses: actions/upload-artifact@v2

34− with:

35− name: openapi-diff-linux

36− path: out/openapi-diff

37− release:

38− name: "Release"

39− if: github.ref == 'refs/heads/master'

40− runs-on: "ubuntu-latest"

41− needs: [linux-build]

42− steps:

43− - uses: actions/download-artifact@v2

44 - name: Zip

33 - name: Zip

34+ if: github.ref == 'refs/heads/master'

45 run: |

35 run: |

46− chmod +x openapi-diff-linux/openapi-diff

47− zip openapi-diff-linux openapi-diff-linux/openapi-diff

36+ zip openapi-diff-linux out/openapi-diff

48 - uses: "marvinpinto/action-automatic-releases@latest"

37 - uses: "marvinpinto/action-automatic-releases@latest"

38+ if: github.ref == 'refs/heads/master'

49 with:

39 with:

50 repo_token: "${{ secrets.GITHUB_TOKEN }}"

40 repo_token: "${{ secrets.GITHUB_TOKEN }}"

51 automatic_release_tag: "latest"

41 automatic_release_tag: "latest"

src/OpenAPI/Checker/Options.hs → app/OpenAPI/Checker/Options.hsrenamed

The content is the same.

openapi-diff.cabal+39−42

@@ -23,50 +23,21 @@ common common-options

23 cc-options: -static

24 ld-options: -static -pthread

25 ghc-options: -static

26− ghc-options: -Wall

26+ ghc-options:

27− -Wcompat

27+ -Weverything

28− -Widentities

28+ -Wno-implicit-prelude

29− -Wincomplete-uni-patterns

29+ -Wno-missing-safe-haskell-mode

30− -Wincomplete-record-updates

30+ -Wno-safe

31− if impl(ghc >= 8.0)

31+ -Wno-prepositive-qualified-module

32− ghc-options: -Wredundant-constraints

32+ -Wno-missing-import-lists

33− if impl(ghc >= 8.2)

34− ghc-options: -fhide-source-paths

35− if impl(ghc >= 8.4)

36− ghc-options: -Wmissing-export-lists

37− -Wpartial-fields

33+ -Wno-partial-fields

38−

34+ -Wno-all-missed-specialisations

35+ -Wno-missing-local-signatures

36+ -Wno-unsafe

39 default-language: Haskell2010

37 default-language: Haskell2010

40 build-depends: base >= 4.12.0.0 && < 4.15

38 build-depends: base >= 4.12.0.0 && < 4.15

41− , aeson

42− , attoparsec

43 , bytestring

39 , bytestring

44− , containers

45− , comonad

46− , deriving-aeson

47− , generic-data

48− , generic-monoid

49− , http-media

50− , insert-ordered-containers

51− , lattices

52− , lens

53− , mtl

54− , openapi3

55− , optparse-applicative

56− , pcre2

57− , scientific

58− , tagged

59 , text

40 , text

60− , transformers

61− , typerep-map

62− , unordered-containers

63− , vector

64− , yaml

65− , hashable

66− , pandoc-types

67− , open-union

68− , type-fun

69− , free

70

41

71 default-extensions: ApplicativeDo

42 default-extensions: ApplicativeDo

72 , BangPatterns

43 , BangPatterns

@@ -111,12 +82,33 @@ common common-options

111

82

112library

83library

113 import: common-options

84 import: common-options

85+ build-depends:

86+ , pcre2

87+ , open-union

88+ , vector

89+ , unordered-containers

90+ , type-fun

91+ , typerep-map

92+ , tagged

93+ , scientific

94+ , pandoc-types

95+ , openapi3

96+ , lattices

97+ , insert-ordered-containers

98+ , http-media

99+ , hashable

100+ , free

101+ , containers

102+ , comonad

103+ , attoparsec

104+ , transformers

105+ , mtl

106+ , aeson

114 hs-source-dirs: src

107 hs-source-dirs: src

115 exposed-modules: Data.HList

108 exposed-modules: Data.HList

116 , OpenAPI.Checker.Behavior

109 , OpenAPI.Checker.Behavior

117 , OpenAPI.Checker.Formula

110 , OpenAPI.Checker.Formula

118 , OpenAPI.Checker.Memo

111 , OpenAPI.Checker.Memo

119− , OpenAPI.Checker.Options

120 , OpenAPI.Checker.Orphans

112 , OpenAPI.Checker.Orphans

121 , OpenAPI.Checker.Paths

113 , OpenAPI.Checker.Paths

122 , OpenAPI.Checker.PathsPrefixTree

114 , OpenAPI.Checker.PathsPrefixTree

@@ -153,11 +145,15 @@ executable openapi-diff

153 , bytestring

145 , bytestring

154 , yaml

146 , yaml

155 , filepath

147 , filepath

148+ , optparse-applicative

149+ , mtl

150+ , aeson

156 ghc-options: -threaded

151 ghc-options: -threaded

157 -rtsopts

152 -rtsopts

158 -with-rtsopts=-N

153 -with-rtsopts=-N

159 other-modules:

154 other-modules:

160 FormatHeuristic

155 FormatHeuristic

156+ OpenAPI.Checker.Options

161

157

162test-suite openapi-diff-test

158test-suite openapi-diff-test

163 import: common-options

159 import: common-options

@@ -172,12 +168,13 @@ test-suite openapi-diff-test

172 , tasty-golden

168 , tasty-golden

173 , tasty

169 , tasty

174 , bytestring

170 , bytestring

175− , aeson

176 , yaml

171 , yaml

177 , directory

172 , directory

178 , filepath

173 , filepath

179 , pandoc

174 , pandoc

180 , data-default

175 , data-default

176+ , lens

177+ , openapi3

181 ghc-options: -threaded

178 ghc-options: -threaded

182 -rtsopts

179 -rtsopts

183 -with-rtsopts=-N

180 -with-rtsopts=-N

src/OpenAPI/Checker/Paths.hs+3−6

@@ -7,7 +7,6 @@ module OpenAPI.Checker.Paths

7 , Paths (..)

8 , DiffPaths (..)

9 , catDiffPaths

10− , _DiffPaths

11 , AnItem (..)

10 , AnItem (..)

12 , step

11 , step

13

12

@@ -18,8 +17,6 @@ module OpenAPI.Checker.Paths

18where

17where

19

18

20import Control.Category

19import Control.Category

21−import Control.Comonad.Env

22−import Control.Lens

23import Data.Kind

20import Data.Kind

24import Data.Type.Equality

21import Data.Type.Equality

25import Type.Reflection

22import Type.Reflection

@@ -87,9 +84,9 @@ newtype DiffPaths (q :: k -> k -> Type) (a :: k) (b :: k)

87catDiffPaths :: DiffPaths q a b -> DiffPaths q b c -> DiffPaths q a c

84catDiffPaths :: DiffPaths q a b -> DiffPaths q b c -> DiffPaths q a c

88catDiffPaths (DiffPaths f) (DiffPaths g) = DiffPaths (g . f)

85catDiffPaths (DiffPaths f) (DiffPaths g) = DiffPaths (g . f)

89

86

90−_DiffPaths :: Iso (DiffPaths q a b) (DiffPaths q c d) (Paths q a b) (Paths q c d)

87+-- _DiffPaths :: Iso (DiffPaths q a b) (DiffPaths q c d) (Paths q a b) (Paths q c d)

91−_DiffPaths = dimap (\(DiffPaths f) -> f Root) $

88+-- _DiffPaths = dimap (\(DiffPaths f) -> f Root) $

92− fmap $ \xs -> DiffPaths (>>> xs)

89+-- fmap $ \xs -> DiffPaths (>>> xs)

93

90

94-- | An item related to some path relative to the root @r@.

91-- | An item related to some path relative to the root @r@.

95data AnItem (q :: k -> k -> Type) (f :: k -> Type) (r :: k) where

92data AnItem (q :: k -> k -> Type) (f :: k -> Type) (r :: k) where

src/OpenAPI/Checker/PathsPrefixTree.hs+5−5

@@ -51,7 +51,7 @@ instance (forall a. ToJSON (f a)) => ToJSON (PathsPrefixTree q f r) where

51 Object . getMergableObject

52 . foldWith (\t x -> MergableObject . traceObject t $ toJSON x)

53

54−deriving instance Eq (PathsPrefixTree q f a)

54+deriving stock instance Eq (PathsPrefixTree q f a)

55

56-- Kind of orphan. Treat the map as an infinite tuple of @Maybe (f a)@'s, where

57-- the components are ordered by the @SomeTypeRep@ of the @a@.

@@ -104,9 +104,9 @@ instance Semigroup (ASet a) where

104 s <> AnEmptySet = s

105 ASet s1 <> ASet s2 = ASet $ S.union s1 s2

106

107−deriving instance Eq (ASet a)

107+deriving stock instance Eq (ASet a)

108

109−deriving instance Ord (ASet a)

109+deriving stock instance Ord (ASet a)

110

111-- type traceprefixset = traceprefixtree proxy

112

@@ -119,9 +119,9 @@ data AStep (q :: k -> k -> Type) (f :: k -> Type) (r :: k) (a :: k) where

119 !(M.Map (q r a) (PathsPrefixTree q f a))

120 -> AStep q f r a

121

122−deriving instance Eq (AStep q f r a)

122+deriving stock instance Eq (AStep q f r a)

123

124−deriving instance Ord (AStep q f r a)

124+deriving stock instance Ord (AStep q f r a)

125

126singleton :: AnItem q f r -> PathsPrefixTree q f r

127singleton (AnItem ys v) = go ys $ PathsPrefixTree (ASet $ S.singleton v) TRM.empty

src/OpenAPI/Checker/Subtree.hs+4−4

@@ -80,7 +80,7 @@ instance Steppable TraceRoot OpenApi where

80

81type Trace = Paths Step TraceRoot

82

83−type instance AdditionalQuiverConstraints Step a b = ()

83+type instance AdditionalQuiverConstraints Step _ _ = ()

84

85type Traced' a b = Env (Trace a) b

86

@@ -104,7 +104,7 @@ data ProdCons a = ProdCons

104 { producer :: a

105 , consumer :: a

106 }

107− deriving (Eq, Ord, Show, Functor, Foldable, Traversable)

107+ deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable)

108

109swapProdCons :: ProdCons a -> ProdCons a

110swapProdCons (ProdCons a b) = ProdCons b a

@@ -134,7 +134,7 @@ data VoidQuiver a b

134

135deriving stock instance Eq (VoidQuiver a b)

136

137−type instance AdditionalQuiverConstraints VoidQuiver a b = ()

137+type instance AdditionalQuiverConstraints VoidQuiver _ _ = ()

138

139deriving stock instance Ord (VoidQuiver a b)

140

@@ -219,7 +219,7 @@ iohmStructural e =

219

220instance (Typeable k, Typeable v, Ord k, Show k) => Steppable (IOHM.InsOrdHashMap k v) v where

221 data Step (IOHM.InsOrdHashMap k v) v = InsOrdHashMapKeyStep k

222− deriving (Eq, Ord, Show)

222+ deriving stock (Eq, Ord, Show)

223

224iohmStructuralWith

225 :: (Ord k, Hashable k, Typeable k, Typeable v, Show k)

src/OpenAPI/Checker/Validate/Link.hs+1−1

@@ -16,7 +16,7 @@ instance Subtree Link where

16instance Issuable 'LinkLevel where

17 data Issue 'LinkLevel

18 = LinksUnsupported

19− deriving (Eq, Ord, Show)

19+ deriving stock (Eq, Ord, Show)

20 issueIsUnsupported = \case

21 LinksUnsupported -> True

22 describeIssue LinksUnsupported = para "OpenApi Diff does not currently support Link Objects."

src/OpenAPI/Checker/Validate/MediaTypeObject.hs+7−7

@@ -6,8 +6,8 @@ module OpenAPI.Checker.Validate.MediaTypeObject

6 )

7where

8

9−import Control.Lens hiding (para)

10import Data.Foldable as F

9import Data.Foldable as F

10+import Data.Functor

11import Data.HList

12import Data.HashMap.Strict.InsOrd as IOHM

13import Data.Map.Strict as M

@@ -37,7 +37,7 @@ instance Issuable 'PayloadLevel where

37 = MediaTypeSchemaRequired

38 | MediaEncodingMissing Text

39 | EncodingNotSupported

40− deriving (Eq, Ord, Show)

40+ deriving stock (Eq, Ord, Show)

41 issueIsUnsupported = \case

42 EncodingNotSupported -> True

43 _ -> False

@@ -49,7 +49,7 @@ instance Issuable 'PayloadLevel where

49instance Behavable 'PayloadLevel 'SchemaLevel where

50 data Behave 'PayloadLevel 'SchemaLevel

51 = PayloadSchema

52− deriving (Eq, Ord, Show)

52+ deriving stock (Eq, Ord, Show)

53 describeBehaviour PayloadSchema = "JSON Schema"

54

55instance Subtree MediaTypeObject where

@@ -124,19 +124,19 @@ instance Subtree Encoding where

124

125instance Steppable MediaTypeObject (Referenced Schema) where

126 data Step MediaTypeObject (Referenced Schema) = MediaTypeSchema

127− deriving (Eq, Ord, Show)

127+ deriving stock (Eq, Ord, Show)

128

129instance Steppable MediaTypeObject (Definitions Encoding) where

130 data Step MediaTypeObject (Definitions Encoding) = MediaTypeEncodingMapping

131− deriving (Eq, Ord, Show)

131+ deriving stock (Eq, Ord, Show)

132

133instance Steppable MediaTypeObject Encoding where

134 data Step MediaTypeObject Encoding = MediaTypeParamEncoding Text

135− deriving (Eq, Ord, Show)

135+ deriving stock (Eq, Ord, Show)

136

137instance Steppable Encoding (Definitions (Referenced Header)) where

138 data Step Encoding (Definitions (Referenced Header)) = EncodingHeaderStep

139− deriving (Eq, Ord, Show)

139+ deriving stock (Eq, Ord, Show)

140

141instance Behavable 'OperationLevel 'ResponseLevel where

142 data Behave 'OperationLevel 'ResponseLevel

src/OpenAPI/Checker/Validate/OAuth2Flows.hs+2−2

@@ -52,7 +52,7 @@ instance Subtree OAuth2Flows where

52

53instance Typeable t => Steppable OAuth2Flows (OAuth2Flow t) where

54 data Step OAuth2Flows (OAuth2Flow t) = OAuth2FlowsFlow (Proxy t)

55− deriving (Eq, Ord, Show)

55+ deriving stock (Eq, Ord, Show)

56

57instance (Typeable t, Subtree t, SubtreeLevel (OAuth2Flow t) ~ SubtreeLevel t) => Subtree (OAuth2Flow t) where

58 type CheckEnv (OAuth2Flow t) = CheckEnv t

@@ -68,7 +68,7 @@ instance (Typeable t, Subtree t, SubtreeLevel (OAuth2Flow t) ~ SubtreeLevel t) =

68

69instance Typeable t => Steppable (OAuth2Flow t) t where

70 data Step (OAuth2Flow t) t = OAuth2FlowParamsStep (Proxy t)

71− deriving (Eq, Ord, Show)

71+ deriving stock (Eq, Ord, Show)

72

73instance Subtree OAuth2ImplicitFlow where

74 type SubtreeLevel OAuth2ImplicitFlow = 'SecuritySchemeLevel

src/OpenAPI/Checker/Validate/OpenApi.hs+9−9

@@ -92,36 +92,36 @@ instance Subtree OpenApi where

92

93instance Steppable OpenApi ProcessedPathItems where

94 data Step OpenApi ProcessedPathItems = OpenApiPathsStep

95− deriving (Eq, Ord, Show)

95+ deriving stock (Eq, Ord, Show)

96

97instance Steppable OpenApi (Definitions RequestBody) where

98 data Step OpenApi (Definitions RequestBody) = ComponentsRequestBody

99− deriving (Eq, Ord, Show)

99+ deriving stock (Eq, Ord, Show)

100

101instance Steppable OpenApi (Definitions Param) where

102 data Step OpenApi (Definitions Param) = ComponentsParam

103− deriving (Eq, Ord, Show)

103+ deriving stock (Eq, Ord, Show)

104

105instance Steppable OpenApi (Definitions SecurityScheme) where

106 data Step OpenApi (Definitions SecurityScheme) = ComponentsSecurityScheme

107− deriving (Eq, Ord, Show)

107+ deriving stock (Eq, Ord, Show)

108

109instance Steppable OpenApi (Definitions Response) where

110 data Step OpenApi (Definitions Response) = ComponentsResponse

111− deriving (Eq, Ord, Show)

111+ deriving stock (Eq, Ord, Show)

112

113instance Steppable OpenApi (Definitions Header) where

114 data Step OpenApi (Definitions Header) = ComponentsHeader

115− deriving (Eq, Ord, Show)

115+ deriving stock (Eq, Ord, Show)

116

117instance Steppable OpenApi (Definitions Schema) where

118 data Step OpenApi (Definitions Schema) = ComponentsSchema

119− deriving (Eq, Ord, Show)

119+ deriving stock (Eq, Ord, Show)

120

121instance Steppable OpenApi (Definitions Link) where

122 data Step OpenApi (Definitions Link) = ComponentsLink

123− deriving (Eq, Ord, Show)

123+ deriving stock (Eq, Ord, Show)

124

125instance Steppable OpenApi (Definitions Callback) where

126 data Step OpenApi (Definitions Callback) = ComponentsCallbacks

127− deriving (Eq, Ord, Show)

127+ deriving stock (Eq, Ord, Show)

src/OpenAPI/Checker/Validate/Operation.hs+9−9

@@ -297,7 +297,7 @@ data OperationMethod

297 | HeadMethod

298 | PatchMethod

299 | TraceMethod

300− deriving (Eq, Ord, Show)

300+ deriving stock (Eq, Ord, Show)

301

302pathItemMethod :: OperationMethod -> PathItem -> Maybe Operation

303pathItemMethod = \case

@@ -334,7 +334,7 @@ instance Steppable MatchedOperation [Server] where

334 data Step MatchedOperation [Server]

335 = OperationServersStep

336 | EnvServerStep

337− deriving (Eq, Ord, Show)

337+ deriving stock (Eq, Ord, Show)

338

339-- * ProcessedPathItems

340

@@ -466,7 +466,7 @@ instance Issuable 'PathLevel where

466instance Behavable 'PathLevel 'OperationLevel where

467 data Behave 'PathLevel 'OperationLevel

468 = InOperation OperationMethod

469− deriving (Eq, Ord, Show)

469+ deriving stock (Eq, Ord, Show)

470

471 describeBehaviour (InOperation method) = showMethod method

472

@@ -538,19 +538,19 @@ instance Subtree MatchedPathItem where

538

539instance Steppable ProcessedPathItems MatchedPathItem where

540 data Step ProcessedPathItems MatchedPathItem = MatchedPathStep FilePath

541− deriving (Eq, Ord, Show)

541+ deriving stock (Eq, Ord, Show)

542

543instance Steppable MatchedPathItem MatchedOperation where

544 data Step MatchedPathItem MatchedOperation = OperationMethodStep OperationMethod

545− deriving (Eq, Ord, Show)

545+ deriving stock (Eq, Ord, Show)

546

547instance Steppable MatchedPathItem (Referenced Param) where

548 data Step MatchedPathItem (Referenced Param) = PathItemParam Int

549− deriving (Eq, Ord, Show)

549+ deriving stock (Eq, Ord, Show)

550

551instance Steppable MatchedPathItem PathFragmentParam where

552 data Step MatchedPathItem PathFragmentParam = PathFragmentStep Int

553− deriving (Eq, Ord, Show)

553+ deriving stock (Eq, Ord, Show)

554

555-- * Callbacks

556

@@ -575,7 +575,7 @@ instance Subtree Callback where

575instance Issuable 'CallbackLevel where

576 data Issue 'CallbackLevel

577 = CallbacksUnsupported

578− deriving (Eq, Ord, Show)

578+ deriving stock (Eq, Ord, Show)

579 issueIsUnsupported = \case

580 CallbacksUnsupported -> True

581 describeIssue CallbacksUnsupported = para "OpenApi Diff does not currently support callbacks."

@@ -586,7 +586,7 @@ tracedCallbackPathItems (Traced t (Callback x)) =

586

587instance Steppable Callback ProcessedPathItems where

588 data Step Callback ProcessedPathItems = CallbackPathsStep

589− deriving (Eq, Ord, Show)

589+ deriving stock (Eq, Ord, Show)

590

591instance Behavable 'OperationLevel 'CallbackLevel where

592 data Behave 'OperationLevel 'CallbackLevel = OperationCallback Text

src/OpenAPI/Checker/Validate/Param.hs+38−30

@@ -4,10 +4,11 @@

4module OpenAPI.Checker.Validate.Param

5 ( Behave (..)

6 , Issue (..)

7+ )

7− ) where

8+where

8

9

9−import Control.Lens hiding (para)

10import Control.Monad

11+import Data.Functor

11import Data.Maybe

12import Data.Maybe

12import Data.OpenApi

13import Data.OpenApi

13import Data.Text as T

14import Data.Text as T

@@ -22,13 +23,18 @@ import Text.Pandoc.Builder

22data EncodingStyle = EncodingStyle

23data EncodingStyle = EncodingStyle

23 { style :: Style

24 { style :: Style

24 , explode :: Bool

25 , explode :: Bool

25− , allowReserved :: Maybe Bool

26− -- ^ Nothing when @in@ parameter is not @query@

26+ , -- | Nothing when @in@ parameter is not @query@

27+ allowReserved :: Maybe Bool

28+ }

27− } deriving (Eq, Ord, Show)

29+ deriving stock (Eq, Ord, Show)

28

30

29paramEncoding :: Param -> EncodingStyle

31paramEncoding :: Param -> EncodingStyle

30−paramEncoding p = EncodingStyle

32+paramEncoding p =

33+ EncodingStyle

34+ { style

35+ , explode

31− { style, explode, allowReserved }

36+ , allowReserved

37+ }

32 where

38 where

33 style = fromMaybe defaultStyle $ _paramStyle p

39 style = fromMaybe defaultStyle $ _paramStyle p

34 defaultStyle = case _paramIn p of

40 defaultStyle = case _paramIn p of

@@ -49,19 +55,19 @@ tracedSchema par = _paramSchema (extract par) <&> traced (ask par >>> step Param

49

55

50instance Issuable 'PathFragmentLevel where

56instance Issuable 'PathFragmentLevel where

51 data Issue 'PathFragmentLevel

57 data Issue 'PathFragmentLevel

52− = ParamNameMismatch

53− -- ^ Params have different names

58+ = -- | Params have different names

54− | ParamEmptinessIncompatible

59+ ParamNameMismatch

55− -- ^ Consumer requires non-empty param, but producer gives emptyable

60+ | -- | Consumer requires non-empty param, but producer gives emptyable

56− | ParamRequired

61+ ParamEmptinessIncompatible

57− -- ^ Consumer requires mandatory parm, but producer optional

62+ | -- | Consumer requires mandatory parm, but producer optional

63+ ParamRequired

58 | ParamPlaceIncompatible

64 | ParamPlaceIncompatible

59− | ParamStyleMismatch

60− -- ^ Params encoded in different styles

65+ | -- | Params encoded in different styles

61− | ParamSchemaMismatch

66+ ParamStyleMismatch

62− -- ^ One of schemas not presented

67+ | -- | One of schemas not presented

68+ ParamSchemaMismatch

63 | PathFragmentsDontMatch Text Text

69 | PathFragmentsDontMatch Text Text

64− deriving (Eq, Ord, Show)

70+ deriving stock (Eq, Ord, Show)

65 issueIsUnsupported _ = False

71 issueIsUnsupported _ = False

66 describeIssue ParamNameMismatch = para "The path fragments don't match."

72 describeIssue ParamNameMismatch = para "The path fragments don't match."

67 describeIssue ParamEmptinessIncompatible = para "Expected that an empty parameter is allowed, but it isn't."

73 describeIssue ParamEmptinessIncompatible = para "Expected that an empty parameter is allowed, but it isn't."

@@ -74,8 +80,8 @@ instance Issuable 'PathFragmentLevel where

74instance Behavable 'PathFragmentLevel 'SchemaLevel where

80instance Behavable 'PathFragmentLevel 'SchemaLevel where

75 data Behave 'PathFragmentLevel 'SchemaLevel

81 data Behave 'PathFragmentLevel 'SchemaLevel

76 = InParamSchema

82 = InParamSchema

77− deriving (Eq, Ord, Show)

83+ deriving stock (Eq, Ord, Show)

78−

84+

79 describeBehaviour InParamSchema = "JSON Schema"

85 describeBehaviour InParamSchema = "JSON Schema"

80

86

81instance Subtree Param where

87instance Subtree Param where

@@ -92,30 +98,32 @@ instance Subtree Param where

92 structuralEq $ fmap _paramExplode <$> pc

98 structuralEq $ fmap _paramExplode <$> pc

93 pure ()

99 pure ()

94 checkSemanticCompatibility env beh pc@(ProdCons p c) = do

100 checkSemanticCompatibility env beh pc@(ProdCons p c) = do

95− when (_paramName (extract p) /= _paramName (extract c))

101+ when (_paramName (extract p) /= _paramName (extract c)) $

96− $ issueAt beh ParamNameMismatch

102+ issueAt beh ParamNameMismatch

103+ when

97− when ((fromMaybe False . _paramRequired . extract $ c) &&

104+ ((fromMaybe False . _paramRequired . extract $ c)

98− not (fromMaybe False . _paramRequired . extract $ p))

105+ && not (fromMaybe False . _paramRequired . extract $ p))

99 $ issueAt beh ParamRequired

106 $ issueAt beh ParamRequired

100 case (_paramIn . extract $ p, _paramIn . extract $ c) of

107 case (_paramIn . extract $ p, _paramIn . extract $ c) of

101 (ParamQuery, ParamQuery) -> do

108 (ParamQuery, ParamQuery) -> do

102 -- Emptiness is only for query params

109 -- Emptiness is only for query params

110+ when

103− when ((fromMaybe False . _paramAllowEmptyValue . extract $ p)

111+ ((fromMaybe False . _paramAllowEmptyValue . extract $ p)

104− && not (fromMaybe False . _paramAllowEmptyValue . extract $ c))

112+ && not (fromMaybe False . _paramAllowEmptyValue . extract $ c))

105 $ issueAt beh ParamEmptinessIncompatible

113 $ issueAt beh ParamEmptinessIncompatible

106 (a, b) | a == b -> pure ()

114 (a, b) | a == b -> pure ()

107 _ -> issueAt beh ParamPlaceIncompatible

115 _ -> issueAt beh ParamPlaceIncompatible

108− unless (paramEncoding (extract p) == paramEncoding (extract c))

116+ unless (paramEncoding (extract p) == paramEncoding (extract c)) $

109− $ issueAt beh ParamStyleMismatch

117+ issueAt beh ParamStyleMismatch

110 case tracedSchema <$> pc of

118 case tracedSchema <$> pc of

111 ProdCons (Just prodSchema) (Just consSchema) -> do

119 ProdCons (Just prodSchema) (Just consSchema) -> do

112 checkCompatibility env (beh >>> step InParamSchema) $ ProdCons prodSchema consSchema

120 checkCompatibility env (beh >>> step InParamSchema) $ ProdCons prodSchema consSchema

113 ProdCons Nothing Nothing -> pure ()

121 ProdCons Nothing Nothing -> pure ()

114 ProdCons Nothing (Just _consSchema) -> issueAt beh ParamSchemaMismatch

122 ProdCons Nothing (Just _consSchema) -> issueAt beh ParamSchemaMismatch

115 ProdCons (Just _prodSchema) Nothing -> pure ()

123 ProdCons (Just _prodSchema) Nothing -> pure ()

116− -- If consumer doesn't care then why we should?

124+ -- If consumer doesn't care then why we should?

117 pure ()

125 pure ()

118

126

119instance Steppable Param (Referenced Schema) where

127instance Steppable Param (Referenced Schema) where

120 data Step Param (Referenced Schema) = ParamSchema

128 data Step Param (Referenced Schema) = ParamSchema

121− deriving (Eq, Ord, Show)

129+ deriving stock (Eq, Ord, Show)

src/OpenAPI/Checker/Validate/PathFragment.hs+18−13

@@ -38,17 +38,19 @@ type PathFragmentParam = PathFragment (Traced Param)

38

39instance (Typeable param) => Steppable (PathFragment param) Param where

40 data Step (PathFragment param) Param = StaticPathParam Text

41− deriving (Eq, Ord, Show)

41+ deriving stock (Eq, Ord, Show)

42

43tracedPathFragmentParam :: Traced PathFragmentParam -> Traced Param

44tracedPathFragmentParam pfp = case extract pfp of

45+ StaticPath s ->

45− StaticPath s -> traced (ask pfp >>> step (StaticPathParam s))

46+ traced (ask pfp >>> step (StaticPathParam s)) $

46− $ mempty

47+ mempty

47− { _paramRequired = Just True

48+ { _paramRequired = Just True

48− , _paramIn = ParamPath

49+ , _paramIn = ParamPath

49− , _paramAllowEmptyValue = Just False

50+ , _paramAllowEmptyValue = Just False

50− , _paramAllowReserved = Just False

51+ , _paramAllowReserved = Just False

51− , _paramSchema = Just $ Inline $ staticStringSchema s }

52+ , _paramSchema = Just $ Inline $ staticStringSchema s

53+ }

52 DynamicPath p -> p

54 DynamicPath p -> p

53

55

54staticStringSchema :: Text -> Schema

56staticStringSchema :: Text -> Schema

@@ -61,13 +63,16 @@ staticStringSchema t =

61

63

62instance Subtree PathFragmentParam where

64instance Subtree PathFragmentParam where

63 type SubtreeLevel PathFragmentParam = 'PathFragmentLevel

65 type SubtreeLevel PathFragmentParam = 'PathFragmentLevel

66+ type

64− type CheckEnv PathFragmentParam =

67+ CheckEnv PathFragmentParam =

65− '[ ProdCons (Traced (Definitions Schema)) ]

68+ '[ProdCons (Traced (Definitions Schema))]

69+

66 -- Not much to compare at this level

70 -- Not much to compare at this level

67− checkStructuralCompatibility _ _ = structuralIssue

71+ checkStructuralCompatibility _ _ = structuralIssue

72+

68 -- This case isn't strictly needed. It is here for optimization.

73 -- This case isn't strictly needed. It is here for optimization.

69− checkSemanticCompatibility _ beh (ProdCons (extract -> StaticPath x) (extract -> StaticPath y))

74+ checkSemanticCompatibility _ beh (ProdCons (extract -> StaticPath x) (extract -> StaticPath y)) =

70− = if x == y

75+ if x == y

71 then pure ()

76 then pure ()

72 else issueAt beh (PathFragmentsDontMatch x y)

77 else issueAt beh (PathFragmentsDontMatch x y)

73 checkSemanticCompatibility env beh prodCons = do

78 checkSemanticCompatibility env beh prodCons = do

src/OpenAPI/Checker/Validate/RequestBody.hs+2−2

@@ -67,8 +67,8 @@ instance Subtree RequestBody where

67

68instance Steppable RequestBody MediaTypeObject where

69 data Step RequestBody MediaTypeObject = RequestMediaTypeObject MediaType

70− deriving (Eq, Ord, Show)

70+ deriving stock (Eq, Ord, Show)

71

72instance Steppable RequestBody (IOHM.InsOrdHashMap MediaType MediaTypeObject) where

73 data Step RequestBody (IOHM.InsOrdHashMap MediaType MediaTypeObject) = RequestMediaTypeObjectMapping

74− deriving (Eq, Ord, Show)

74+ deriving stock (Eq, Ord, Show)

src/OpenAPI/Checker/Validate/Schema.hs+7−6

@@ -19,7 +19,6 @@ import Algebra.Lattice

19import Control.Applicative

20import Control.Arrow

21import Control.Comonad.Env hiding (env)

22−import Control.Lens hiding (cons, para)

23import Control.Monad.Reader hiding (ask)

22import Control.Monad.Reader hiding (ask)

24import qualified Control.Monad.Reader as R

23import qualified Control.Monad.Reader as R

25import Control.Monad.State

24import Control.Monad.State

@@ -28,6 +27,8 @@ import qualified Data.Aeson as A

28import qualified Data.ByteString.Lazy as BSL

27import qualified Data.ByteString.Lazy as BSL

29import Data.Coerce

28import Data.Coerce

30import qualified Data.Foldable as F

29import qualified Data.Foldable as F

30+import Data.Functor

31+import Data.Functor.Identity

31import Data.HList

32import Data.HList

32import qualified Data.HashMap.Strict as HM

33import qualified Data.HashMap.Strict as HM

33import qualified Data.HashMap.Strict.InsOrd as IOHM

34import qualified Data.HashMap.Strict.InsOrd as IOHM

@@ -90,7 +91,7 @@ untypeValue (TArray a) = A.Array a

90untypeValue (TObject o) = A.Object o

91untypeValue (TObject o) = A.Object o

91

92

92data Bound a = Exclusive !a | Inclusive !a

93data Bound a = Exclusive !a | Inclusive !a

93− deriving (Eq, Show, Functor)

94+ deriving stock (Eq, Show, Functor)

94

95

95-- | The order is lexicographical on @a * Bool@.

96-- | The order is lexicographical on @a * Bool@.

96instance Ord a => Ord (Bound a) where

97instance Ord a => Ord (Bound a) where

@@ -417,19 +418,19 @@ instance Steppable Schema (Referenced Schema) where

417 | ItemsArrayStep Int

418 | ItemsArrayStep Int

418 | AdditionalPropertiesStep

419 | AdditionalPropertiesStep

419 | NotStep

420 | NotStep

420− deriving (Eq, Ord, Show)

421+ deriving stock (Eq, Ord, Show)

421

422

422instance Steppable Schema (Definitions (Referenced Schema)) where

423instance Steppable Schema (Definitions (Referenced Schema)) where

423 data Step Schema (Definitions (Referenced Schema)) = PropertiesStep

424 data Step Schema (Definitions (Referenced Schema)) = PropertiesStep

424− deriving (Eq, Ord, Show)

425+ deriving stock (Eq, Ord, Show)

425

426

426instance Steppable Schema Discriminator where

427instance Steppable Schema Discriminator where

427 data Step Schema Discriminator = DiscriminatorStep

428 data Step Schema Discriminator = DiscriminatorStep

428− deriving (Eq, Ord, Show)

429+ deriving stock (Eq, Ord, Show)

429

430

430instance Steppable Discriminator (Definitions (Referenced Schema)) where

431instance Steppable Discriminator (Definitions (Referenced Schema)) where

431 data Step Discriminator (Definitions (Referenced Schema)) = DiscriminatorMapping

432 data Step Discriminator (Definitions (Referenced Schema)) = DiscriminatorMapping

432− deriving (Eq, Ord, Show)

433+ deriving stock (Eq, Ord, Show)

433

434

434parseDiscriminatorValue :: Text -> Referenced Schema

435parseDiscriminatorValue :: Text -> Referenced Schema

435parseDiscriminatorValue v = case A.fromJSON @(Referenced Schema) $ A.object ["$ref" A..= v] of

436parseDiscriminatorValue v = case A.fromJSON @(Referenced Schema) $ A.object ["$ref" A..= v] of

src/OpenAPI/Checker/Validate/SecurityScheme.hs+2−2

@@ -36,8 +36,8 @@ tracedSecuritySchemaTypes (Traced t x) = Traced (t >>> step SecuritySchemeTypeSt

36

37instance Steppable SecurityScheme SecuritySchemeType where

38 data Step SecurityScheme SecuritySchemeType = SecuritySchemeTypeStep

39− deriving (Eq, Ord, Show)

39+ deriving stock (Eq, Ord, Show)

40

41instance Steppable SecuritySchemeType OAuth2Flows where

42 data Step SecuritySchemeType OAuth2Flows = SecurityOAuthFlowsStep

43− deriving (Eq, Ord, Show)

43+ deriving stock (Eq, Ord, Show)

src/OpenAPI/Checker/Validate/Server.hs+1−1

@@ -124,7 +124,7 @@ parseServerUrl = fromRight undefined . parseOnly (serverUrlParser <* endOfInput)

124

125instance Steppable [Server] ProcessedServer where

126 data Step [Server] ProcessedServer = ServerStep Text

127− deriving (Eq, Ord, Show)

127+ deriving stock (Eq, Ord, Show)

128

129instance Issuable 'ServerLevel where

130 data Issue 'ServerLevel

test/Spec/Golden/Extra.hs+1−1

@@ -17,7 +17,7 @@ import Test.Tasty.Golden

17data TestInput t

18 = TestInputNode TestName [TestInput t]

19 | TestInputLeaf TestName t FilePath

20− deriving (Functor)

20+ deriving stock (Functor)

21

22getGoldenInputs

23 :: (Each s t (FilePath, FilePath -> IO a) a)