420 lines
14 KiB
Haskell
420 lines
14 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
module Servant.QuickCheck.InternalSpec (spec) where
|
|
|
|
|
|
import Control.Concurrent.MVar (newMVar, readMVar, swapMVar)
|
|
import Control.Exception (SomeException)
|
|
import Control.Monad (replicateM)
|
|
import Control.Monad.IO.Class (liftIO)
|
|
import qualified Data.ByteString as BS
|
|
import qualified Data.ByteString.Char8 as C
|
|
import Data.Maybe (fromJust)
|
|
import Network.HTTP.Client (path, queryString)
|
|
import Prelude.Compat
|
|
import Servant
|
|
import Servant.HTML.Blaze (HTML)
|
|
import qualified Text.Blaze.Html as Blaze
|
|
import qualified Text.Blaze.Html5 as Blaze5
|
|
import Test.Hspec (Spec, context, describe, it, shouldBe,
|
|
shouldContain)
|
|
import Test.Hspec.Core.Spec (Arg, Example, Result (..),
|
|
defaultParams)
|
|
import Test.QuickCheck.Gen (generate, unGen)
|
|
import Test.QuickCheck.Random (mkQCGen)
|
|
|
|
|
|
#if MIN_VERSION_servant(0,8,0)
|
|
import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPIWithoutRaw)
|
|
#else
|
|
import Servant.API.Internal.Test.ComprehensiveAPI (ComprehensiveAPI,
|
|
comprehensiveAPI)
|
|
#endif
|
|
|
|
#if MIN_VERSION_hspec(2,4,0)
|
|
import Test.Hspec.Core.Spec (safeEvaluateExample)
|
|
#else
|
|
import Control.Exception (try)
|
|
import Test.Hspec.Core.Spec (evaluateExample)
|
|
#endif
|
|
|
|
import Servant.QuickCheck
|
|
import Servant.QuickCheck.Internal (genRequest, runGenRequest,
|
|
serverDoesntSatisfy)
|
|
|
|
spec :: Spec
|
|
spec = do
|
|
serversEqualSpec
|
|
serverSatisfiesSpec
|
|
isComprehensiveSpec
|
|
no500s
|
|
onlyJsonObjectSpec
|
|
notLongerThanSpec
|
|
queryParamsSpec
|
|
queryFlagsSpec
|
|
deepPathSpec
|
|
authServerCheck
|
|
htmlDocTypesSpec
|
|
unbiasedGenerationSpec
|
|
|
|
serversEqualSpec :: Spec
|
|
serversEqualSpec = describe "serversEqual" $ do
|
|
|
|
it "considers equal servers equal" $ do
|
|
withServantServerAndContext api ctx server $ \burl1 ->
|
|
withServantServerAndContext api ctx server $ \burl2 -> do
|
|
serversEqual api burl1 burl2 args bodyEquality
|
|
|
|
context "when servers are not equal" $ do
|
|
it "provides the failing responses in the error message" $ do
|
|
FailedWith err <- withServantServer api2 server2 $ \burl1 ->
|
|
withServantServer api2 server3 $ \burl2 -> do
|
|
evalExample $ serversEqual api2 burl1 burl2 args bodyEquality
|
|
show err `shouldContain` "Server equality failed"
|
|
show err `shouldContain` "Body: 1"
|
|
show err `shouldContain` "Body: 2"
|
|
show err `shouldContain` "Path: /failplz"
|
|
|
|
context "when JSON is equal but looks a bit different as a ByteString" $ do
|
|
|
|
it "sanity check: different whitespace same JSON objects bodyEquality fails" $ do
|
|
FailedWith err <- withServantServer jsonApi jsonServer1 $ \burl1 ->
|
|
withServantServer jsonApi jsonServer2 $ \burl2 -> do
|
|
evalExample $ serversEqual jsonApi burl1 burl2 args bodyEquality
|
|
show err `shouldContain` "Server equality failed"
|
|
|
|
it "jsonEquality considers equal JSON apis equal regardless of key ordering or whitespace" $ do
|
|
withServantServerAndContext jsonApi ctx jsonServer1 $ \burl1 ->
|
|
withServantServerAndContext jsonApi ctx jsonServer2 $ \burl2 ->
|
|
serversEqual jsonApi burl1 burl2 args jsonEquality
|
|
|
|
it "sees when JSON apis are not equal because any value is different" $ do
|
|
FailedWith err <- withServantServer jsonApi jsonServer2 $ \burl1 ->
|
|
withServantServer jsonApi jsonServer3 $ \burl2 -> do
|
|
evalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality
|
|
show err `shouldContain` "Server equality failed"
|
|
show err `shouldContain` "Path: /jsonComparison"
|
|
|
|
it "sees when JSON apis are not equal due to different keys but same values" $ do
|
|
FailedWith err <- withServantServer jsonApi jsonServer2 $ \burl1 ->
|
|
withServantServer jsonApi jsonServer4 $ \burl2 -> do
|
|
evalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality
|
|
show err `shouldContain` "Server equality failed"
|
|
show err `shouldContain` "Path: /jsonComparison"
|
|
|
|
|
|
serverSatisfiesSpec :: Spec
|
|
serverSatisfiesSpec = describe "serverSatisfies" $ do
|
|
|
|
it "succeeds for true predicates" $ do
|
|
withServantServerAndContext api ctx server $ \burl ->
|
|
serverSatisfies api burl args (unauthorizedContainsWWWAuthenticate
|
|
<%> not500
|
|
<%> mempty)
|
|
|
|
it "fails for false predicates" $ do
|
|
withServantServerAndContext api ctx server $ \burl -> do
|
|
serverDoesntSatisfy api burl args (onlyJsonObjects
|
|
<%> getsHaveCacheControlHeader
|
|
<%> headsHaveCacheControlHeader
|
|
<%> notAllowedContainsAllowHeader
|
|
<%> mempty)
|
|
|
|
context "when predicates are false" $ do
|
|
|
|
it "fails with informative error messages" $ do
|
|
FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
|
|
evalExample $ serverSatisfies api burl args (notAllowedContainsAllowHeader <%> mempty)
|
|
show err `shouldContain` "notAllowedContainsAllowHeader"
|
|
show err `shouldContain` "Headers"
|
|
show err `shouldContain` "Body"
|
|
|
|
|
|
no500s :: Spec
|
|
no500s = describe "no500s" $ do
|
|
|
|
it "fails correctly" $ do
|
|
FailedWith err <- withServantServerAndContext api2 ctx server500fail $ \burl -> do
|
|
evalExample $ serverSatisfies api2 burl args
|
|
(not500 <%> mempty)
|
|
show err `shouldContain` "not500"
|
|
|
|
onlyJsonObjectSpec :: Spec
|
|
onlyJsonObjectSpec = describe "onlyJsonObjects" $ do
|
|
|
|
it "fails correctly" $ do
|
|
FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
|
|
evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
|
|
(onlyJsonObjects <%> mempty)
|
|
show err `shouldContain` "onlyJsonObjects"
|
|
|
|
it "accepts non-JSON endpoints" $ do
|
|
withServantServerAndContext octetAPI ctx serverOctetAPI $ \burl ->
|
|
serverSatisfies octetAPI burl args (onlyJsonObjects <%> mempty)
|
|
|
|
notLongerThanSpec :: Spec
|
|
notLongerThanSpec = describe "notLongerThan" $ do
|
|
|
|
it "fails correctly" $ do
|
|
FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
|
|
evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
|
|
(notLongerThan 1 <%> mempty)
|
|
show err `shouldContain` "notLongerThan"
|
|
|
|
it "succeeds correctly" $ do
|
|
withServantServerAndContext api ctx server $ \burl ->
|
|
serverSatisfies api burl args (notLongerThan 1000000000000 <%> mempty)
|
|
|
|
isComprehensiveSpec :: Spec
|
|
isComprehensiveSpec = describe "HasGenRequest" $ do
|
|
|
|
it "has instances for all 'servant' combinators" $ do
|
|
let _g = genRequest comprehensiveAPIWithoutRaw
|
|
True `shouldBe` True -- This is a type-level check
|
|
|
|
deepPathSpec :: Spec
|
|
deepPathSpec = describe "Path components" $ do
|
|
|
|
it "are separated by slashes, without a trailing slash" $ do
|
|
let rng = mkQCGen 0
|
|
burl = BaseUrl Http "localhost" 80 ""
|
|
gen = runGenRequest deepAPI
|
|
req = (unGen gen rng 0) burl
|
|
path req `shouldBe` ("/one/two/three")
|
|
|
|
|
|
queryParamsSpec :: Spec
|
|
queryParamsSpec = describe "QueryParams" $ do
|
|
|
|
it "reduce to an HTTP query string correctly" $ do
|
|
let rng = mkQCGen 0
|
|
burl = BaseUrl Http "localhost" 80 ""
|
|
gen = runGenRequest paramsAPI
|
|
req = (unGen gen rng 0) burl
|
|
qs = C.unpack $ queryString req
|
|
qs `shouldBe` "one=_&two=_"
|
|
|
|
queryFlagsSpec :: Spec
|
|
queryFlagsSpec = describe "QueryFlags" $ do
|
|
|
|
it "reduce to an HTTP query string correctly" $ do
|
|
let rng = mkQCGen 0
|
|
burl = BaseUrl Http "localhost" 80 ""
|
|
gen = runGenRequest flagsAPI
|
|
req = (unGen gen rng 0) burl
|
|
qs = C.unpack $ queryString req
|
|
qs `shouldBe` "one&two"
|
|
|
|
authServerCheck :: Spec
|
|
authServerCheck = describe "authenticate endpoints" $ do
|
|
|
|
it "authorization failure without WWWAuthenticate header fails correctly" $ do
|
|
FailedWith err <- withServantServerAndContext api2 ctx authFailServer $ \burl -> do
|
|
evalExample $ serverSatisfies api2 burl args
|
|
(unauthorizedContainsWWWAuthenticate <%> mempty)
|
|
show err `shouldContain` "unauthorizedContainsWWWAuthenticate"
|
|
|
|
|
|
-- Large API Randomness Testing Helper
|
|
htmlDocTypesSpec :: Spec
|
|
htmlDocTypesSpec = describe "HtmlDocTypes" $ do
|
|
|
|
it "fails HTML without doctype correctly" $ do
|
|
err <- withServantServerAndContext docTypeApi ctx noDocTypeServer $ \burl -> do
|
|
evalExample $ serverSatisfies docTypeApi burl args
|
|
(htmlIncludesDoctype <%> mempty)
|
|
show err `shouldContain` "htmlIncludesDoctype"
|
|
|
|
it "passes HTML with a doctype at start" $ do
|
|
withServantServerAndContext docTypeApi ctx docTypeServer $ \burl ->
|
|
serverSatisfies docTypeApi burl args (htmlIncludesDoctype <%> mempty)
|
|
|
|
it "accepts json endpoints and passes over them in silence" $ do
|
|
withServantServerAndContext api ctx server $ \burl -> do
|
|
serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
|
|
(htmlIncludesDoctype <%> mempty)
|
|
|
|
|
|
makeRandomRequest :: Proxy LargeAPI -> BaseUrl -> IO Integer
|
|
makeRandomRequest large burl = do
|
|
req <- generate $ runGenRequest large
|
|
pure $ fst . fromJust . C.readInteger . C.drop 1 . path $ req burl
|
|
|
|
unbiasedGenerationSpec :: Spec
|
|
unbiasedGenerationSpec = describe "Unbiased Generation of requests" $
|
|
|
|
it "frequency paired with generated endpoint should be more randomly distributed" $ do
|
|
let burl = BaseUrl Http "localhost" 80 ""
|
|
let runs = 10000 :: Double
|
|
someRequests <- replicateM 10000 (makeRandomRequest largeApi burl)
|
|
let mean = (sum $ map fromIntegral someRequests) / runs
|
|
let variancer x = let ix = fromIntegral x in (ix - mean) * (ix - mean)
|
|
let variance = (sum $ map variancer someRequests) / runs - 1
|
|
-- mean should be around 8.5. If this fails, we likely need more runs (or there's a bug!)
|
|
mean > 8 `shouldBe` True
|
|
mean < 9 `shouldBe` True
|
|
-- Std dev is likely around 4. Variance is probably greater than 20.
|
|
variance > 19.5 `shouldBe` True
|
|
|
|
------------------------------------------------------------------------------
|
|
-- APIs
|
|
------------------------------------------------------------------------------
|
|
|
|
type API = ReqBody '[JSON] String :> Post '[JSON] String
|
|
:<|> Get '[JSON] Int
|
|
:<|> BasicAuth "some-realm" () :> Get '[JSON] ()
|
|
|
|
api :: Proxy API
|
|
api = Proxy
|
|
|
|
type ParamsAPI = QueryParam "one" () :> QueryParam "two" () :> Get '[JSON] ()
|
|
|
|
paramsAPI :: Proxy ParamsAPI
|
|
paramsAPI = Proxy
|
|
|
|
type FlagsAPI = QueryFlag "one" :> QueryFlag "two" :> Get '[JSON] ()
|
|
|
|
flagsAPI :: Proxy FlagsAPI
|
|
flagsAPI = Proxy
|
|
|
|
|
|
server :: IO (Server API)
|
|
server = do
|
|
mvar <- newMVar ""
|
|
return $ (\x -> liftIO $ swapMVar mvar x)
|
|
:<|> (liftIO $ readMVar mvar >>= return . length)
|
|
:<|> (const $ return ())
|
|
|
|
|
|
type API2 = "failplz" :> Get '[JSON] Int
|
|
|
|
api2 :: Proxy API2
|
|
api2 = Proxy
|
|
|
|
type DeepAPI = "one" :> "two" :> "three":> Get '[JSON] ()
|
|
|
|
deepAPI :: Proxy DeepAPI
|
|
deepAPI = Proxy
|
|
|
|
server2 :: IO (Server API2)
|
|
server2 = return $ return 1
|
|
|
|
server3 :: IO (Server API2)
|
|
server3 = return $ return 2
|
|
|
|
server500fail :: IO (Server API2)
|
|
server500fail = return $ throwError $ err500 { errBody = "BOOM!" }
|
|
|
|
authFailServer :: IO (Server API2)
|
|
authFailServer = return $ throwError $ err401 { errBody = "Login failure but missing header"}
|
|
|
|
-- With Doctypes
|
|
type HtmlDoctype = Get '[HTML] Blaze.Html
|
|
|
|
docTypeApi :: Proxy HtmlDoctype
|
|
docTypeApi = Proxy
|
|
|
|
docTypeServer :: IO (Server HtmlDoctype)
|
|
docTypeServer = pure $ pure $ Blaze5.docTypeHtml $ Blaze5.span "Hello Test!"
|
|
|
|
noDocTypeServer :: IO (Server HtmlDoctype)
|
|
noDocTypeServer = pure $ pure $ Blaze.text "Hello Test!"
|
|
|
|
-- Api for unbiased generation of requests tests
|
|
largeApi :: Proxy LargeAPI
|
|
largeApi = Proxy
|
|
|
|
type LargeAPI
|
|
= "1" :> Get '[JSON] Int
|
|
:<|> "2" :> Get '[JSON] Int
|
|
:<|> "3" :> Get '[JSON] Int
|
|
:<|> "4" :> Get '[JSON] Int
|
|
:<|> "5" :> Get '[JSON] Int
|
|
:<|> "6" :> Get '[JSON] Int
|
|
:<|> "7" :> Get '[JSON] Int
|
|
:<|> "8" :> Get '[JSON] Int
|
|
:<|> "9" :> Get '[JSON] Int
|
|
:<|> "10" :> Get '[JSON] Int
|
|
:<|> "11" :> Get '[JSON] Int
|
|
:<|> "12" :> Get '[JSON] Int
|
|
:<|> "13" :> Get '[JSON] Int
|
|
:<|> "14" :> Get '[JSON] Int
|
|
:<|> "15" :> Get '[JSON] Int
|
|
:<|> "16" :> Get '[JSON] Int
|
|
|
|
|
|
type OctetAPI = Get '[OctetStream] BS.ByteString
|
|
|
|
octetAPI :: Proxy OctetAPI
|
|
octetAPI = Proxy
|
|
|
|
serverOctetAPI :: IO (Server OctetAPI)
|
|
serverOctetAPI = return $ return "blah"
|
|
|
|
type JsonApi = "jsonComparison" :> Get '[OctetStream] BS.ByteString
|
|
|
|
jsonApi :: Proxy JsonApi
|
|
jsonApi = Proxy
|
|
|
|
jsonServer1 :: IO (Server JsonApi)
|
|
jsonServer1 = return $ return "{ \"b\": [\"b\"], \"a\": 1 }" -- whitespace, ordering different
|
|
|
|
jsonServer2 :: IO (Server JsonApi)
|
|
jsonServer2 = return $ return "{\"a\": 1,\"b\":[\"b\"]}"
|
|
|
|
jsonServer3 :: IO (Server JsonApi)
|
|
jsonServer3 = return $ return "{\"a\": 2, \"b\": [\"b\"]}"
|
|
|
|
jsonServer4 :: IO (Server JsonApi)
|
|
jsonServer4 = return $ return "{\"c\": 1, \"d\": [\"b\"]}"
|
|
|
|
|
|
ctx :: Context '[BasicAuthCheck ()]
|
|
ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext
|
|
------------------------------------------------------------------------------
|
|
-- Utils
|
|
------------------------------------------------------------------------------
|
|
evalExample :: (Example e, Arg e ~ ()) => e -> IO EvalResult
|
|
#if MIN_VERSION_hspec(2,4,0)
|
|
evalExample e = do
|
|
r <- safeEvaluateExample e defaultParams ($ ()) progCallback
|
|
case r of
|
|
Left err -> return $ AnException err
|
|
Right Success -> return $ AllGood
|
|
Right (Failure _ reason) -> return $ FailedWith $ show reason
|
|
Right (Pending _) -> error "should not happen"
|
|
where
|
|
progCallback _ = return ()
|
|
#else
|
|
evalExample e = do
|
|
r <- try $ evaluateExample e defaultParams ($ ()) progCallback
|
|
case r of
|
|
Left err -> return $ AnException err
|
|
Right Success -> return $ AllGood
|
|
Right (Fail _ reason) -> return $ FailedWith reason
|
|
Right (Pending _) -> error "should not happen"
|
|
where
|
|
progCallback _ = return ()
|
|
#endif
|
|
|
|
data EvalResult
|
|
= AnException SomeException
|
|
| AllGood
|
|
| FailedWith String
|
|
deriving (Show)
|
|
|
|
|
|
args :: Args
|
|
args = defaultArgs { maxSuccess = noOfTestCases }
|
|
|
|
noOfTestCases :: Int
|
|
#if LONG_TESTS
|
|
noOfTestCases = 20000
|
|
#else
|
|
noOfTestCases = 1000
|
|
#endif
|
|
|
|
#if !MIN_VERSION_servant(0,8,0)
|
|
comprehensiveAPIWithoutRaw :: Proxy ComprehensiveAPI
|
|
comprehensiveAPIWithoutRaw = comprehensiveAPI
|
|
#endif
|