@@ -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,205 @@ 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+
39+import Data.Dynamic (Dynamic, fromDynamic)
40+import Data.Map.Strict (Map)
41+import qualified Data.Map.Strict as Map
42+import Data.Maybe
43+import Data.Typeable (TypeRep, Typeable, typeRep)
44+import Hedgehog
45+import qualified Hedgehog.Gen as Gen
46+import Roboservant.Hedgehog
47+
48+class HasContextualGenRequest a where
49+ genContextualRequest :: Proxy a -> Map TypeRep Dynamic -> Maybe (Int, Gen ( BaseUrl -> Request))
50+
51+-- | Generatable is functionally equivalent to Arbitrary with a default.
52+-- It is separate because we want to allow overwriting at will.
53+class Generatable a where
54+ generator :: Gen [a]
55+ generator = pure []
56+
57+instance ( HasContextualGenRequest a
58+ , HasContextualGenRequest b)
59+ => HasContextualGenRequest (a :<|> b) where
60+ genContextualRequest _ store
61+ = case sub of
62+ [] -> Nothing
63+ _ -> Just (newfreq, Gen.frequency sub)
5164 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 })
65+ newfreq = sum (map fst sub)
66+ sub = catMaybes [l,r]
67+ l = genContextualRequest (Proxy :: Proxy a) store
68+ r = genContextualRequest (Proxy :: Proxy b) store
69+
70+withGeneratable p store cont = cont <$> genContextualRequest p store
71+
72+getCandidates p st cont =
73+ case Map.lookup (typeRep p) st of
74+ Nothing -> (0,error "shouldn't ever be invoked")
75+ Just x -> do
76+ case fromDynamic x of
77+ Nothing -> (0,error "shouldn't ever be invoked")
78+ Just candidates -> cont candidates
79+
80+instance (KnownSymbol path, HasContextualGenRequest b )
81+ => HasContextualGenRequest (path :> b) where
82+ genContextualRequest _ store =
83+ withGeneratable (Proxy :: Proxy b) store $ \(oldf,old') -> do
84+ ( oldf, do
85+ old <- old'
86+ pure $ \burl ->
87+ let r = old burl
88+ oldPath = path r
89+ oldPath' = BS.dropWhile (== BS.c2w '/') oldPath
90+ paths = filter (not . BS.null) [new, oldPath']
91+ in r { path = "/" <> BS.intercalate "/" paths }
92+
93+ )
6794 where
68− -- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
95+ -- (oldf, old) = genContextualRequest (Proxy :: Proxy b) store
6996 new = cs $ symbolVal (Proxy :: Proxy path)
7097
71−instance HasContextualGenRequest EmptyAPI st where
72− genContextualRequest _ = (0, error "EmptyAPIs cannot be queried.")
98+instance HasContextualGenRequest EmptyAPI where
99+ genContextualRequest _ _ = Nothing
73100
74−instance HasContextualGenRequest api st => HasContextualGenRequest (Summary d :> api) st where
101+instance HasContextualGenRequest api => HasContextualGenRequest (Summary d :> api) where
75102 genContextualRequest _ = genContextualRequest (Proxy :: Proxy api)
76103
77−instance HasContextualGenRequest api st => HasContextualGenRequest (Description d :> api) st where
104+instance HasContextualGenRequest api => HasContextualGenRequest (Description d :> api) where
78105 genContextualRequest _ = genContextualRequest (Proxy :: Proxy api)
79106
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)
107+instance (HasContextualGenRequest b, Typeable c, ToHttpApiData c )
108+ => HasContextualGenRequest (Capture' mods x c :> b) where
109+ genContextualRequest _ st = withGeneratable (Proxy :: Proxy b) st $ \(oldf,old) ->
110+ getCandidates (Proxy :: Proxy c) st $ \candidates ->
111+ (oldf
112+ ,do
113+ piece :: c <- Gen.choice candidates
114+ old' <- old
115+ pure $ \burl ->
116+ let r = old' burl
117+ in r { path = cs (toUrlPiece piece) <> path r })
118+
119+-- unsure how CaptureAll works, finish later.
120+-- instance (HasContextualGenRequest b, ToHttpApiData c, Typeable c )
121+-- => HasContextualGenRequest (CaptureAll x c :> b) where
122+-- genContextualRequest _ st = withGeneratable (Proxy :: Proxy b) st $ \(oldf,old) ->
123+-- getCandidates (Proxy :: Proxy c) st $ \candidates ->
124+-- (oldf, do
125+-- old' <- old
126+-- piece :: c <- Gen.choice candidates
127+-- let new'' = BS.intercalate "/" . fmap (cs . toUrlPiece) $ piece
128+
129+
130+
131+-- return $ \burl -> let r = old' burl
132+-- in r { path = new'' <> path r })
133+
134+-- -- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
135+-- -- new = _arbitrary :: Gen [c]
136+
137+-- instance (KnownSymbol h, HasContextualGenRequest b st, ToHttpApiData c)
138+-- => HasContextualGenRequest (Header' mods h c :> b) st where
139+-- genContextualRequest _ = (oldf, do
140+-- old' <- old
141+-- new' <- toUrlPiece <$> new -- TODO: generate lenient or/and optional
142+-- return $ \burl st -> let r = old' burl st in r {
143+-- requestHeaders = (hdr, cs new') : requestHeaders r })
144+-- where
145+-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
146+-- hdr = fromString $ symbolVal (Proxy :: Proxy h)
147+-- new = _arbitrary :: Gen c
148+
149+-- instance (AllMimeRender x c, HasContextualGenRequest b st)
150+-- => HasContextualGenRequest (ReqBody' mods x c :> b) st where
151+-- genContextualRequest _ = (oldf, do
152+-- old' <- old -- TODO: generate lenient
153+-- new' <- new
154+-- (ct, bd) <- elements $ allMimeRender (Proxy :: Proxy x) new'
155+-- return $ \burl st -> let r = old' burl st in r {
156+-- requestBody = RequestBodyLBS bd
157+-- , requestHeaders = ("Content-Type", renderHeader ct) : requestHeaders r
158+-- })
159+-- where
160+-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
161+-- new = _arbitrary :: Gen c
162+
163+-- instance (KnownSymbol x, ToHttpApiData c, HasContextualGenRequest b st)
164+-- => HasContextualGenRequest (QueryParam' mods x c :> b) st where
165+-- genContextualRequest _ = (oldf, do
166+-- new' <- new -- TODO: generate lenient or/and optional
167+-- old' <- old
168+-- return $ \burl st -> let
169+-- r = old' burl st
170+-- newExpr = param <> "=" <> cs (toQueryParam new')
171+-- qs = queryString r in r {
172+-- queryString = if BS.null qs then newExpr else newExpr <> "&" <> qs })
173+-- where
174+-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
175+-- param = cs $ symbolVal (Proxy :: Proxy x)
176+-- new = _arbitrary :: Gen c
177+
178+-- instance (KnownSymbol x, ToHttpApiData c, HasContextualGenRequest b st)
179+-- => HasContextualGenRequest (QueryParams x c :> b) st where
180+-- genContextualRequest _ = (oldf, do
181+-- (new' :: c) <- _fetch
182+-- old' <- old
183+-- return $ \burl st -> let r = old' burl st in r {
184+-- queryString = queryString r
185+-- <> if length new' > 0 then fold (toParam <$> new') else ""})
186+-- where
187+-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
188+-- param = cs $ symbolVal (Proxy :: Proxy x)
189+-- toParam c = param <> "[]=" <> cs (toQueryParam c)
190+-- fold = foldr1 (\a b -> a <> "&" <> b)
191+
192+-- instance (KnownSymbol x, HasContextualGenRequest b st)
193+-- => HasContextualGenRequest (QueryFlag x :> b) st where
194+-- genContextualRequest _ = (oldf, do
195+-- old' <- old
196+-- return $ \burl st -> let r = old' burl st
197+-- qs = queryString r in r {
198+-- queryString = if BS.null qs then param else param <> "&" <> qs })
199+-- where
200+-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
201+-- param = cs $ symbolVal (Proxy :: Proxy x)
202+
203+-- instance (ReflectMethod method)
204+-- => HasContextualGenRequest (Verb (method :: k) (status :: Nat) (cts :: [*]) a) st where
205+-- genContextualRequest _ = (1, return $ \burl st -> defaultRequest
206+-- { host = cs $ baseUrlHost burl
207+-- , port = baseUrlPort burl
208+-- , secure = baseUrlScheme burl == Https
209+-- , method = reflectMethod (Proxy :: Proxy method)
210+-- })
211+
212+-- instance (ReflectMethod method)
213+-- => HasContextualGenRequest (NoContentVerb (method :: k)) st where
214+-- genContextualRequest _ = (1, return $ \burl st -> defaultRequest
215+-- { host = cs $ baseUrlHost burl
216+-- , port = baseUrlPort burl
217+-- , secure = baseUrlScheme burl == Https
218+-- , method = reflectMethod (Proxy :: Proxy method)
219+-- })
220+
221+-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (RemoteHost :> a) st where
222+-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
223+
224+-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (IsSecure :> a) st where
225+-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
226+
227+-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (HttpVersion :> a) st where
228+-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
229+
230+-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (Vault :> a) st where
231+-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
232+
233+-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (WithNamedContext x y a) st where
234+-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
235+
236+-- -- TODO: Try logging in
237+-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (BasicAuth x y :> a) st where
238+-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)