@@ -1,238 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE GADTs #-}
6−{-# LANGUAGE KindSignatures #-}
7−{-# LANGUAGE LambdaCase #-}
8−{-# LANGUAGE MultiParamTypeClasses #-}
9−{-# LANGUAGE OverloadedStrings #-}
10−{-# LANGUAGE PolyKinds #-}
11−{-# LANGUAGE QuantifiedConstraints #-}
12−{-# LANGUAGE RankNTypes #-}
13−{-# LANGUAGE ScopedTypeVariables #-}
14−{-# LANGUAGE TupleSections #-}
15−{-# LANGUAGE TypeApplications #-}
16−{-# LANGUAGE TypeFamilies #-}
17−{-# LANGUAGE TypeOperators #-}
18−{-# LANGUAGE UndecidableInstances #-}
19−module Roboservant.ContextualGenRequest where
20−
21−import qualified Data.ByteString as BS
22−import qualified Data.ByteString.Internal as BS (c2w)
23−import Data.Data (Proxy (Proxy))
24−import Data.String (IsString (fromString))
25−import Data.String.Conversions (cs)
26−import GHC.TypeLits (KnownSymbol, Nat, symbolVal)
27−import Network.HTTP.Client (Request,
28− RequestBody (RequestBodyLBS),
29− defaultRequest, host, method, path,
30− port, queryString, requestBody,
31− requestHeaders, secure)
32−import Network.HTTP.Media (renderHeader)
33−import Servant
34−import Servant.API
35−import Servant.API.ContentTypes (AllMimeRender, allMimeRender)
36−import Servant.Client
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)
64− where
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− )
94− where
95− -- (oldf, old) = genContextualRequest (Proxy :: Proxy b) store
96− new = cs $ symbolVal (Proxy :: Proxy path)
97−
98−instance HasContextualGenRequest EmptyAPI where
99− genContextualRequest _ _ = Nothing
100−
101−instance HasContextualGenRequest api => HasContextualGenRequest (Summary d :> api) where
102− genContextualRequest _ = genContextualRequest (Proxy :: Proxy api)
103−
104−instance HasContextualGenRequest api => HasContextualGenRequest (Description d :> api) where
105− genContextualRequest _ = genContextualRequest (Proxy :: Proxy api)
106−
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)