@@ -0,0 +1,109 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE TypeFamilies #-}
3+{-# LANGUAGE TypeOperators #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7+module Servant.Mock ( HasMock(..) ) where
8+
9+import Control.Monad.IO.Class
10+import Data.ByteString.Lazy.Char8 (pack)
11+import Data.Proxy
12+import GHC.TypeLits
13+import Network.HTTP.Types.Status
14+import Network.Wai
15+import Servant
16+import Servant.API.ContentTypes
17+import Test.QuickCheck.Arbitrary (Arbitrary(..), vector)
18+import Test.QuickCheck.Gen (Gen, generate)
19+
20+class HasServer api => HasMock api where
21+ mock :: Proxy api -> Server api
22+
23+instance (HasMock a, HasMock b) => HasMock (a :<|> b) where
24+ mock _ = mock (Proxy :: Proxy a) :<|> mock (Proxy :: Proxy b)
25+
26+instance (KnownSymbol path, HasMock rest) => HasMock (path :> rest) where
27+ mock _ = mock (Proxy :: Proxy rest)
28+
29+instance (KnownSymbol s, FromText a, HasMock rest) => HasMock (Capture s a :> rest) where
30+ mock _ = \_ -> mock (Proxy :: Proxy rest)
31+
32+instance (AllCTUnrender ctypes a, HasMock rest) => HasMock (ReqBody ctypes a :> rest) where
33+ mock _ = \_ -> mock (Proxy :: Proxy rest)
34+
35+instance HasMock rest => HasMock (RemoteHost :> rest) where
36+ mock _ = \_ -> mock (Proxy :: Proxy rest)
37+
38+instance HasMock rest => HasMock (IsSecure :> rest) where
39+ mock _ = \_ -> mock (Proxy :: Proxy rest)
40+
41+instance HasMock rest => HasMock (Vault :> rest) where
42+ mock _ = \_ -> mock (Proxy :: Proxy rest)
43+
44+instance HasMock rest => HasMock (HttpVersion :> rest) where
45+ mock _ = \_ -> mock (Proxy :: Proxy rest)
46+
47+instance (KnownSymbol s, FromText a, HasMock rest)
48+ => HasMock (QueryParam s a :> rest) where
49+ mock _ = \_ -> mock (Proxy :: Proxy rest)
50+
51+instance (KnownSymbol s, FromText a, HasMock rest)
52+ => HasMock (QueryParams s a :> rest) where
53+ mock _ = \_ -> mock (Proxy :: Proxy rest)
54+
55+instance (KnownSymbol s, HasMock rest) => HasMock (QueryFlag s :> rest) where
56+ mock _ = \_ -> mock (Proxy :: Proxy rest)
57+
58+instance (KnownSymbol s, FromText a, HasMock rest)
59+ => HasMock (MatrixParam s a :> rest) where
60+ mock _ = \_ -> mock (Proxy :: Proxy rest)
61+
62+instance (KnownSymbol s, FromText a, HasMock rest)
63+ => HasMock (MatrixParams s a :> rest) where
64+ mock _ = \_ -> mock (Proxy :: Proxy rest)
65+
66+instance (KnownSymbol s, HasMock rest) => HasMock (MatrixFlag s :> rest) where
67+ mock _ = \_ -> mock (Proxy :: Proxy rest)
68+
69+instance (KnownSymbol h, FromText a, HasMock rest) => HasMock (Header h a :> rest) where
70+ mock _ = \_ -> mock (Proxy :: Proxy rest)
71+
72+instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Delete ctypes a) where
73+ mock _ = mockArbitrary
74+
75+instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Get ctypes a) where
76+ mock _ = mockArbitrary
77+
78+instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Patch ctypes a) where
79+ mock _ = mockArbitrary
80+
81+instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Post ctypes a) where
82+ mock _ = mockArbitrary
83+
84+instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Put ctypes a) where
85+ mock _ = mockArbitrary
86+
87+instance HasMock Raw where
88+ mock _ = \req respond -> do
89+ bdy <- genBody
90+ respond $ responseLBS status200 [] bdy
91+
92+ where genBody = fmap pack $ generate (vector 100 :: Gen [Char])
93+
94+mockArbitrary :: (MonadIO m, Arbitrary a) => m a
95+mockArbitrary = liftIO (generate arbitrary)
96+
97+-- utility instance
98+instance (Arbitrary (HList ls), Arbitrary a)
99+ => Arbitrary (Headers ls a) where
100+ arbitrary = Headers <$> arbitrary <*> arbitrary
101+
102+instance Arbitrary (HList '[]) where
103+ arbitrary = pure HNil
104+
105+instance (Arbitrary a, Arbitrary (HList hs))
106+ => Arbitrary (HList (Header h a ': hs)) where
107+ arbitrary = HCons <$> fmap Header arbitrary <*> arbitrary
108+
109+