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