mirror of
https://github.com/ilyakooo0/servant-quickcheck.git
synced 2024-08-16 22:00:32 +03:00
Get an error message in.
This commit is contained in:
parent
70fed09866
commit
b7df33fbe8
@ -24,6 +24,7 @@ library
|
||||
, Servant.QuickCheck.Internal.HasGenRequest
|
||||
, Servant.QuickCheck.Internal.QuickCheck
|
||||
, Servant.QuickCheck.Internal.Equality
|
||||
, Servant.QuickCheck.Internal.ErrorTypes
|
||||
build-depends: base >=4.7 && <4.9
|
||||
, base-compat == 0.9.*
|
||||
, QuickCheck == 2.8.*
|
||||
|
@ -4,3 +4,4 @@ import Servant.QuickCheck.Internal.HasGenRequest as X
|
||||
import Servant.QuickCheck.Internal.Predicates as X
|
||||
import Servant.QuickCheck.Internal.QuickCheck as X
|
||||
import Servant.QuickCheck.Internal.Equality as X
|
||||
import Servant.QuickCheck.Internal.ErrorTypes as X
|
||||
|
@ -1,6 +1,9 @@
|
||||
module Servant.QuickCheck.Internal.ErrorTypes where
|
||||
|
||||
import Text.PrettyPrint
|
||||
import Prelude.Compat
|
||||
import Data.String (IsString(fromString))
|
||||
import GHC.Generics (Generic)
|
||||
|
||||
data Request = Request
|
||||
{ requestBody :: String
|
||||
@ -8,12 +11,12 @@ data Request = Request
|
||||
, requestUrl :: String
|
||||
} deriving (Eq, Show, Read, Generic)
|
||||
|
||||
prettyReq :: Doc
|
||||
prettyReq :: Request -> Doc
|
||||
prettyReq r =
|
||||
text "Request:" $ nest 5 $
|
||||
text "URL:" <+> text (nest 5 $ requestUrl r)
|
||||
$$ text "Headers:" <+>
|
||||
$$ text "Body:" <+> text (nest 5 $ requestBody r)
|
||||
text "Request:" $$ (nest 5 $
|
||||
text "URL:" <+> (nest 5 $ text $ requestUrl r)
|
||||
$$ text "Headers:" <+> (nest 5 $ hsep $ text <$> requestHeaders r)
|
||||
$$ text "Body:" <+> (nest 5 $ text $ requestBody r))
|
||||
|
||||
instance IsString Request where
|
||||
fromString url = Request "" [] url
|
||||
@ -30,8 +33,8 @@ instance IsString Response where
|
||||
data Failure
|
||||
= PredicateFailure String Request Response
|
||||
| ServerEqualityFailure Request Response Response
|
||||
deriving (Eq, Show, Read, Generic)
|
||||
deriving (Eq, Read, Generic)
|
||||
|
||||
instance Show Failure where
|
||||
show (PredicateFailure pred req resp)
|
||||
= "Predicate failed for " <> pred <> "
|
||||
= "Predicate failed for " ++ pred
|
||||
|
@ -29,7 +29,7 @@ instance (HasGenRequest a, HasGenRequest b) => HasGenRequest (a :<|> b) where
|
||||
instance (KnownSymbol path, HasGenRequest b) => HasGenRequest (path :> b) where
|
||||
genRequest _ = do
|
||||
old' <- old
|
||||
return $ \burl -> let r = old' burl in r { path = new <> "/" <> path r }
|
||||
return $ \burl -> let r = old' burl in r { path = new <> path r }
|
||||
where
|
||||
old = genRequest (Proxy :: Proxy b)
|
||||
new = cs $ symbolVal (Proxy :: Proxy path)
|
||||
@ -39,7 +39,7 @@ instance (Arbitrary c, HasGenRequest b, ToHttpApiData c )
|
||||
genRequest _ = do
|
||||
old' <- old
|
||||
new' <- toUrlPiece <$> new
|
||||
return $ \burl -> let r = old' burl in r { path = cs new' <> "/" <> path r }
|
||||
return $ \burl -> let r = old' burl in r { path = cs new' <> path r }
|
||||
where
|
||||
old = genRequest (Proxy :: Proxy b)
|
||||
new = arbitrary :: Gen c
|
||||
|
@ -15,7 +15,9 @@ import System.IO.Unsafe (unsafePerformIO)
|
||||
import Test.Hspec (Expectation, expectationFailure)
|
||||
import Test.QuickCheck (Args (..), Result (..),
|
||||
quickCheckWithResult)
|
||||
import Test.QuickCheck.Monadic (assert, forAllM, monadicIO, run)
|
||||
import Test.QuickCheck.Monadic (assert, forAllM, monadicIO, run, monitor)
|
||||
import Test.QuickCheck.Property (counterexample)
|
||||
import Control.Monad (unless)
|
||||
|
||||
import Servant.QuickCheck.Internal.Equality
|
||||
import Servant.QuickCheck.Internal.HasGenRequest
|
||||
@ -61,7 +63,10 @@ serversEqual api burl1 burl2 args req = do
|
||||
r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \(req1, req2) -> do
|
||||
resp1 <- run $ C.httpLbs (noCheckStatus req1) defManager
|
||||
resp2 <- run $ C.httpLbs (noCheckStatus req2) defManager
|
||||
assert $ getResponseEquality req resp1 resp2
|
||||
unless (getResponseEquality req resp1 resp2) $ do
|
||||
monitor (counterexample "hi" )
|
||||
assert False
|
||||
|
||||
case r of
|
||||
Success {} -> return ()
|
||||
GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
|
||||
|
@ -34,20 +34,27 @@ serversEqualSpec = describe "serversEqual" $ do
|
||||
|
||||
context "when servers are not equal" $ do
|
||||
|
||||
it "provides the failing requests in the error message" $ do
|
||||
e <- withServantServer api2 server2 $ \burl1 ->
|
||||
withServantServer api2 server3 $ \burl2 -> do
|
||||
evalExample $ serversEqual api2 burl1 burl2 args bodyEquality
|
||||
e `shouldBe` e
|
||||
|
||||
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
|
||||
print err
|
||||
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"
|
||||
{-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
|
||||
|
Loading…
Reference in New Issue
Block a user