{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# 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 import Prelude () import Prelude.Compat 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 Servant.API.Modifiers 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, SBoolI (FoldLenient mods)) => HasMock (Capture' mods s a :> rest) context where mock _ context = \_ -> mock (Proxy :: Proxy rest) context instance (KnownSymbol s, FromHttpApiData a, HasMock rest context) => HasMock (CaptureAll s a :> rest) context where mock _ context = \_ -> mock (Proxy :: Proxy rest) context instance (AllCTUnrender ctypes a, HasMock rest context, SBoolI (FoldLenient mods)) => HasMock (ReqBody' mods ctypes a :> rest) context where mock _ context = \_ -> mock (Proxy :: Proxy rest) context -- | @since 0.8.5 instance (MimeUnrender ctype chunk, FramingUnrender fr, FromSourceIO chunk a, HasMock rest context) => HasMock (StreamBody' mods fr ctype 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, SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)) => HasMock (QueryParam' mods 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, SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)) => HasMock (Header' mods 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 (ReflectMethod method) => HasMock (NoContentVerb method) context where mock _ _ = mockArbitrary instance (Arbitrary a, KnownNat status, ReflectMethod method, MimeRender ctype chunk, FramingRender fr, ToSourceIO chunk a) => HasMock (Stream method status fr ctype 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 mock _ _ = Tagged $ \_req respond -> do bdy <- genBody respond $ responseLBS status200 [] bdy where genBody = pack <$> generate (vector 100 :: Gen [Char]) instance HasMock EmptyAPI context where mock _ _ = emptyServer instance HasMock api context => HasMock (Summary d :> api) context where mock _ context = mock (Proxy :: Proxy api) context instance HasMock api context => HasMock (Description d :> api) context where mock _ context = mock (Proxy :: Proxy api) context 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