@@ -4,12 +4,14 @@
44{-# LANGUAGE FlexibleInstances #-}
55{-# LANGUAGE GADTs #-}
66{-# LANGUAGE KindSignatures #-}
7+{-# LANGUAGE LambdaCase #-}
78{-# LANGUAGE MultiParamTypeClasses #-}
89{-# LANGUAGE OverloadedStrings #-}
910{-# LANGUAGE PolyKinds #-}
1011{-# LANGUAGE QuantifiedConstraints #-}
1112{-# LANGUAGE RankNTypes #-}
1213{-# LANGUAGE ScopedTypeVariables #-}
14+{-# LANGUAGE TupleSections #-}
1315{-# LANGUAGE TypeApplications #-}
1416{-# LANGUAGE TypeFamilies #-}
1517{-# LANGUAGE TypeOperators #-}
@@ -32,171 +34,189 @@ import Servant
3234import Servant.API
3335import Servant.API.ContentTypes (AllMimeRender, allMimeRender)
3436import Servant.Client
35−import Test.QuickCheck (Arbitrary, Gen, elements, frequency)
36−
37−class HasContextualGenRequest a b where
38− genContextualRequest :: Proxy a -> (Int, Gen (BaseUrl -> b -> Request))
39−
40−-- -- | Generatable is functionally equivalent to Arbitrary with a default.
41−-- -- It is separate because we want to allow overwriting at will.
42−-- class Generatable a where
43−-- generator :: Gen [a]
44−-- generator = pure []
45−
46−instance ( HasContextualGenRequest a st
47− , HasContextualGenRequest b st)
48− => HasContextualGenRequest (a :<|> b) st where
49− genContextualRequest _
50− = (lf + rf, frequency [l, r])
37+-- import Test.QuickCheck (Arbitrary, Gen, elements, frequency)
38+import Data.Dynamic (Dynamic)
39+import Data.Map.Strict (Map)
40+import Data.Maybe
41+import Data.Typeable (TypeRep)
42+import Hedgehog
43+import qualified Hedgehog.Gen as Gen
44+import Roboservant.Hedgehog
45+
46+class HasContextualGenRequest a where
47+ genContextualRequest :: Proxy a -> Map TypeRep Dynamic -> Maybe (Int, Gen ( BaseUrl -> Request))
48+
49+-- | Generatable is functionally equivalent to Arbitrary with a default.
50+-- It is separate because we want to allow overwriting at will.
51+class Generatable a where
52+ generator :: Gen [a]
53+ generator = pure []
54+
55+instance ( HasContextualGenRequest a
56+ , HasContextualGenRequest b)
57+ => HasContextualGenRequest (a :<|> b) where
58+ genContextualRequest _ store
59+ = case sub of
60+ [] -> Nothing
61+ _ -> Just (newfreq, Gen.frequency sub)
5162 where
52− l@(lf, _) = genContextualRequest (Proxy :: Proxy a)
53− r@(rf, _) = genContextualRequest (Proxy :: Proxy b)
54−
55−
56−instance (KnownSymbol path, HasContextualGenRequest b st)
57− => HasContextualGenRequest (path :> b) st where
58− genContextualRequest _ = (1, do
59−
60− old' <- (_old :: _)
61− return $ \burl st ->
62− let r = old' burl
63− oldPath = path r
64− oldPath' = BS.dropWhile (== BS.c2w '/') oldPath
65− paths = filter (not . BS.null) [new, oldPath']
66− in r { path = "/" <> BS.intercalate "/" paths })
63+ newfreq = sum (map fst sub)
64+ sub = catMaybes [l,r]
65+ l = genContextualRequest (Proxy :: Proxy a) store
66+ r = genContextualRequest (Proxy :: Proxy b) store
67+
68+withGeneratable p store cont = cont <$> genContextualRequest p store
69+
70+instance (KnownSymbol path, HasContextualGenRequest b )
71+ => HasContextualGenRequest (path :> b) where
72+ genContextualRequest _ store =
73+ withGeneratable (Proxy :: Proxy b) store $ \(oldf,old') -> do
74+ ( oldf, do
75+ old <- old'
76+ pure $ \burl ->
77+ let r = old burl
78+ oldPath = path r
79+ oldPath' = BS.dropWhile (== BS.c2w '/') oldPath
80+ paths = filter (not . BS.null) [new, oldPath']
81+ in r { path = "/" <> BS.intercalate "/" paths }
82+
83+ )
84+-- , pure ( \burl -> do
85+-- _
86+ -- fmap (Just . (1,)) $ return $ \burl st ->
6787 where
68− -- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
88+ -- (oldf, old) = genContextualRequest (Proxy :: Proxy b) store
6989 new = cs $ symbolVal (Proxy :: Proxy path)
7090
71−instance HasContextualGenRequest EmptyAPI st where
72− genContextualRequest _ = (0, error "EmptyAPIs cannot be queried.")
73−
74−instance HasContextualGenRequest api st => HasContextualGenRequest (Summary d :> api) st where
75− genContextualRequest _ = genContextualRequest (Proxy :: Proxy api)
76−
77−instance HasContextualGenRequest api st => HasContextualGenRequest (Description d :> api) st where
78− genContextualRequest _ = genContextualRequest (Proxy :: Proxy api)
79−
80−instance (HasContextualGenRequest b st, ToHttpApiData c )
81− => HasContextualGenRequest (Capture' mods x c :> b) st where
82− genContextualRequest _ = (oldf, do
83− old' <- old
84− new' <- toUrlPiece <$> _generator
85− return $ \burl st -> let r = old' burl st in r { path = cs new' <> path r })
86− where
87− (oldf, old) = genContextualRequest (Proxy :: Proxy b)
88−
89−instance (HasContextualGenRequest b st, ToHttpApiData c )
90− => HasContextualGenRequest (CaptureAll x c :> b) st where
91− genContextualRequest _ = (oldf, do
92− old' <- old
93− new' <- fmap (cs . toUrlPiece) <$> new
94− let new'' = BS.intercalate "/" new'
95− return $ \burl st -> let r = old' burl st
96− in r { path = new'' <> path r })
97− where
98− (oldf, old) = genContextualRequest (Proxy :: Proxy b)
99− new = _arbitrary :: Gen [c]
100−
101−instance (KnownSymbol h, HasContextualGenRequest b st, ToHttpApiData c)
102− => HasContextualGenRequest (Header' mods h c :> b) st where
103− genContextualRequest _ = (oldf, do
104− old' <- old
105− new' <- toUrlPiece <$> new -- TODO: generate lenient or/and optional
106− return $ \burl st -> let r = old' burl st in r {
107− requestHeaders = (hdr, cs new') : requestHeaders r })
108− where
109− (oldf, old) = genContextualRequest (Proxy :: Proxy b)
110− hdr = fromString $ symbolVal (Proxy :: Proxy h)
111− new = _arbitrary :: Gen c
112−
113−instance (AllMimeRender x c, HasContextualGenRequest b st)
114− => HasContextualGenRequest (ReqBody' mods x c :> b) st where
115− genContextualRequest _ = (oldf, do
116− old' <- old -- TODO: generate lenient
117− new' <- new
118− (ct, bd) <- elements $ allMimeRender (Proxy :: Proxy x) new'
119− return $ \burl st -> let r = old' burl st in r {
120− requestBody = RequestBodyLBS bd
121− , requestHeaders = ("Content-Type", renderHeader ct) : requestHeaders r
122− })
123− where
124− (oldf, old) = genContextualRequest (Proxy :: Proxy b)
125− new = _arbitrary :: Gen c
126−
127−instance (KnownSymbol x, ToHttpApiData c, HasContextualGenRequest b st)
128− => HasContextualGenRequest (QueryParam' mods x c :> b) st where
129− genContextualRequest _ = (oldf, do
130− new' <- new -- TODO: generate lenient or/and optional
131− old' <- old
132− return $ \burl st -> let
133− r = old' burl st
134− newExpr = param <> "=" <> cs (toQueryParam new')
135− qs = queryString r in r {
136− queryString = if BS.null qs then newExpr else newExpr <> "&" <> qs })
137− where
138− (oldf, old) = genContextualRequest (Proxy :: Proxy b)
139− param = cs $ symbolVal (Proxy :: Proxy x)
140− new = _arbitrary :: Gen c
141−
142−instance (KnownSymbol x, ToHttpApiData c, HasContextualGenRequest b st)
143− => HasContextualGenRequest (QueryParams x c :> b) st where
144− genContextualRequest _ = (oldf, do
145− new' <- _fetch
146− old' <- old
147− return $ \burl st -> let r = old' burl st in r {
148− queryString = queryString r
149− <> if length new' > 0 then fold (toParam <$> new') else ""})
150− where
151− (oldf, old) = genContextualRequest (Proxy :: Proxy b)
152− param = cs $ symbolVal (Proxy :: Proxy x)
153− toParam c = param <> "[]=" <> cs (toQueryParam c)
154− fold = foldr1 (\a b -> a <> "&" <> b)
155−
156−instance (KnownSymbol x, HasContextualGenRequest b st)
157− => HasContextualGenRequest (QueryFlag x :> b) st where
158− genContextualRequest _ = (oldf, do
159− old' <- old
160− return $ \burl st -> let r = old' burl st
161− qs = queryString r in r {
162− queryString = if BS.null qs then param else param <> "&" <> qs })
163− where
164− (oldf, old) = genContextualRequest (Proxy :: Proxy b)
165− param = cs $ symbolVal (Proxy :: Proxy x)
166−
167−instance (ReflectMethod method)
168− => HasContextualGenRequest (Verb (method :: k) (status :: Nat) (cts :: [*]) a) st where
169− genContextualRequest _ = (1, return $ \burl st -> defaultRequest
170− { host = cs $ baseUrlHost burl
171− , port = baseUrlPort burl
172− , secure = baseUrlScheme burl == Https
173− , method = reflectMethod (Proxy :: Proxy method)
174− })
175−
176−instance (ReflectMethod method)
177− => HasContextualGenRequest (NoContentVerb (method :: k)) st where
178− genContextualRequest _ = (1, return $ \burl st -> defaultRequest
179− { host = cs $ baseUrlHost burl
180− , port = baseUrlPort burl
181− , secure = baseUrlScheme burl == Https
182− , method = reflectMethod (Proxy :: Proxy method)
183− })
184−
185−instance (HasContextualGenRequest a st) => HasContextualGenRequest (RemoteHost :> a) st where
186− genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
187−
188−instance (HasContextualGenRequest a st) => HasContextualGenRequest (IsSecure :> a) st where
189− genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
190−
191−instance (HasContextualGenRequest a st) => HasContextualGenRequest (HttpVersion :> a) st where
192− genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
193−
194−instance (HasContextualGenRequest a st) => HasContextualGenRequest (Vault :> a) st where
195− genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
196−
197−instance (HasContextualGenRequest a st) => HasContextualGenRequest (WithNamedContext x y a) st where
198− genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
199−
200−-- TODO: Try logging in
201−instance (HasContextualGenRequest a st) => HasContextualGenRequest (BasicAuth x y :> a) st where
202− genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
91+-- instance HasContextualGenRequest EmptyAPI st where
92+-- genContextualRequest _ = (0, error "EmptyAPIs cannot be queried.")
93+
94+-- instance HasContextualGenRequest api st => HasContextualGenRequest (Summary d :> api) st where
95+-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy api)
96+
97+-- instance HasContextualGenRequest api st => HasContextualGenRequest (Description d :> api) st where
98+-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy api)
99+
100+-- instance (HasContextualGenRequest b st, ToHttpApiData c )
101+-- => HasContextualGenRequest (Capture' mods x c :> b) st where
102+-- genContextualRequest _ = (oldf, do
103+-- old' <- old
104+-- new' <- toUrlPiece <$> _generator
105+-- return $ \burl st -> let r = old' burl st in r { path = cs new' <> path r })
106+-- where
107+-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
108+
109+-- instance (HasContextualGenRequest b st, ToHttpApiData c )
110+-- => HasContextualGenRequest (CaptureAll x c :> b) st where
111+-- genContextualRequest _ = (oldf, do
112+-- old' <- old
113+-- new' <- fmap (cs . toUrlPiece) <$> new
114+-- let new'' = BS.intercalate "/" new'
115+-- return $ \burl st -> let r = old' burl st
116+-- in r { path = new'' <> path r })
117+-- where
118+-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
119+-- new = _arbitrary :: Gen [c]
120+
121+-- instance (KnownSymbol h, HasContextualGenRequest b st, ToHttpApiData c)
122+-- => HasContextualGenRequest (Header' mods h c :> b) st where
123+-- genContextualRequest _ = (oldf, do
124+-- old' <- old
125+-- new' <- toUrlPiece <$> new -- TODO: generate lenient or/and optional
126+-- return $ \burl st -> let r = old' burl st in r {
127+-- requestHeaders = (hdr, cs new') : requestHeaders r })
128+-- where
129+-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
130+-- hdr = fromString $ symbolVal (Proxy :: Proxy h)
131+-- new = _arbitrary :: Gen c
132+
133+-- instance (AllMimeRender x c, HasContextualGenRequest b st)
134+-- => HasContextualGenRequest (ReqBody' mods x c :> b) st where
135+-- genContextualRequest _ = (oldf, do
136+-- old' <- old -- TODO: generate lenient
137+-- new' <- new
138+-- (ct, bd) <- elements $ allMimeRender (Proxy :: Proxy x) new'
139+-- return $ \burl st -> let r = old' burl st in r {
140+-- requestBody = RequestBodyLBS bd
141+-- , requestHeaders = ("Content-Type", renderHeader ct) : requestHeaders r
142+-- })
143+-- where
144+-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
145+-- new = _arbitrary :: Gen c
146+
147+-- instance (KnownSymbol x, ToHttpApiData c, HasContextualGenRequest b st)
148+-- => HasContextualGenRequest (QueryParam' mods x c :> b) st where
149+-- genContextualRequest _ = (oldf, do
150+-- new' <- new -- TODO: generate lenient or/and optional
151+-- old' <- old
152+-- return $ \burl st -> let
153+-- r = old' burl st
154+-- newExpr = param <> "=" <> cs (toQueryParam new')
155+-- qs = queryString r in r {
156+-- queryString = if BS.null qs then newExpr else newExpr <> "&" <> qs })
157+-- where
158+-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
159+-- param = cs $ symbolVal (Proxy :: Proxy x)
160+-- new = _arbitrary :: Gen c
161+
162+-- instance (KnownSymbol x, ToHttpApiData c, HasContextualGenRequest b st)
163+-- => HasContextualGenRequest (QueryParams x c :> b) st where
164+-- genContextualRequest _ = (oldf, do
165+-- (new' :: c) <- _fetch
166+-- old' <- old
167+-- return $ \burl st -> let r = old' burl st in r {
168+-- queryString = queryString r
169+-- <> if length new' > 0 then fold (toParam <$> new') else ""})
170+-- where
171+-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
172+-- param = cs $ symbolVal (Proxy :: Proxy x)
173+-- toParam c = param <> "[]=" <> cs (toQueryParam c)
174+-- fold = foldr1 (\a b -> a <> "&" <> b)
175+
176+-- instance (KnownSymbol x, HasContextualGenRequest b st)
177+-- => HasContextualGenRequest (QueryFlag x :> b) st where
178+-- genContextualRequest _ = (oldf, do
179+-- old' <- old
180+-- return $ \burl st -> let r = old' burl st
181+-- qs = queryString r in r {
182+-- queryString = if BS.null qs then param else param <> "&" <> qs })
183+-- where
184+-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
185+-- param = cs $ symbolVal (Proxy :: Proxy x)
186+
187+-- instance (ReflectMethod method)
188+-- => HasContextualGenRequest (Verb (method :: k) (status :: Nat) (cts :: [*]) a) st where
189+-- genContextualRequest _ = (1, return $ \burl st -> defaultRequest
190+-- { host = cs $ baseUrlHost burl
191+-- , port = baseUrlPort burl
192+-- , secure = baseUrlScheme burl == Https
193+-- , method = reflectMethod (Proxy :: Proxy method)
194+-- })
195+
196+-- instance (ReflectMethod method)
197+-- => HasContextualGenRequest (NoContentVerb (method :: k)) st where
198+-- genContextualRequest _ = (1, return $ \burl st -> defaultRequest
199+-- { host = cs $ baseUrlHost burl
200+-- , port = baseUrlPort burl
201+-- , secure = baseUrlScheme burl == Https
202+-- , method = reflectMethod (Proxy :: Proxy method)
203+-- })
204+
205+-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (RemoteHost :> a) st where
206+-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
207+
208+-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (IsSecure :> a) st where
209+-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
210+
211+-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (HttpVersion :> a) st where
212+-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
213+
214+-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (Vault :> a) st where
215+-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
216+
217+-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (WithNamedContext x y a) st where
218+-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
219+
220+-- -- TODO: Try logging in
221+-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (BasicAuth x y :> a) st where
222+-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)