{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} #include "overlapping-compat.h" -- | -- Module : Servant.Mock -- Copyright : 2015 Alp Mestanogullari -- License : BSD3 -- -- Maintainer : Alp Mestanogullari -- Stability : experimental -- Portability : portable -- -- Automatically derive a mock webserver that implements some API type, -- just from the said API type's definition. -- -- Using this module couldn't be simpler. Given some API type, like: -- -- > type API = "user" :> Get '[JSON] User -- -- that describes your web application, all you have to do is define -- a 'Proxy' to it: -- -- > myAPI :: Proxy API -- > myAPI = Proxy -- -- and call 'mock', which has the following type: -- -- @ -- 'mock' :: 'HasMock' api context => 'Proxy' api -> 'Proxy' context -> 'Server' api -- @ -- -- What this says is, given some API type @api@ that it knows it can -- "mock", 'mock' hands you an implementation of the API type. It does so -- by having each request handler generate a random value of the -- appropriate type (@User@ in our case). All you need for this to work is -- to provide 'Arbitrary' instances for the data types returned as response -- bodies, hence appearing next to 'Delete', 'Get', 'Patch', 'Post' and 'Put'. -- -- To put this all to work and run the mock server, just call 'serve' on the -- result of 'mock' to get an 'Application' that you can then run with warp. -- -- @ -- main :: IO () -- main = Network.Wai.Handler.Warp.run 8080 $ -- 'serve' myAPI ('mock' myAPI Proxy) -- @ module Servant.Mock ( HasMock(..) ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif import Control.Monad.IO.Class import Data.ByteString.Lazy.Char8 (pack) import Data.Proxy import GHC.TypeLits import Network.HTTP.Types.Status import Network.Wai import Servant import Servant.API.ContentTypes import Test.QuickCheck.Arbitrary (Arbitrary (..), vector) import Test.QuickCheck.Gen (Gen, generate) -- | 'HasMock' defines an interpretation of API types -- than turns them into random-response-generating -- request handlers, hence providing an instance for -- all the combinators of the core /servant/ library. class HasServer api context => HasMock api context where -- | Calling this method creates request handlers of -- the right type to implement the API described by -- @api@ that just generate random response values of -- the right type. E.g: -- -- @ -- type API = "user" :> Get '[JSON] User -- :<|> "book" :> Get '[JSON] Book -- -- api :: Proxy API -- api = Proxy -- -- -- let's say we will start with the frontend, -- -- and hence need a placeholder server -- server :: Server API -- server = mock api Proxy -- @ -- -- What happens here is that @'Server' API@ -- actually "means" 2 request handlers, of the following types: -- -- @ -- getUser :: Handler User -- getBook :: Handler Book -- @ -- -- So under the hood, 'mock' uses the 'IO' bit to generate -- random values of type 'User' and 'Book' every time these -- endpoints are requested. mock :: Proxy api -> Proxy context -> Server api instance (HasMock a context, HasMock b context) => HasMock (a :<|> b) context where mock _ context = mock (Proxy :: Proxy a) context :<|> mock (Proxy :: Proxy b) context instance (KnownSymbol path, HasMock rest context) => HasMock (path :> rest) context where mock _ = mock (Proxy :: Proxy rest) instance (KnownSymbol s, FromHttpApiData a, HasMock rest context) => HasMock (Capture s a :> rest) context where mock _ context = \_ -> mock (Proxy :: Proxy rest) context #if MIN_VERSION_servant(0,8,1) instance (KnownSymbol s, FromHttpApiData a, HasMock rest context) => HasMock (CaptureAll s a :> rest) context where mock _ context = \_ -> mock (Proxy :: Proxy rest) context #endif instance (AllCTUnrender ctypes a, HasMock rest context) => HasMock (ReqBody ctypes a :> rest) context where mock _ context = \_ -> mock (Proxy :: Proxy rest) context instance HasMock rest context => HasMock (RemoteHost :> rest) context where mock _ context = \_ -> mock (Proxy :: Proxy rest) context instance HasMock rest context => HasMock (IsSecure :> rest) context where mock _ context = \_ -> mock (Proxy :: Proxy rest) context instance HasMock rest context => HasMock (Vault :> rest) context where mock _ context = \_ -> mock (Proxy :: Proxy rest) context instance HasMock rest context => HasMock (HttpVersion :> rest) context where mock _ context = \_ -> mock (Proxy :: Proxy rest) context instance (KnownSymbol s, FromHttpApiData a, HasMock rest context) => HasMock (QueryParam s a :> rest) context where mock _ context = \_ -> mock (Proxy :: Proxy rest) context instance (KnownSymbol s, FromHttpApiData a, HasMock rest context) => HasMock (QueryParams s a :> rest) context where mock _ context = \_ -> mock (Proxy :: Proxy rest) context instance (KnownSymbol s, HasMock rest context) => HasMock (QueryFlag s :> rest) context where mock _ context = \_ -> mock (Proxy :: Proxy rest) context instance (KnownSymbol h, FromHttpApiData a, HasMock rest context) => HasMock (Header h a :> rest) context where mock _ context = \_ -> mock (Proxy :: Proxy rest) context instance (Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a) => HasMock (Verb method status ctypes a) context where mock _ _ = mockArbitrary instance OVERLAPPING_ (GetHeaders (Headers headerTypes a), Arbitrary (HList headerTypes), Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a) => HasMock (Verb method status ctypes (Headers headerTypes a)) context where mock _ _ = mockArbitrary instance HasMock Raw context where #if MIN_VERSION_servant(0,11,0) mock _ _ = Tagged $ \_req respond -> do #else mock _ _ = \_req respond -> do #endif bdy <- genBody respond $ responseLBS status200 [] bdy where genBody = pack <$> generate (vector 100 :: Gen [Char]) #if MIN_VERSION_servant(0,11,0) instance HasMock EmptyAPI context where mock _ _ = emptyServer #endif instance (HasContextEntry context (NamedContext name subContext), HasMock rest subContext) => HasMock (WithNamedContext name subContext rest) context where mock _ _ = mock (Proxy :: Proxy rest) (Proxy :: Proxy subContext) mockArbitrary :: (MonadIO m, Arbitrary a) => m a mockArbitrary = liftIO (generate arbitrary) -- utility instance instance (Arbitrary (HList ls), Arbitrary a) => Arbitrary (Headers ls a) where arbitrary = Headers <$> arbitrary <*> arbitrary instance Arbitrary (HList '[]) where arbitrary = pure HNil instance (Arbitrary a, Arbitrary (HList hs)) => Arbitrary (HList (Header h a ': hs)) where arbitrary = HCons <$> fmap Header arbitrary <*> arbitrary instance Arbitrary NoContent where arbitrary = pure NoContent