{-# 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 (AuthProtect, Capture, CaptureAll, Get, JSON, NoContent,
NoContentVerb, Post, QueryParam, QueryParams,
ReqBody, StdMethod (GET, POST), Verb,
type (:<|>), type (:>))
import Servant.Multipart (MultipartForm, MultipartData, Mem)
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)
import Data.Kind (Type)
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 Phan :: k -> Type
data Phan a
data Ghostly = Waaa | Oooo
type DisambiguatedByPhantom =
"spooky"
:> Capture "boo!" (Phan 'Waaa)
:> Capture "entrails" (Phan 'Oooo) :> Post '[JSON] ()
type Duplicates
= "bar" :> CaptureAll "foo" () :> "baz" :> CaptureAll "bar" () :> Get '[JSON] ()
:<|> "hunk" :> QueryParam "foo" () :> QueryParam "bar" () :> Get '[JSON] ()
:<|> "baz" :> Capture "foo" () :> Capture "bar" () :> Get '[JSON] ()
:<|> "foo" :> "foo" :> "foo" :> Get '[JSON] ()
:<|> "mixed" :> Capture "id" Int :> ReqBody '[JSON] Int :> Post '[JSON] String
:<|> "query-capture" :> Capture "userId" String :> QueryParam "name" String :> Get '[JSON] ()
type DuplicateQueryParamNames
= "test" :> QueryParam "foo" Int :> QueryParam "foo" Bool :> Get '[JSON] ()
:<|> "multi" :> QueryParam "name" Int :> QueryParam "age" Int :> QueryParam "name" Int :> Post '[JSON] ()
type MultipleDuplicateQueryParamNames
= "chaos" :> QueryParam "foo" Int :> QueryParam "bar" String :> QueryParam "foo" Bool :> QueryParam "bar" Double :> Get '[JSON] ()
type AuthProtectAPI
= "protected" :> AuthProtect "jwt" :> MultipartForm Mem (MultipartData Mem) :> 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
it "DisambiguatedByPhantom" $ lintShouldBe @DisambiguatedByPhantom $ mempty
it "AuthProtect and Multipart instances work" $ lintShouldBe @AuthProtectAPI $ 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 "Route accepts the same type multiple times: "
, bold $ chunk "()"
, chunk ". This doesn't guarantee argument order and can lead to ambiguous behavior:"
]
, [ chunk "\t\"bar\" :> CaptureAll \"foo\" () 👈 :> \"baz\" :> CaptureAll \"bar\" () 👈 :> Verb 'GET 200 ()" ]
, []
, [ chunk "Route accepts the same type multiple times: "
, bold $ chunk "()"
, chunk ". This doesn't guarantee argument order and can lead to ambiguous behavior:"
]
, [ chunk "\t\"hunk\" :> QueryParam \"foo\" () 👈 :> QueryParam \"bar\" () 👈 :> Verb 'GET 200 ()" ]
, []
, [ chunk "Route accepts the same type multiple times: "
, bold $ chunk "()"
, chunk ". This doesn't guarantee argument order and can lead to ambiguous behavior:"
]
, [ chunk "\t\"baz\" :> Capture \"foo\" () 👈 :> Capture \"bar\" () 👈 :> Verb 'GET 200 ()" ]
, []
, [ chunk "Route accepts the same type multiple times: "
, bold $ chunk "Int"
, chunk ". This doesn't guarantee argument order and can lead to ambiguous behavior:"
]
, [ chunk "\t\"mixed\" :> Capture \"id\" Int 👈 :> ReqBody _ _ Int 👈 :> Verb 'POST 200 [Char]" ]
, []
, [ chunk "Route accepts the same type multiple times: "
, bold $ chunk "[Char]"
, chunk ". This doesn't guarantee argument order and can lead to ambiguous behavior:"
]
, [ chunk "\t\"query-capture\" :> Capture \"userId\" [Char] 👈 :> QueryParam \"name\" [Char] 👈 :> Verb 'GET 200 ()" ]
]
it "duplicate QueryParam names" $ lintShouldBe @DuplicateQueryParamNames
[ [ chunk "Route has multiple QueryParam with the same name: "
, bold $ chunk "foo"
, chunk ". QueryParam names must be unique within a route:"
]
, [ chunk "\t\"test\" :> QueryParam \"foo\" Int 👈 :> QueryParam \"foo\" Bool 👈 :> Verb 'GET 200 ()" ]
, []
, [ chunk "Route accepts the same type multiple times: "
, bold $ chunk "Int, Int"
, chunk ". This doesn't guarantee argument order and can lead to ambiguous behavior:"
]
, [ chunk "\t\"multi\" :> QueryParam \"name\" Int 👈 :> QueryParam \"age\" Int 👈 :> QueryParam \"name\" Int 👈 :> Verb 'POST 200 ()" ]
, []
, [ chunk "Route has multiple QueryParam with the same name: "
, bold $ chunk "name"
, chunk ". QueryParam names must be unique within a route:"
]
, [ chunk "\t\"multi\" :> QueryParam \"name\" Int 👈 :> QueryParam \"age\" Int :> QueryParam \"name\" Int 👈 :> Verb 'POST 200 ()" ]
]
it "multiple duplicate QueryParam names" $ lintShouldBe @MultipleDuplicateQueryParamNames
[ [ chunk "Route has multiple QueryParam with the same name: "
, bold $ chunk "foo, bar"
, chunk ". QueryParam names must be unique within a route:"
]
, [ chunk "\t\"chaos\" :> QueryParam \"foo\" Int 👈 :> QueryParam \"bar\" [Char] 👈 :> QueryParam \"foo\" Bool 👈 :> QueryParam \"bar\" Double 👈 :> Verb 'GET 200 ()" ]
]