94 lines
3.4 KiB
Haskell
94 lines
3.4 KiB
Haskell
{-# LANGUAGE PolyKinds #-}
|
|
module Servant.QuickCheck.Internal.HasGenRequest where
|
|
|
|
import Data.Default.Class (def)
|
|
import Data.Monoid ((<>))
|
|
import Data.String (fromString)
|
|
import Data.String.Conversions (cs)
|
|
import GHC.TypeLits
|
|
import Network.HTTP.Client (Request, RequestBody (..), host,
|
|
method, path, port, requestBody,
|
|
requestHeaders, secure, queryString)
|
|
import Network.HTTP.Media (renderHeader)
|
|
import Servant
|
|
import Servant.API.ContentTypes
|
|
import Servant.Client (BaseUrl (..), Scheme (..))
|
|
import Test.QuickCheck
|
|
|
|
|
|
class HasGenRequest a where
|
|
genRequest :: Proxy a -> Gen (BaseUrl -> Request)
|
|
|
|
instance (HasGenRequest a, HasGenRequest b) => HasGenRequest (a :<|> b) where
|
|
genRequest _
|
|
= oneof [ genRequest (Proxy :: Proxy a)
|
|
, genRequest (Proxy :: Proxy b)
|
|
]
|
|
|
|
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 }
|
|
where
|
|
old = genRequest (Proxy :: Proxy b)
|
|
new = cs $ symbolVal (Proxy :: Proxy path)
|
|
|
|
instance (Arbitrary c, HasGenRequest b, ToHttpApiData c )
|
|
=> HasGenRequest (Capture x c :> b) where
|
|
genRequest _ = do
|
|
old' <- old
|
|
new' <- toUrlPiece <$> new
|
|
return $ \burl -> let r = old' burl in r { path = cs new' <> "/" <> path r }
|
|
where
|
|
old = genRequest (Proxy :: Proxy b)
|
|
new = arbitrary :: Gen c
|
|
|
|
instance (Arbitrary c, KnownSymbol h, HasGenRequest b, ToHttpApiData c)
|
|
=> HasGenRequest (Header h c :> b) where
|
|
genRequest _ = do
|
|
old' <- old
|
|
new' <- toUrlPiece <$> new
|
|
return $ \burl -> let r = old' burl in r {
|
|
requestHeaders = (hdr, cs new') : requestHeaders r }
|
|
where
|
|
old = genRequest (Proxy :: Proxy b)
|
|
hdr = fromString $ symbolVal (Proxy :: Proxy h)
|
|
new = arbitrary :: Gen c
|
|
|
|
instance (AllMimeRender x c, Arbitrary c, HasGenRequest b)
|
|
=> HasGenRequest (ReqBody x c :> b) where
|
|
genRequest _ = do
|
|
old' <- old
|
|
new' <- new
|
|
(ct, bd) <- elements $ allMimeRender (Proxy :: Proxy x) new'
|
|
return $ \burl -> let r = old' burl in r {
|
|
requestBody = RequestBodyLBS bd
|
|
, requestHeaders = ("Content-Type", renderHeader ct) : requestHeaders r
|
|
}
|
|
where
|
|
old = genRequest (Proxy :: Proxy b)
|
|
new = arbitrary :: Gen c
|
|
|
|
instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
|
|
=> HasGenRequest (QueryParam x c :> b) where
|
|
genRequest _ = do
|
|
new' <- new
|
|
old' <- old
|
|
return $ \burl -> let r = old' burl in r {
|
|
queryString = queryString r
|
|
<> param <> "=" <> cs (toQueryParam new') }
|
|
where
|
|
old = genRequest (Proxy :: Proxy b)
|
|
param = cs $ symbolVal (Proxy :: Proxy x)
|
|
new = arbitrary :: Gen c
|
|
|
|
instance (ReflectMethod method)
|
|
=> HasGenRequest (Verb (method :: k) (status :: Nat) (cts :: [*]) a) where
|
|
genRequest _ = return $ \burl -> def
|
|
{ host = cs $ baseUrlHost burl
|
|
, port = baseUrlPort burl
|
|
, secure = baseUrlScheme burl == Https
|
|
, method = reflectMethod (Proxy :: Proxy method)
|
|
}
|
|
|