{-# 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 ():"
]
]