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