mirror of
https://github.com/ilyakooo0/servant-quickcheck.git
synced 2024-09-11 18:37:09 +03:00
Comprehensive instances for HasGenRequest.
This commit is contained in:
parent
1c1c3dc9bd
commit
3189902c4b
@ -41,6 +41,7 @@ library
|
|||||||
, warp >= 3.2.4 && < 3.3
|
, warp >= 3.2.4 && < 3.3
|
||||||
, process == 1.2.*
|
, process == 1.2.*
|
||||||
, temporary == 1.2.*
|
, temporary == 1.2.*
|
||||||
|
, case-insensitive
|
||||||
, hspec
|
, hspec
|
||||||
, text == 1.*
|
, text == 1.*
|
||||||
hs-source-dirs: src
|
hs-source-dirs: src
|
||||||
@ -74,6 +75,7 @@ test-suite spec
|
|||||||
, warp
|
, warp
|
||||||
, servant-server
|
, servant-server
|
||||||
, servant-client
|
, servant-client
|
||||||
|
, servant
|
||||||
, transformers
|
, transformers
|
||||||
, QuickCheck
|
, QuickCheck
|
||||||
, quickcheck-io
|
, quickcheck-io
|
||||||
|
@ -36,6 +36,7 @@ module Servant.QuickCheck
|
|||||||
, (<%>)
|
, (<%>)
|
||||||
, Predicates
|
, Predicates
|
||||||
, not500
|
, not500
|
||||||
|
, onlyJsonObjects
|
||||||
|
|
||||||
-- ** Re-exports
|
-- ** Re-exports
|
||||||
, BaseUrl(..)
|
, BaseUrl(..)
|
||||||
|
@ -82,6 +82,31 @@ instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
|
|||||||
param = cs $ symbolVal (Proxy :: Proxy x)
|
param = cs $ symbolVal (Proxy :: Proxy x)
|
||||||
new = arbitrary :: Gen c
|
new = arbitrary :: Gen c
|
||||||
|
|
||||||
|
instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
|
||||||
|
=> HasGenRequest (QueryParams x c :> b) where
|
||||||
|
genRequest _ = do
|
||||||
|
new' <- new
|
||||||
|
old' <- old
|
||||||
|
return $ \burl -> let r = old' burl in r {
|
||||||
|
queryString = queryString r
|
||||||
|
<> if length new' > 0 then fold (toParam <$> new') else ""}
|
||||||
|
where
|
||||||
|
old = genRequest (Proxy :: Proxy b)
|
||||||
|
param = cs $ symbolVal (Proxy :: Proxy x)
|
||||||
|
new = arbitrary :: Gen [c]
|
||||||
|
toParam c = param <> "[]=" <> cs (toQueryParam c)
|
||||||
|
fold = foldr1 (\a b -> a <> "&" <> b)
|
||||||
|
|
||||||
|
instance (KnownSymbol x, HasGenRequest b)
|
||||||
|
=> HasGenRequest (QueryFlag x :> b) where
|
||||||
|
genRequest _ = do
|
||||||
|
old' <- old
|
||||||
|
return $ \burl -> let r = old' burl in r {
|
||||||
|
queryString = queryString r <> param <> "=" }
|
||||||
|
where
|
||||||
|
old = genRequest (Proxy :: Proxy b)
|
||||||
|
param = cs $ symbolVal (Proxy :: Proxy x)
|
||||||
|
|
||||||
instance (ReflectMethod method)
|
instance (ReflectMethod method)
|
||||||
=> HasGenRequest (Verb (method :: k) (status :: Nat) (cts :: [*]) a) where
|
=> HasGenRequest (Verb (method :: k) (status :: Nat) (cts :: [*]) a) where
|
||||||
genRequest _ = return $ \burl -> def
|
genRequest _ = return $ \burl -> def
|
||||||
@ -91,3 +116,17 @@ instance (ReflectMethod method)
|
|||||||
, method = reflectMethod (Proxy :: Proxy method)
|
, method = reflectMethod (Proxy :: Proxy method)
|
||||||
}
|
}
|
||||||
|
|
||||||
|
instance (HasGenRequest a) => HasGenRequest (RemoteHost :> a) where
|
||||||
|
genRequest _ = genRequest (Proxy :: Proxy a)
|
||||||
|
|
||||||
|
instance (HasGenRequest a) => HasGenRequest (IsSecure :> a) where
|
||||||
|
genRequest _ = genRequest (Proxy :: Proxy a)
|
||||||
|
|
||||||
|
instance (HasGenRequest a) => HasGenRequest (HttpVersion :> a) where
|
||||||
|
genRequest _ = genRequest (Proxy :: Proxy a)
|
||||||
|
|
||||||
|
instance (HasGenRequest a) => HasGenRequest (Vault :> a) where
|
||||||
|
genRequest _ = genRequest (Proxy :: Proxy a)
|
||||||
|
|
||||||
|
instance (HasGenRequest a) => HasGenRequest (WithNamedContext x y a) where
|
||||||
|
genRequest _ = genRequest (Proxy :: Proxy a)
|
||||||
|
@ -1,13 +1,17 @@
|
|||||||
module Servant.QuickCheck.Internal.Predicates where
|
module Servant.QuickCheck.Internal.Predicates where
|
||||||
|
|
||||||
import Data.Monoid ((<>))
|
import Control.Monad
|
||||||
import GHC.Generics (Generic)
|
import Data.Aeson (Object, decode)
|
||||||
import Control.Monad
|
import Data.Bifunctor (Bifunctor (..))
|
||||||
import Network.HTTP.Client (Request, Response, responseStatus, Manager, httpLbs)
|
|
||||||
import Network.HTTP.Types (status500)
|
|
||||||
import qualified Data.ByteString.Lazy as LBS
|
import qualified Data.ByteString.Lazy as LBS
|
||||||
import Data.Bifunctor (Bifunctor(..))
|
import qualified Data.ByteString as SBS
|
||||||
import Data.Text (Text)
|
import Data.CaseInsensitive (mk)
|
||||||
|
import Data.Monoid ((<>))
|
||||||
|
import Data.Text (Text)
|
||||||
|
import GHC.Generics (Generic)
|
||||||
|
import Network.HTTP.Client (Manager, Request, Response, httpLbs,
|
||||||
|
responseBody, responseStatus, responseHeaders)
|
||||||
|
import Network.HTTP.Types (status500)
|
||||||
|
|
||||||
-- | @500 Internal Server Error@ should be avoided - it may represent some
|
-- | @500 Internal Server Error@ should be avoided - it may represent some
|
||||||
-- issue with the application code, and it moreover gives the client little
|
-- issue with the application code, and it moreover gives the client little
|
||||||
@ -17,7 +21,6 @@ import Data.Text (Text)
|
|||||||
not500 :: ResponsePredicate Text Bool
|
not500 :: ResponsePredicate Text Bool
|
||||||
not500 = ResponsePredicate "not500" (\resp -> not $ responseStatus resp == status500)
|
not500 = ResponsePredicate "not500" (\resp -> not $ responseStatus resp == status500)
|
||||||
|
|
||||||
{-
|
|
||||||
-- | Returning anything other than an object when returning JSON is considered
|
-- | Returning anything other than an object when returning JSON is considered
|
||||||
-- bad practice, as:
|
-- bad practice, as:
|
||||||
--
|
--
|
||||||
@ -30,10 +33,13 @@ not500 = ResponsePredicate "not500" (\resp -> not $ responseStatus resp == statu
|
|||||||
--
|
--
|
||||||
-- This function checks that any @application/json@ responses only return JSON
|
-- This function checks that any @application/json@ responses only return JSON
|
||||||
-- objects (and not arrays, strings, numbers, or booleans) at the top level.
|
-- objects (and not arrays, strings, numbers, or booleans) at the top level.
|
||||||
onlyJsonObjects :: Response b -> IO Bool
|
onlyJsonObjects :: ResponsePredicate Text Bool
|
||||||
onlyJsonObjects
|
onlyJsonObjects
|
||||||
= ResponsePredicate "onlyJsonObjects" _
|
= ResponsePredicate "onlyJsonObjects" (\resp -> case decode (responseBody resp) of
|
||||||
|
Nothing -> False
|
||||||
|
Just (_ :: Object) -> True)
|
||||||
|
|
||||||
|
{-
|
||||||
-- | When creating a new resource, it is good practice to provide a @Location@
|
-- | When creating a new resource, it is good practice to provide a @Location@
|
||||||
-- header with a link to the created resource.
|
-- header with a link to the created resource.
|
||||||
--
|
--
|
||||||
@ -42,9 +48,9 @@ onlyJsonObjects
|
|||||||
-- requests.
|
-- requests.
|
||||||
--
|
--
|
||||||
-- References: <RFC 7231, Section 6.3.2 https://tools.ietf.org/html/rfc7231#section-6.3.2>
|
-- References: <RFC 7231, Section 6.3.2 https://tools.ietf.org/html/rfc7231#section-6.3.2>
|
||||||
createContainsValidLocation :: Response b -> IO Bool
|
createContainsValidLocation :: ResponsePredicate Text Bool
|
||||||
createContainsValidLocation
|
createContainsValidLocation
|
||||||
= ResponsePredicate "createContainsValidLocation" _
|
= ResponsePredicate "createContainsValidLocation" (\resp ->
|
||||||
|
|
||||||
getsHaveLastModifiedHeader :: Response b -> IO Bool
|
getsHaveLastModifiedHeader :: Response b -> IO Bool
|
||||||
getsHaveLastModifiedHeader
|
getsHaveLastModifiedHeader
|
||||||
@ -221,3 +227,8 @@ finishPredicates p req mgr = do
|
|||||||
resps <- reqResps (reqPreds p) req mgr
|
resps <- reqResps (reqPreds p) req mgr
|
||||||
let preds = reqPred (reqPreds p) <> respPreds p
|
let preds = reqPred (reqPreds p) <> respPreds p
|
||||||
return $ mconcat [respPred preds r | r <- resps ]
|
return $ mconcat [respPred preds r | r <- resps ]
|
||||||
|
|
||||||
|
-- * helpers
|
||||||
|
|
||||||
|
hasHeader :: SBS.ByteString -> Response b -> Bool
|
||||||
|
hasHeader hdr r = mk hdr `elem` (fst <$> responseHeaders r)
|
||||||
|
@ -8,13 +8,17 @@ import Data.Proxy
|
|||||||
import Servant
|
import Servant
|
||||||
import Test.Hspec
|
import Test.Hspec
|
||||||
import Test.QuickCheck
|
import Test.QuickCheck
|
||||||
|
import Servant.API.Internal.Test.ComprehensiveAPI
|
||||||
|
|
||||||
import Servant.QuickCheck
|
import Servant.QuickCheck
|
||||||
|
|
||||||
|
import Servant.QuickCheck.Internal (genRequest)
|
||||||
|
|
||||||
spec :: Spec
|
spec :: Spec
|
||||||
spec = do
|
spec = do
|
||||||
serversEqualSpec
|
serversEqualSpec
|
||||||
serverSatisfiesSpec
|
serverSatisfiesSpec
|
||||||
|
isComprehensiveSpec
|
||||||
|
|
||||||
serversEqualSpec :: Spec
|
serversEqualSpec :: Spec
|
||||||
serversEqualSpec = describe "serversEqual" $ do
|
serversEqualSpec = describe "serversEqual" $ do
|
||||||
@ -32,6 +36,17 @@ serverSatisfiesSpec = describe "serverSatisfies" $ do
|
|||||||
withServantServer api server $ \burl ->
|
withServantServer api server $ \burl ->
|
||||||
serverSatisfies api burl args (not500 <%> mempty)
|
serverSatisfies api burl args (not500 <%> mempty)
|
||||||
|
|
||||||
|
it "fails for false predicates" $ do
|
||||||
|
withServantServer api server $ \burl ->
|
||||||
|
serverSatisfies api burl args (onlyJsonObjects <%> mempty)
|
||||||
|
|
||||||
|
isComprehensiveSpec :: Spec
|
||||||
|
isComprehensiveSpec = describe "HasGenRequest" $ do
|
||||||
|
|
||||||
|
it "has instances for all 'servant' combinators" $ do
|
||||||
|
let _g = genRequest comprehensiveAPI
|
||||||
|
True `shouldBe` True -- This is a type-level check
|
||||||
|
|
||||||
|
|
||||||
------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
||||||
-- APIs
|
-- APIs
|
||||||
|
Loading…
Reference in New Issue
Block a user