mirror of
https://github.com/ilyakooo0/servant-quickcheck.git
synced 2024-08-16 22:00:32 +03:00
Start implementing better error messages.
This commit is contained in:
parent
65a0809921
commit
70fed09866
@ -45,6 +45,7 @@ library
|
||||
, case-insensitive == 1.2.*
|
||||
, hspec == 2.2.*
|
||||
, text == 1.*
|
||||
, pretty == 1.1.*
|
||||
if impl(ghc < 7.10)
|
||||
build-depends: bifunctors == 5.*
|
||||
|
||||
@ -77,6 +78,7 @@ test-suite spec
|
||||
, base-compat
|
||||
, servant-quickcheck
|
||||
, hspec
|
||||
, hspec-core
|
||||
, http-client
|
||||
, warp
|
||||
, servant-server
|
||||
@ -88,7 +90,10 @@ test-suite spec
|
||||
default-extensions: TypeOperators
|
||||
, FlexibleInstances
|
||||
, FlexibleContexts
|
||||
, GADTs
|
||||
, DataKinds
|
||||
, NoImplicitPrelude
|
||||
, OverloadedStrings
|
||||
, ScopedTypeVariables
|
||||
if flag(long-tests)
|
||||
cpp-options: -DLONG_TESTS
|
||||
|
37
src/Servant/QuickCheck/Internal/ErrorTypes.hs
Normal file
37
src/Servant/QuickCheck/Internal/ErrorTypes.hs
Normal file
@ -0,0 +1,37 @@
|
||||
module Servant.QuickCheck.Internal.ErrorTypes where
|
||||
|
||||
import Text.PrettyPrint
|
||||
|
||||
data Request = Request
|
||||
{ requestBody :: String
|
||||
, requestHeaders :: [String]
|
||||
, requestUrl :: String
|
||||
} deriving (Eq, Show, Read, Generic)
|
||||
|
||||
prettyReq :: Doc
|
||||
prettyReq r =
|
||||
text "Request:" $ nest 5 $
|
||||
text "URL:" <+> text (nest 5 $ requestUrl r)
|
||||
$$ text "Headers:" <+>
|
||||
$$ text "Body:" <+> text (nest 5 $ requestBody r)
|
||||
|
||||
instance IsString Request where
|
||||
fromString url = Request "" [] url
|
||||
|
||||
data Response = Response
|
||||
{ responseBody :: String
|
||||
, responseHeaders :: [String]
|
||||
} deriving (Eq, Show, Read, Generic)
|
||||
|
||||
instance IsString Response where
|
||||
fromString body = Response body []
|
||||
|
||||
-- The error that occurred.
|
||||
data Failure
|
||||
= PredicateFailure String Request Response
|
||||
| ServerEqualityFailure Request Response Response
|
||||
deriving (Eq, Show, Read, Generic)
|
||||
|
||||
instance Show Failure where
|
||||
show (PredicateFailure pred req resp)
|
||||
= "Predicate failed for " <> pred <> "
|
@ -2,10 +2,10 @@ module Servant.QuickCheck.Internal.QuickCheck where
|
||||
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import Data.Proxy (Proxy)
|
||||
import Data.String (IsString (..))
|
||||
import Data.Text (Text)
|
||||
import Network.HTTP.Client (Manager, Request, checkStatus,
|
||||
defaultManagerSettings, httpLbs,
|
||||
newManager)
|
||||
import GHC.Generics (Generic)
|
||||
import qualified Network.HTTP.Client as C
|
||||
import Network.Wai.Handler.Warp (withApplication)
|
||||
import Prelude.Compat
|
||||
import Servant (Context (EmptyContext), HasServer,
|
||||
@ -17,9 +17,10 @@ import Test.QuickCheck (Args (..), Result (..),
|
||||
quickCheckWithResult)
|
||||
import Test.QuickCheck.Monadic (assert, forAllM, monadicIO, run)
|
||||
|
||||
import Servant.QuickCheck.Internal.Equality
|
||||
import Servant.QuickCheck.Internal.HasGenRequest
|
||||
import Servant.QuickCheck.Internal.Predicates
|
||||
import Servant.QuickCheck.Internal.Equality
|
||||
import Servant.QuickCheck.Internal.ErrorTypes
|
||||
|
||||
|
||||
-- | Start a servant application on an open port, run the provided function,
|
||||
@ -58,8 +59,8 @@ serversEqual :: HasGenRequest a =>
|
||||
serversEqual api burl1 burl2 args req = do
|
||||
let reqs = (\f -> (f burl1, f burl2)) <$> genRequest api
|
||||
r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \(req1, req2) -> do
|
||||
resp1 <- run $ httpLbs (noCheckStatus req1) defManager
|
||||
resp2 <- run $ httpLbs (noCheckStatus req2) defManager
|
||||
resp1 <- run $ C.httpLbs (noCheckStatus req1) defManager
|
||||
resp2 <- run $ C.httpLbs (noCheckStatus req2) defManager
|
||||
assert $ getResponseEquality req resp1 resp2
|
||||
case r of
|
||||
Success {} -> return ()
|
||||
@ -116,9 +117,9 @@ serverDoesntSatisfy api burl args preds = do
|
||||
NoExpectedFailure {} -> expectationFailure $ "No expected failure"
|
||||
InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
|
||||
|
||||
noCheckStatus :: Request -> Request
|
||||
noCheckStatus r = r { checkStatus = \_ _ _ -> Nothing}
|
||||
noCheckStatus :: C.Request -> C.Request
|
||||
noCheckStatus r = r { C.checkStatus = \_ _ _ -> Nothing}
|
||||
|
||||
defManager :: Manager
|
||||
defManager = unsafePerformIO $ newManager defaultManagerSettings
|
||||
defManager :: C.Manager
|
||||
defManager = unsafePerformIO $ C.newManager C.defaultManagerSettings
|
||||
{-# NOINLINE defManager #-}
|
||||
|
@ -1,5 +1,4 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Servant.QuickCheck.InternalSpec (spec) where
|
||||
|
||||
import Control.Concurrent.MVar (newMVar, readMVar,
|
||||
@ -8,11 +7,16 @@ import Control.Monad.IO.Class (liftIO)
|
||||
import Prelude.Compat
|
||||
import Servant
|
||||
import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPI)
|
||||
import Test.Hspec (Spec, describe, it,
|
||||
shouldBe)
|
||||
import Test.Hspec (Spec, context,
|
||||
describe, it,
|
||||
pending, shouldBe)
|
||||
import Test.Hspec.Core.Spec (Arg, Example,
|
||||
Result (..),
|
||||
defaultParams,
|
||||
evaluateExample)
|
||||
|
||||
import Servant.QuickCheck
|
||||
import Servant.QuickCheck.Internal (genRequest, serverDoesntSatisfy)
|
||||
import Servant.QuickCheck.Internal (genRequest, Failure(..), serverDoesntSatisfy)
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
@ -28,6 +32,23 @@ serversEqualSpec = describe "serversEqual" $ do
|
||||
withServantServerAndContext api ctx server $ \burl2 -> do
|
||||
serversEqual api burl1 burl2 args bodyEquality
|
||||
|
||||
context "when servers are not equal" $ do
|
||||
|
||||
it "provides the failing requests in the error message" $ do
|
||||
Fail _ err <- withServantServer api2 server2 $ \burl1 ->
|
||||
withServantServer api2 server3 $ \burl2 -> do
|
||||
evalExample $ serversEqual api2 burl1 burl2 args bodyEquality
|
||||
let ServerEqualityFailure req _ _ = read err
|
||||
req `shouldBe` "failplz"
|
||||
|
||||
it "provides the failing responses in the error message" $ do
|
||||
Fail _ err <- withServantServer api2 server2 $ \burl1 ->
|
||||
withServantServer api2 server3 $ \burl2 -> do
|
||||
evalExample $ serversEqual api2 burl1 burl2 args bodyEquality
|
||||
let ServerEqualityFailure _ r1 r2 = read err
|
||||
r1 `shouldBe` "1"
|
||||
r2 `shouldBe` "2"
|
||||
|
||||
|
||||
serverSatisfiesSpec :: Spec
|
||||
serverSatisfiesSpec = describe "serverSatisfies" $ do
|
||||
@ -46,6 +67,9 @@ serverSatisfiesSpec = describe "serverSatisfies" $ do
|
||||
<%> notAllowedContainsAllowHeader
|
||||
<%> mempty)
|
||||
|
||||
context "when predicates are false" $
|
||||
it "fails with informative error messages" $ pending
|
||||
|
||||
isComprehensiveSpec :: Spec
|
||||
isComprehensiveSpec = describe "HasGenRequest" $ do
|
||||
|
||||
@ -72,12 +96,29 @@ server = do
|
||||
:<|> (liftIO $ readMVar mvar >>= return . length)
|
||||
:<|> (const $ return ())
|
||||
|
||||
|
||||
type API2 = "failplz" :> Get '[JSON] Int
|
||||
|
||||
api2 :: Proxy API2
|
||||
api2 = Proxy
|
||||
|
||||
server2 :: IO (Server API2)
|
||||
server2 = return $ return 1
|
||||
|
||||
server3 :: IO (Server API2)
|
||||
server3 = return $ return 2
|
||||
|
||||
ctx :: Context '[BasicAuthCheck ()]
|
||||
ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext
|
||||
------------------------------------------------------------------------------
|
||||
-- Utils
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
evalExample :: (Example e, Arg e ~ ()) => e -> IO Result
|
||||
evalExample e = evaluateExample e defaultParams ($ ()) progCallback
|
||||
where
|
||||
progCallback _ = return ()
|
||||
|
||||
args :: Args
|
||||
args = defaultArgs { maxSuccess = noOfTestCases }
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user