@@ -0,0 +1,177 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TypeFamilies #-}
7+{-# LANGUAGE TypeOperators #-}
8+-- |
9+-- Module : Servant.Mock
10+-- Copyright : 2015 Alp Mestanogullari
11+-- License : BSD3
12+--
13+-- Maintainer : Alp Mestanogullari <alpmestan@gmail.com>
14+-- Stability : experimental
15+-- Portability : portable
16+--
17+-- Automatically derive a mock webserver that implements some API type,
18+-- just from the said API type's definition.
19+--
20+-- Using this module couldn't be simpler. Given some API type, like:
21+--
22+-- > type API = "user" :> Get '[JSON] User
23+--
24+-- that describes your web application, all you have to do is define
25+-- a 'Proxy' to it:
26+--
27+-- > myAPI :: Proxy API
28+-- > myAPI = Proxy
29+--
30+-- and call 'mock', which has the following type:
31+--
32+-- @
33+-- 'mock' :: 'HasMock' api => 'Proxy' api -> 'Server' api
34+-- @
35+--
36+-- What this says is, given some API type @api@ that it knows it can
37+-- "mock", 'mock' hands you an implementation of the API type. It does so
38+-- by having each request handler generate a random value of the
39+-- appropriate type (@User@ in our case). All you need for this to work is
40+-- to provide 'Arbitrary' instances for the data types returned as response
41+-- bodies, hence appearing next to 'Delete', 'Get', 'Patch', 'Post' and 'Put'.
42+--
43+-- To put this all to work and run the mock server, just call 'serve' on the
44+-- result of 'mock' to get an 'Application' that you can then run with warp.
45+--
46+-- @
47+-- main :: IO ()
48+-- main = Network.Wai.Handler.Warp.run 8080 $
49+-- 'serve' myAPI ('mock' myAPI)
50+-- @
51+module Servant.Mock ( HasMock(..) ) where
52+
53+#if !MIN_VERSION_base(4,8,0)
54+import Control.Applicative
55+#endif
56+import Control.Monad.IO.Class
57+import Data.ByteString.Lazy.Char8 (pack)
58+import Data.Proxy
59+import GHC.TypeLits
60+import Network.HTTP.Types.Status
61+import Network.Wai
62+import Servant
63+import Servant.API.ContentTypes
64+import Test.QuickCheck.Arbitrary (Arbitrary (..), vector)
65+import Test.QuickCheck.Gen (Gen, generate)
66+
67+-- | 'HasMock' defines an interpretation of API types
68+-- than turns them into random-response-generating
69+-- request handlers, hence providing an instance for
70+-- all the combinators of the core /servant/ library.
71+class HasServer api => HasMock api where
72+ -- | Calling this method creates request handlers of
73+ -- the right type to implement the API described by
74+ -- @api@ that just generate random response values of
75+ -- the right type. E.g:
76+ --
77+ -- @
78+ -- type API = "user" :> Get '[JSON] User
79+ -- :<|> "book" :> Get '[JSON] Book
80+ --
81+ -- api :: Proxy API
82+ -- api = Proxy
83+ --
84+ -- -- let's say we will start with the frontend,
85+ -- -- and hence need a placeholder server
86+ -- server :: Server API
87+ -- server = mock api
88+ -- @
89+ --
90+ -- What happens here is that @'Server' API@
91+ -- actually "means" 2 request handlers, of the following types:
92+ --
93+ -- @
94+ -- getUser :: EitherT ServantErr IO User
95+ -- getBook :: EitherT ServantErr IO Book
96+ -- @
97+ --
98+ -- So under the hood, 'mock' uses the 'IO' bit to generate
99+ -- random values of type 'User' and 'Book' every time these
100+ -- endpoints are requested.
101+ mock :: Proxy api -> Server api
102+
103+instance (HasMock a, HasMock b) => HasMock (a :<|> b) where
104+ mock _ = mock (Proxy :: Proxy a) :<|> mock (Proxy :: Proxy b)
105+
106+instance (KnownSymbol path, HasMock rest) => HasMock (path :> rest) where
107+ mock _ = mock (Proxy :: Proxy rest)
108+
109+instance (KnownSymbol s, FromText a, HasMock rest) => HasMock (Capture s a :> rest) where
110+ mock _ = \_ -> mock (Proxy :: Proxy rest)
111+
112+instance (AllCTUnrender ctypes a, HasMock rest) => HasMock (ReqBody ctypes a :> rest) where
113+ mock _ = \_ -> mock (Proxy :: Proxy rest)
114+
115+instance (KnownSymbol s, FromText a, HasMock rest)
116+ => HasMock (QueryParam s a :> rest) where
117+ mock _ = \_ -> mock (Proxy :: Proxy rest)
118+
119+instance (KnownSymbol s, FromText a, HasMock rest)
120+ => HasMock (QueryParams s a :> rest) where
121+ mock _ = \_ -> mock (Proxy :: Proxy rest)
122+
123+instance (KnownSymbol s, HasMock rest) => HasMock (QueryFlag s :> rest) where
124+ mock _ = \_ -> mock (Proxy :: Proxy rest)
125+
126+instance (KnownSymbol s, FromText a, HasMock rest)
127+ => HasMock (MatrixParam s a :> rest) where
128+ mock _ = \_ -> mock (Proxy :: Proxy rest)
129+
130+instance (KnownSymbol s, FromText a, HasMock rest)
131+ => HasMock (MatrixParams s a :> rest) where
132+ mock _ = \_ -> mock (Proxy :: Proxy rest)
133+
134+instance (KnownSymbol s, HasMock rest) => HasMock (MatrixFlag s :> rest) where
135+ mock _ = \_ -> mock (Proxy :: Proxy rest)
136+
137+instance (KnownSymbol h, FromText a, HasMock rest) => HasMock (Header h a :> rest) where
138+ mock _ = \_ -> mock (Proxy :: Proxy rest)
139+
140+instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Delete ctypes a) where
141+ mock _ = mockArbitrary
142+
143+instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Get ctypes a) where
144+ mock _ = mockArbitrary
145+
146+instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Patch ctypes a) where
147+ mock _ = mockArbitrary
148+
149+instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Post ctypes a) where
150+ mock _ = mockArbitrary
151+
152+instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Put ctypes a) where
153+ mock _ = mockArbitrary
154+
155+instance HasMock Raw where
156+ mock _ = \req respond -> do
157+ bdy <- genBody
158+ respond $ responseLBS status200 [] bdy
159+
160+ where genBody = pack <$> generate (vector 100 :: Gen [Char])
161+
162+mockArbitrary :: (MonadIO m, Arbitrary a) => m a
163+mockArbitrary = liftIO (generate arbitrary)
164+
165+-- utility instance
166+instance (Arbitrary (HList ls), Arbitrary a)
167+ => Arbitrary (Headers ls a) where
168+ arbitrary = Headers <$> arbitrary <*> arbitrary
169+
170+instance Arbitrary (HList '[]) where
171+ arbitrary = pure HNil
172+
173+instance (Arbitrary a, Arbitrary (HList hs))
174+ => Arbitrary (HList (Header h a ': hs)) where
175+ arbitrary = HCons <$> fmap Header arbitrary <*> arbitrary
176+
177+