mirror of
https://github.com/ilyakooo0/servant-quickcheck.git
synced 2024-08-17 06:10:27 +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
|
||||
, process == 1.2.*
|
||||
, temporary == 1.2.*
|
||||
, case-insensitive
|
||||
, hspec
|
||||
, text == 1.*
|
||||
hs-source-dirs: src
|
||||
@ -74,6 +75,7 @@ test-suite spec
|
||||
, warp
|
||||
, servant-server
|
||||
, servant-client
|
||||
, servant
|
||||
, transformers
|
||||
, QuickCheck
|
||||
, quickcheck-io
|
||||
|
@ -36,6 +36,7 @@ module Servant.QuickCheck
|
||||
, (<%>)
|
||||
, Predicates
|
||||
, not500
|
||||
, onlyJsonObjects
|
||||
|
||||
-- ** Re-exports
|
||||
, BaseUrl(..)
|
||||
|
@ -82,6 +82,31 @@ instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
|
||||
param = cs $ symbolVal (Proxy :: Proxy x)
|
||||
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)
|
||||
=> HasGenRequest (Verb (method :: k) (status :: Nat) (cts :: [*]) a) where
|
||||
genRequest _ = return $ \burl -> def
|
||||
@ -91,3 +116,17 @@ instance (ReflectMethod 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
|
||||
|
||||
import Data.Monoid ((<>))
|
||||
import GHC.Generics (Generic)
|
||||
import Control.Monad
|
||||
import Network.HTTP.Client (Request, Response, responseStatus, Manager, httpLbs)
|
||||
import Network.HTTP.Types (status500)
|
||||
import Control.Monad
|
||||
import Data.Aeson (Object, decode)
|
||||
import Data.Bifunctor (Bifunctor (..))
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import Data.Bifunctor (Bifunctor(..))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.ByteString as SBS
|
||||
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
|
||||
-- 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 "not500" (\resp -> not $ responseStatus resp == status500)
|
||||
|
||||
{-
|
||||
-- | Returning anything other than an object when returning JSON is considered
|
||||
-- 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
|
||||
-- objects (and not arrays, strings, numbers, or booleans) at the top level.
|
||||
onlyJsonObjects :: Response b -> IO Bool
|
||||
onlyJsonObjects :: ResponsePredicate Text Bool
|
||||
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@
|
||||
-- header with a link to the created resource.
|
||||
--
|
||||
@ -42,9 +48,9 @@ onlyJsonObjects
|
||||
-- requests.
|
||||
--
|
||||
-- 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
|
||||
= ResponsePredicate "createContainsValidLocation" _
|
||||
= ResponsePredicate "createContainsValidLocation" (\resp ->
|
||||
|
||||
getsHaveLastModifiedHeader :: Response b -> IO Bool
|
||||
getsHaveLastModifiedHeader
|
||||
@ -221,3 +227,8 @@ finishPredicates p req mgr = do
|
||||
resps <- reqResps (reqPreds p) req mgr
|
||||
let preds = reqPred (reqPreds p) <> respPreds p
|
||||
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 Test.Hspec
|
||||
import Test.QuickCheck
|
||||
import Servant.API.Internal.Test.ComprehensiveAPI
|
||||
|
||||
import Servant.QuickCheck
|
||||
|
||||
import Servant.QuickCheck.Internal (genRequest)
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
serversEqualSpec
|
||||
serverSatisfiesSpec
|
||||
isComprehensiveSpec
|
||||
|
||||
serversEqualSpec :: Spec
|
||||
serversEqualSpec = describe "serversEqual" $ do
|
||||
@ -32,6 +36,17 @@ serverSatisfiesSpec = describe "serverSatisfies" $ do
|
||||
withServantServer api server $ \burl ->
|
||||
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
|
||||
|
Loading…
Reference in New Issue
Block a user