servant-lint (empty) → 0.1.0.0
raw patch · 5 files changed
+538/−0 lines, 5 filesdep +basedep +bytestringdep +containers
Dependencies added: base, bytestring, containers, safe-coloured-text, servant, servant-server, sydtest, text
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- servant-lint.cabal +51/−0
- src/Servant/Lint.hs +230/−0
- test/Main.hs +222/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for servant-coherent++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2024, Isaac Shapira++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Isaac Shapira nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ servant-lint.cabal view
@@ -0,0 +1,51 @@+cabal-version: 3.0+name: servant-lint+version: 0.1.0.0+synopsis: Lint Servant Routes+description: Lint Servant Routes and reject bad routes, overlaps, and more+license: BSD-3-Clause+license-file: LICENSE+author: Isaac Shapira+maintainer: isaac.shapira@platonic.systems+category: Web+build-type: Simple+extra-doc-files: CHANGELOG.md++source-repository head+ type: git+ location: https://gitlab.com/platonic/servant-lint.git++common warnings+ ghc-options: -Wall++library+ import: warnings+ exposed-modules: Servant.Lint+ build-depends:+ base >= 4.18.2 && < 4.19,+ bytestring >= 0.11.5 && < 0.12,+ containers >= 0.6.7 && < 0.7,+ safe-coloured-text >= 0.2.0 && < 0.3,+ text >= 2.0.2 && < 2.1,+ servant >= 0.20.1 && < 0.21,+ servant-server >= 0.20 && < 0.21+ hs-source-dirs: src+ default-language: GHC2021++test-suite servant-lint-test+ import: warnings+ default-language: GHC2021+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ other-modules: Servant.Lint+ type: exitcode-stdio-1.0+ hs-source-dirs: test src+ main-is: Main.hs+ build-depends:+ , base+ , bytestring+ , containers+ , safe-coloured-text+ , servant+ , servant-server+ , sydtest+ , text
+ src/Servant/Lint.hs view
@@ -0,0 +1,230 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+module Servant.Lint+ ( lintAPI+ , lintAPI'+ , printLintAPI+ , Error(..)+ , Path(..)+ , Lintable(..)+ , Ambiguity(..)+ , unlinesChunks+ ) where++import Data.ByteString (ByteString)+import Data.Containers.ListUtils (nubOrd)+import Data.Kind (Constraint, Type)+import Data.Maybe (mapMaybe, maybeToList)+import Data.Proxy (Proxy (Proxy))+import qualified Data.Text as Text (pack, unpack)+import Data.Text.Encoding (decodeUtf8)+import Data.Typeable (TypeRep, Typeable, typeRep)+import GHC.Generics (Generic)+import GHC.TypeLits (KnownNat, KnownSymbol, natVal,+ symbolVal)+import Servant.API (Capture', CaptureAll, NoContent,+ NoContentVerb, QueryParam,+ QueryParams, ReflectMethod (..),+ ReqBody', Verb, type (:<|>),+ type (:>))+import Text.Colour (Chunk, TerminalCapabilities (..),+ bold, renderChunksText)+import Text.Colour.Chunk (chunk, fore, red)++-- | A term level representation of the API+-- Its defined recursive to flatten the API to a list of routes instead of a tree+type Path :: Type+data Path+ = PPath String !Path+ | PCapture String TypeRep !Path+ | PCaptureAll String TypeRep !Path+ | PQueryParam String TypeRep !Path+ | PQueryParams String TypeRep !Path+ | PReqBody TypeRep !Path+ | PVerb ByteString Integer TypeRep+ deriving (Eq, Ord)++instance Show Path where+ show (PPath s p) = "\"" <> s <> "\" :> " <> show p+ show (PCapture s t p) = "Capture \"" <> s <> "\" " <> show t <> " :> " <> show p+ show (PCaptureAll s t p) = "CaptureAll \"" <> s <> "\" " <> show t <> " :> " <> show p+ show (PQueryParam s t p) = "QueryParam \"" <> s <> "\" " <> show t <> " :> " <> show p+ show (PQueryParams s t p) = "QueryParams \"" <> s <> "\" " <> show t <> " :> " <> show p+ show (PReqBody t p) = "ReqBody _ _ " <> show t <> " :> " <> show p+ show (PVerb method code t) = "Verb '" <> Text.unpack (decodeUtf8 method) <> " " <> show code <> " " <> show t++-- | The Lintable type class describes how to go from a Servant Combinator to a @Path@+-- This is essentially a function from `Type -> [Path]`+-- If you have custom Servant Combinators you may need to add an instance of Lintable for your Combinator, typically ignoring the custom Combinator.+type Lintable :: Type -> Constraint+class Lintable a where+ paths :: [Path]++instance (Lintable a, Lintable b) => Lintable (a :<|> b) where+ paths = paths @a <> paths @b++instance (Lintable b, KnownSymbol hint, Typeable a) => Lintable (Capture' _mods hint a :> b) where+ paths = PCapture (symbolVal (Proxy @hint)) (typeRep (Proxy @a))<$> paths @b++instance (Lintable b, KnownSymbol hint, Typeable a) => Lintable (CaptureAll hint a :> b) where+ paths = PCaptureAll (symbolVal (Proxy @hint)) (typeRep (Proxy @a)) <$> paths @b++instance (Lintable b, KnownSymbol hint, Typeable a) => Lintable (QueryParam hint a :> b) where+ paths = PQueryParam (symbolVal (Proxy @hint)) (typeRep (Proxy @a)) <$> paths @b++instance (Lintable b, KnownSymbol hint, Typeable a) => Lintable (QueryParams hint a :> b) where+ paths = PQueryParam (symbolVal (Proxy @hint)) (typeRep (Proxy @a)) <$> paths @b++instance (Lintable b, Typeable a) => Lintable (ReqBody' _mods _ms a :> b) where+ paths = PReqBody (typeRep (Proxy @a)) <$> paths @b++instance (KnownSymbol a, Lintable b) => Lintable (a :> b) where+ paths = PPath (symbolVal (Proxy @a)) <$> paths @b++instance {-# OVERLAPPABLE #-}+ ( ReflectMethod method+ ) => Lintable (NoContentVerb method) where+ paths = pure $ PVerb (reflectMethod (Proxy @method)) 204 (typeRep (Proxy @NoContent))++instance {-# OVERLAPPABLE #-}+ ( Typeable ret+ , ReflectMethod method+ , KnownNat code+ ) => Lintable (Verb method code _cs ret) where+ paths = pure $ PVerb (reflectMethod (Proxy @method)) (natVal (Proxy @code)) (typeRep (Proxy @ret))++-- | This is a striped down version of the @Path@ focusing on removing details that ambiguate routes+type Ambiguity :: Type+data Ambiguity+ = ACapture+ | ACaptureAll+ | AQueryParam String+ | APath String+ | AReqBody+ | AVerb ByteString Integer+ deriving (Eq, Ord, Show, Generic)++-- | Non lawful Eq check+(=!=) :: Ambiguity -> Ambiguity -> Bool+ACapture =!= _ = True+_ =!= ACapture = True+AReqBody =!= AReqBody = True+APath s =!= APath s' = s == s'+AVerb m c =!= AVerb m' c' = m == m' && c == c'+AQueryParam s =!= AQueryParam s' = s == s'+_ =!= _ = False++-- | Non lawful Eq check+(=!!=) :: [Ambiguity] -> [Ambiguity] -> Bool+a@(ACaptureAll : _) =!!= b@(_:_) = last a =!= last b+a@(_:_) =!!= b@(ACaptureAll:_) = last a =!= last b+(a:as) =!!= (b:bs) = a =!= b && as =!!= bs+[] =!!= [] = True+_ =!!= _ = False++ambiguity :: Path -> [Ambiguity]+ambiguity = \case+ PPath s p -> APath s : ambiguity p+ PCapture _ _ p -> ACapture : ambiguity p+ PCaptureAll _ _ p -> ACaptureAll : ambiguity p+ PReqBody _ p -> AReqBody : ambiguity p+ PQueryParam s _ p -> AQueryParam s : ambiguity p+ PQueryParams s _ p -> AQueryParam s : ambiguity p+ PVerb method code _ty -> [AVerb method code]++checkForDuplicates :: Path -> Maybe Error+checkForDuplicates p =+ if length (nubOrd noStatic) /= length noStatic+ then Just $ Error [[ chunk "Duplicate found in route "+ , bold $ chunk $ Text.pack (show p) <> ":"+ ]]+ else Nothing+ where+ noStatic = filter (\case APath _ -> False; _ -> True) $ ambiguity p++-- | Pretty errors via @Text.Colour@+newtype Error = Error { toChunks :: [[Chunk]] }+ deriving newtype (Eq, Show, Semigroup, Monoid)++elem' :: [Ambiguity] -> [[Ambiguity]] -> Bool+elem' = any . (=!!=)++-- | Pass your API type for lint errors as Chunks+-- Chunks are colored terminal bits from @Text.Colour@ for making+-- pretty errors.+lintAPI' :: forall api. Lintable api => [Error]+lintAPI' = case go psAll of [x,_] -> [x]; x -> x+ where+ psAll = paths @api+ go [] = []+ go (p:ps) =+ let ambiguities = [printAmbiguity psAll p | ambiguity p `elem'` (ambiguity <$> deleteFirst p psAll)]+ badReturns = mapMaybe (badReturn psAll p) psAll+ duplicates = checkForDuplicates p+ in ambiguities <> badReturns <> maybeToList duplicates <> go ps++-- | Pass your API type for lint errors thrown in IO+-- This is typically useful for testing+lintAPI :: forall api. Lintable api => IO ()+lintAPI = case lintAPI' @api of+ [] -> pure ()+ ls -> error $ Text.unpack $ renderChunksText With24BitColours . unlinesChunks $ unlinesChunks . toChunks <$> ls++-- | Pass your API type for lint via @putStrLn@ in stdout+printLintAPI :: forall api. Lintable api => IO ()+printLintAPI = case lintAPI' @api of+ [] -> pure ()+ ls -> putStrLn $ Text.unpack $ renderChunksText With24BitColours . unlinesChunks $ unlinesChunks . toChunks <$> ls++deleteFirst :: Eq t => t -> [t] -> [t]+deleteFirst _ [] = []+deleteFirst a (b:bc) | a == b = bc+ | otherwise = b : deleteFirst a bc++badReturn :: [Path] -> Path -> Path -> Maybe Error+badReturn psAll c = \case+ PPath _ p -> badReturn psAll c p+ PCapture _ _ p -> badReturn psAll c p+ PCaptureAll _ _ p -> badReturn psAll c p+ PQueryParam _ _ p -> badReturn psAll c p+ PVerb _method 500 _ty -> Just $ Error $+ [ chunk "Bad verb, you should never intentionally return 500 as part of your API:"+ ] : (badReturnColor <$> psAll)+ PVerb _method code ty | code /= 204 && ty == typeRep (Proxy @NoContent) -> Just $ Error $+ [ chunk "Bad verb, NoContent must use HTTP Status Code 204, not "+ , bold $ chunk $ Text.pack $ show code <> ":"+ ] : (badReturnColor <$> psAll)+ PReqBody _ (PVerb "GET" _ _) -> Just $ Error $+ [ chunk "Bad verb, do not use ReqBody in a GET request, Http 1.1 says its meaningless"+ ] : (badReturnColor <$> psAll)+ PReqBody _ (PVerb {}) -> Nothing+ PReqBody _ _ -> Just $ Error $+ [ chunk "ReqBody must be the last combinator before the Verb"+ ] : (badReturnColor <$> psAll)+ _ -> Nothing+ where+ badReturnColor :: Path -> [Chunk]+ badReturnColor p' = pure $+ if c == p'+ then fore red $ chunk $ ("\t" <>) $ Text.pack $ show p' <> " 👈"+ else chunk $ ("\t" <>) $ Text.pack $ show p'++printAmbiguity :: [Path] -> Path -> Error+printAmbiguity ps p = Error $+ [ chunk "Ambiguous with "+ , bold $ chunk $ Text.pack (show p) <> ":"+ ] : (overlappingColor <$> ps)+ where+ overlappingColor p' = pure $+ if ambiguity p =!!= ambiguity p'+ then fore red $ chunk $ ("\t" <>) $ Text.pack $ show p' <> " 👈"+ else chunk $ ("\t" <>) $ Text.pack $ show p'++-- | Exported for testing only+unlinesChunks :: [[Chunk]] -> [Chunk]+unlinesChunks = concatMap (<> [chunk "\n"])
+ test/Main.hs view
@@ -0,0 +1,222 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-unused-imports #-}+{-# OPTIONS_GHC -fconstraint-solver-iterations=0 #-}+{-# LANGUAGE DerivingVia #-}+{-# OPTIONS_GHC -Wno-orphans #-}+module Main (main) where++import Data.ByteString (ByteString)+import Data.String (fromString)+import Data.Text as Text (unpack)+import Servant (Capture, CaptureAll, Get, JSON, NoContent,+ NoContentVerb, Post, QueryParam, QueryParams,+ ReqBody, StdMethod (GET, POST), Verb,+ type (:<|>), type (:>))+import Servant.Lint (Ambiguity, Error (..), Lintable, lintAPI',+ unlinesChunks)+import Test.Syd (describe, expectationFailure, it, shouldBe,+ sydTest, xdescribe)+import Text.Colour (Chunk,+ TerminalCapabilities (With24BitColours), bold,+ chunk, fore, red, renderChunksText)++type DisambiguatedQuery+ = QueryParam "foo" Int :> Get '[JSON] ()+ :<|> QueryParam "bar" Int :> Get '[JSON] ()++type DisambiguatedMethod+ = Post '[JSON] ()+ :<|> Get '[JSON] ()++type DisambiguatedReturn+ = Get '[JSON] Bool+ :<|> Get '[JSON] ()++type DisambiguatedStatic+ = "foo" :> Get '[JSON] ()+ :<|> "bar" :> Get '[JSON] ()++type DisambiguatedNoContent+ = "foo" :> NoContentVerb 'GET++type DisambiguatedReqBody+ = ReqBody '[JSON] () :> Post '[JSON] ()+ :<|> "bar" :> ReqBody '[JSON] () :> Post '[JSON] ()++type AmbiguousRoot+ = Get '[JSON] ()+ :<|> Get '[JSON] ()++type AmbiguousStatic+ = "foo" :> Get '[JSON] ()+ :<|> "foo" :> Get '[JSON] ()++type AmbiguousCapture+ = "bar" :> Capture "gurf" Int :> Get '[JSON] ()+ :<|> "foo" :> Get '[JSON] ()+ :<|> "bar" :> Capture "wat" Int :> Get '[JSON] ()++type AmbiguousCaptureWithStatic+ = "bar" :> Capture "gurf" Int :> Get '[JSON] ()+ :<|> "bar" :> "5" :> Get '[JSON] ()+ :<|> "bar" :> "5" :> "wat" :> Get '[JSON] ()++type AmbiguousCaptureAllWithStatic+ = "bar" :> CaptureAll "murf" [Int] :> Get '[JSON] ()+ :<|> "bar" :> "5" :> Get '[JSON] ()+ :<|> "bar" :> Capture "how" Int :> Get '[JSON] ()+ :<|> "bar" :> "3" :> "2" :> Get '[JSON] ()++type AmbiguousQuery+ = QueryParam "foo" Int :> Get '[JSON] ()+ :<|> QueryParam "foo" String :> Get '[JSON] ()++type AmbiguousQuerys+ = QueryParams "foo" Int :> Get '[JSON] ()+ :<|> QueryParams"foo" String :> Get '[JSON] ()++type AmbiguousReqBody+ = ReqBody '[JSON] Int :> Post '[JSON] ()+ :<|> ReqBody '[JSON] String :> Post '[JSON] ()++type Bad200NoContent+ = "foo" :> Get '[JSON] NoContent+ :<|> "bar" :> Get '[JSON] ()++type BadReqBodyGet+ = "foo" :> ReqBody '[JSON] () :> Get '[JSON] ()++type BadReqBodyPosition+ = ReqBody '[JSON] () :> "bar" :> Post '[JSON] ()++type Bad500Code+ = "foo" :> Verb 'POST 500 '[JSON] ()++type Duplicates+ = "bar" :> CaptureAll "foo" () :> "baz" :> CaptureAll "bar" () :> Get '[JSON] ()+ :<|> "hunk" :> QueryParam "foo" () :> QueryParam "foo" Bool :> Get '[JSON] ()+ :<|> "baz" :> Capture "foo" () :> Capture "foo" Bool :> Get '[JSON] ()+ :<|> "foo" :> "foo" :> "foo" :> Get '[JSON] ()++lintShouldBe :: forall api. Lintable api => [[Chunk]] -> IO ()+lintShouldBe expected' = let+ renderError = renderChunksText With24BitColours . unlinesChunks . fmap (unlinesChunks . toChunks)+ actual = renderError $ lintAPI' @api+ expected = renderError [Error expected']+ in if expected' == mempty || actual == expected then pure ()+ else expectationFailure $ Text.unpack $ "Expected:\n\n" <> expected <> "But Got:\n\n" <> actual++main :: IO ()+main = sydTest $ do++ describe "Disambiguation" $ do+ it "DisambiguatedQuery" $ lintShouldBe @DisambiguatedQuery $ mempty+ it "DisambiguatedMethod" $ lintShouldBe @DisambiguatedMethod $ mempty+ it "DisambiguatedReturn" $ lintShouldBe @DisambiguatedReturn $ mempty+ it "DisambiguatedStatic" $ lintShouldBe @DisambiguatedStatic $ mempty+ it "DisambiguatedNoContent" $ lintShouldBe @DisambiguatedNoContent $ mempty+ it "DisambiguatedReqBody" $ lintShouldBe @DisambiguatedReqBody $ mempty++ describe "Ambiguation" $ do+ it "AmbiguousRoot" $ lintShouldBe @AmbiguousRoot+ [ [ chunk "Ambiguous with ", bold $ chunk "Verb 'GET 200 ():" ]+ , pure $ fore red $ chunk "\tVerb 'GET 200 () 👈"+ , pure $ fore red $ chunk "\tVerb 'GET 200 () 👈"+ ]+ it "AmbiguousCapture" $ lintShouldBe @AmbiguousCapture+ [ [ chunk "Ambiguous with ", bold $ chunk "\"bar\" :> Capture \"gurf\" Int :> Verb 'GET 200 ():" ]+ , pure $ fore red $ chunk "\t\"bar\" :> Capture \"gurf\" Int :> Verb 'GET 200 () 👈"+ , pure $ chunk "\t\"foo\" :> Verb 'GET 200 ()"+ , pure $ fore red $ chunk "\t\"bar\" :> Capture \"wat\" Int :> Verb 'GET 200 () 👈"+ ]+ it "AmbiguousCaptureWithStatic" $ lintShouldBe @AmbiguousCaptureWithStatic+ [ [ chunk "Ambiguous with ", bold $ chunk "\"bar\" :> Capture \"gurf\" Int :> Verb 'GET 200 ():" ]+ , pure $ fore red $ chunk "\t\"bar\" :> Capture \"gurf\" Int :> Verb 'GET 200 () 👈"+ , pure $ fore red $ chunk "\t\"bar\" :> \"5\" :> Verb 'GET 200 () 👈"+ , pure $ chunk "\t\"bar\" :> \"5\" :> \"wat\" :> Verb 'GET 200 ()"+ ]+ it "AmbiguousCaptureAllWithStatic" $ lintShouldBe @AmbiguousCaptureAllWithStatic+ [ [ chunk "Ambiguous with ", bold $ chunk "\"bar\" :> CaptureAll \"murf\" [Int] :> Verb 'GET 200 ():" ]+ , pure $ fore red $ chunk "\t\"bar\" :> CaptureAll \"murf\" [Int] :> Verb 'GET 200 () 👈"+ , pure $ fore red $ chunk "\t\"bar\" :> \"5\" :> Verb 'GET 200 () 👈"+ , pure $ fore red $ chunk "\t\"bar\" :> Capture \"how\" Int :> Verb 'GET 200 () 👈"+ , pure $ fore red $ chunk "\t\"bar\" :> \"3\" :> \"2\" :> Verb 'GET 200 () 👈"+ , []+ , [ chunk "Ambiguous with ", bold $ chunk "\"bar\" :> \"5\" :> Verb 'GET 200 ():" ]+ , pure $ fore red $ chunk "\t\"bar\" :> CaptureAll \"murf\" [Int] :> Verb 'GET 200 () 👈"+ , pure $ fore red $ chunk "\t\"bar\" :> \"5\" :> Verb 'GET 200 () 👈"+ , pure $ fore red $ chunk "\t\"bar\" :> Capture \"how\" Int :> Verb 'GET 200 () 👈"+ , pure $ chunk "\t\"bar\" :> \"3\" :> \"2\" :> Verb 'GET 200 ()"+ , []+ , [ chunk "Ambiguous with ", bold $ chunk "\"bar\" :> Capture \"how\" Int :> Verb 'GET 200 ():" ]+ , pure $ fore red $ chunk "\t\"bar\" :> CaptureAll \"murf\" [Int] :> Verb 'GET 200 () 👈"+ , pure $ fore red $ chunk "\t\"bar\" :> \"5\" :> Verb 'GET 200 () 👈"+ , pure $ fore red $ chunk "\t\"bar\" :> Capture \"how\" Int :> Verb 'GET 200 () 👈"+ , pure $ chunk "\t\"bar\" :> \"3\" :> \"2\" :> Verb 'GET 200 ()"+ , []+ , [ chunk "Ambiguous with ", bold $ chunk "\"bar\" :> \"3\" :> \"2\" :> Verb 'GET 200 ():" ]+ , pure $ fore red $ chunk "\t\"bar\" :> CaptureAll \"murf\" [Int] :> Verb 'GET 200 () 👈"+ , pure $ chunk "\t\"bar\" :> \"5\" :> Verb 'GET 200 ()"+ , pure $ chunk "\t\"bar\" :> Capture \"how\" Int :> Verb 'GET 200 ()"+ , pure $ fore red $ chunk "\t\"bar\" :> \"3\" :> \"2\" :> Verb 'GET 200 () 👈"+ ]+ it "AmbiguousQuery" $ lintShouldBe @AmbiguousQuery+ [ [ chunk "Ambiguous with ", bold $ chunk "QueryParam \"foo\" Int :> Verb 'GET 200 ():" ]+ , pure $ fore red $ chunk "\tQueryParam \"foo\" Int :> Verb 'GET 200 () 👈"+ , pure $ fore red $ chunk "\tQueryParam \"foo\" [Char] :> Verb 'GET 200 () 👈"+ ]+ it "AmbiguousQuerys" $ lintShouldBe @AmbiguousQuerys+ [ [ chunk "Ambiguous with ", bold $ chunk "QueryParam \"foo\" Int :> Verb 'GET 200 ():" ]+ , pure $ fore red $ chunk "\tQueryParam \"foo\" Int :> Verb 'GET 200 () 👈"+ , pure $ fore red $ chunk "\tQueryParam \"foo\" [Char] :> Verb 'GET 200 () 👈"+ ]+ it "AmbiguousStatic" $ lintShouldBe @AmbiguousStatic+ [ [ chunk "Ambiguous with ", bold $ chunk "\"foo\" :> Verb 'GET 200 ():" ]+ , pure $ fore red $ chunk "\t\"foo\" :> Verb 'GET 200 () 👈"+ , pure $ fore red $ chunk "\t\"foo\" :> Verb 'GET 200 () 👈"+ ]+ it "AmbiguousReqBody" $ lintShouldBe @AmbiguousReqBody+ [ [ chunk "Ambiguous with ", bold $ chunk "ReqBody _ _ Int :> Verb 'POST 200 ():" ]+ , pure $ fore red $ chunk "\tReqBody _ _ Int :> Verb 'POST 200 () 👈"+ , pure $ fore red $ chunk "\tReqBody _ _ [Char] :> Verb 'POST 200 () 👈"+ ]++ describe "Bad Returns" $ do+ it "NoContent" $ lintShouldBe @Bad200NoContent+ [ [ chunk "Bad verb, NoContent must use HTTP Status Code 204, not "+ , bold $ chunk "200:" ]+ , pure $ fore red $ chunk "\t\"foo\" :> Verb 'GET 200 NoContent 👈"+ , pure $ chunk "\t\"bar\" :> Verb 'GET 200 ()"+ ]++ it "ReqBody on GET" $ lintShouldBe @BadReqBodyGet+ [ [ chunk "Bad verb, do not use ReqBody in a GET request, Http 1.1 says its meaningless" ]+ , pure $ fore red $ chunk "\t\"foo\" :> ReqBody _ _ () :> Verb 'GET 200 () 👈"+ ]++ it "500 not allowed as valid response code" $ lintShouldBe @Bad500Code+ [ [ chunk "Bad verb, you should never intentionally return 500 as part of your API:" ]+ , pure $ fore red $ chunk "\t\"foo\" :> Verb 'POST 500 () 👈"+ ]++ it "ReqBody not next to Verb" $ lintShouldBe @BadReqBodyPosition+ [ [ chunk "ReqBody must be the last combinator before the Verb" ]+ , pure $ fore red $ chunk "\tReqBody _ _ () :> \"bar\" :> Verb 'POST 200 () 👈"+ ]++ it "duplicates" $ lintShouldBe @Duplicates+ [ [ chunk "Duplicate found in route "+ , bold $ chunk "\"bar\" :> CaptureAll \"foo\" () :> \"baz\" :> CaptureAll \"bar\" () :> Verb 'GET 200 ():"+ ]+ , []+ , [ chunk "Duplicate found in route "+ , bold $ chunk "\"hunk\" :> QueryParam \"foo\" () :> QueryParam \"foo\" Bool :> Verb 'GET 200 ():"+ ]+ , []+ , [ chunk "Duplicate found in route "+ , bold $ chunk "\"baz\" :> Capture \"foo\" () :> Capture \"foo\" Bool :> Verb 'GET 200 ():"+ ]+ ]