git.iko.soy/typeable/servant-reflex
on master help sign in
Add forgotten file
f6d3b8bGreg Hale
src/Servant/Reflex/Multi.hsnew file+328
compare with master
unifiedsplit
@@ -0,0 +1,328 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE InstanceSigs #-}
7+{-# LANGUAGE OverloadedStrings #-}
8+{-# LANGUAGE PolyKinds #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE TupleSections #-}
11+{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE TypeOperators #-}
13+{-# LANGUAGE UndecidableInstances #-}
14+{-# LANGUAGE MultiParamTypeClasses #-}
15+
16+module Servant.Reflex.Multi
17+ ( clientA
18+ , HasClientMulti(..)
19+ ) where
20+
21+------------------------------------------------------------------------------
22+import Control.Applicative
23+import Data.Monoid ((<>))
24+import qualified Data.Set as Set
25+import qualified Data.Text.Encoding as E
26+import Data.CaseInsensitive (mk)
27+import Data.Proxy (Proxy (..))
28+import qualified Data.Map as Map
29+import Data.Text (Text)
30+import qualified Data.Text as T
31+import GHC.TypeLits (KnownSymbol, symbolVal)
32+import Servant.API ((:<|>)(..),(:>), BasicAuth,
33+ BasicAuthData, BuildHeadersTo(..),
34+ Capture, contentType, Header,
35+ Headers(..), HttpVersion, IsSecure,
36+ MimeRender(..), MimeUnrender,
37+ NoContent, QueryFlag, QueryParam,
38+ QueryParams, Raw, ReflectMethod(..),
39+ RemoteHost, ReqBody,
40+ ToHttpApiData(..), Vault, Verb)
41+
42+import Reflex.Dom (Dynamic, Event, Reflex,
43+ XhrRequest(..),
44+ XhrResponseHeaders(..),
45+ XhrResponse(..), ffor, fmapMaybe,
46+ leftmost, performRequestAsync,
47+ tagPromptlyDyn )
48+------------------------------------------------------------------------------
49+import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,
50+ showBaseUrl,
51+ SupportsServantReflex)
52+import Servant.Common.Req (Req, ReqResult(..), QParam(..),
53+ QueryPart(..), addHeader, authData,
54+ defReq, prependToPathParts,
55+ performRequestCT,
56+ performRequestsCT,
57+ performRequestNoBody,
58+ performRequestsNoBody,
59+ performSomeRequestsAsync,
60+ qParamToQueryPart, reqBody,
61+ reqSuccess, reqFailure,
62+ reqMethod, respHeaders, response,
63+ qParams)
64+import Servant.Reflex (BuildHeaderKeysTo(..), toHeaders)
65+
66+clientA :: (HasClientMulti t m layout f, Applicative f)
67+ => Proxy layout -> Proxy m -> Proxy f -> Dynamic t BaseUrl -> ClientMulti t m layout f
68+clientA p q f baseurl = clientWithRouteMulti p q f (pure defReq) baseurl
69+
70+class HasClientMulti t m layout f where
71+ type ClientMulti t m layout f :: *
72+ clientWithRouteMulti :: Proxy layout -> Proxy m -> Proxy f -> f (Req t) -> Dynamic t BaseUrl -> ClientMulti t m layout f
73+
74+instance (HasClientMulti t m a f, HasClientMulti t m b f) => HasClientMulti t m (a :<|> b) f where
75+ type ClientMulti t m (a :<|> b) f = ClientMulti t m a f :<|> ClientMulti t m b f
76+ clientWithRouteMulti Proxy q f reqs baseurl =
77+ clientWithRouteMulti (Proxy :: Proxy a) q f reqs baseurl :<|>
78+ clientWithRouteMulti (Proxy :: Proxy b) q f reqs baseurl
79+
80+
81+instance (SupportsServantReflex t m, ToHttpApiData a, HasClientMulti t m sublayout f, Applicative f)
82+ => HasClientMulti t m (Capture capture a :> sublayout) f where
83+
84+ type ClientMulti t m (Capture capture a :> sublayout) f =
85+ f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f
86+
87+ clientWithRouteMulti l q f reqs baseurl vals = clientWithRouteMulti (Proxy :: Proxy sublayout) q f reqs' baseurl
88+ where
89+ reqs' = prependToPathParts <$> ps <*> reqs
90+ ps = (fmap . fmap . fmap) toUrlPiece vals
91+
92+-- VERB (Returning content) --
93+instance {-# OVERLAPPABLE #-}
94+ -- Note [Non-Empty Content Types]
95+ (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts),
96+ SupportsServantReflex t m,
97+ Applicative f,
98+ Traversable f
99+ ) => HasClientMulti t m (Verb method status cts' a) f where
100+
101+ type ClientMulti t m (Verb method status cts' a) f =
102+ Event t () -> m (Event t (f (ReqResult a)))
103+
104+ clientWithRouteMulti _ _ f reqs baseurl =
105+ performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl
106+ where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
107+ reqs' = (\r -> r { reqMethod = method }) <$> reqs
108+
109+-- -- VERB (No content) --
110+instance {-# OVERLAPPING #-}
111+ (ReflectMethod method, SupportsServantReflex t m, Traversable f) =>
112+ HasClientMulti t m (Verb method status cts NoContent) f where
113+ type ClientMulti t m (Verb method status cts NoContent) f =
114+ Event t () -> m (Event t (f (ReqResult NoContent)))
115+ -- TODO: how to access input types here?
116+ -- ExceptT ServantError IO NoContent
117+ clientWithRouteMulti Proxy _ _ req baseurl =
118+ performRequestsNoBody method req baseurl
119+ where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
120+
121+instance {-# OVERLAPPABLE #-}
122+ -- Note [Non-Empty Content Types]
123+ ( MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,
124+ ReflectMethod method, cts' ~ (ct ': cts),
125+ SupportsServantReflex t m,
126+ Traversable f
127+ ) => HasClientMulti t m (Verb method status cts' (Headers ls a)) f where
128+ type ClientMulti t m (Verb method status cts' (Headers ls a)) f =
129+ Event t () -> m (Event t (f (ReqResult (Headers ls a))))
130+ clientWithRouteMulti Proxy _ _ reqs baseurl = do
131+ let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
132+ resp <- performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl
133+ return $ (fmap . fmap) toHeaders <$> resp
134+ where reqs' = ffor reqs $ \r -> r { respHeaders =
135+ OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
136+ }
137+
138+
139+instance {-# OVERLAPPABLE #-}
140+ ( BuildHeadersTo ls,
141+ BuildHeaderKeysTo ls,
142+ ReflectMethod method,
143+ SupportsServantReflex t m,
144+ Traversable f
145+ ) => HasClientMulti t m (Verb method status cts (Headers ls NoContent)) f where
146+ type ClientMulti t m (Verb method status cts (Headers ls NoContent)) f
147+ = Event t () -> m (Event t (f (ReqResult (Headers ls NoContent))))
148+ clientWithRouteMulti Proxy _ _ reqs baseurl = do
149+ let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
150+ resp <- performRequestsNoBody method reqs' baseurl
151+ return $ (fmap . fmap) toHeaders <$> resp
152+ where reqs' = ffor reqs $ \req ->
153+ req {respHeaders = OnlyHeaders (Set.fromList
154+ (buildHeaderKeysTo (Proxy :: Proxy ls)))
155+ }
156+
157+
158+instance (KnownSymbol sym,
159+ ToHttpApiData a,
160+ HasClientMulti t m sublayout f,
161+ SupportsServantReflex t m,
162+ Traversable f,
163+ Applicative f)
164+ => HasClientMulti t m (Header sym a :> sublayout) f where
165+
166+ type ClientMulti t m (Header sym a :> sublayout) f =
167+ f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f
168+
169+ clientWithRouteMulti Proxy f q reqs baseurl eVals =
170+ clientWithRouteMulti (Proxy :: Proxy sublayout) f
171+ q
172+ reqs'
173+ baseurl
174+ where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
175+ reqs' = (\eVal req -> Servant.Common.Req.addHeader hname eVal req)
176+ <$> eVals <*> reqs
177+
178+
179+instance HasClientMulti t m sublayout f
180+ => HasClientMulti t m (HttpVersion :> sublayout) f where
181+
182+ type ClientMulti t m (HttpVersion :> sublayout) f =
183+ ClientMulti t m sublayout f
184+
185+ clientWithRouteMulti Proxy q f =
186+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f
187+
188+
189+instance (KnownSymbol sym, ToHttpApiData a, HasClientMulti t m sublayout f, Reflex t, Traversable f, Applicative f)
190+ => HasClientMulti t m (QueryParam sym a :> sublayout) f where
191+
192+ type ClientMulti t m (QueryParam sym a :> sublayout) f =
193+ f (Dynamic t (QParam a)) -> ClientMulti t m sublayout f
194+
195+ -- if mparam = Nothing, we don't add it to the query string
196+ -- TODO: Check the above comment
197+ clientWithRouteMulti Proxy q f reqs baseurl mparams =
198+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f
199+ reqs' baseurl
200+
201+ where pname = symbolVal (Proxy :: Proxy sym)
202+ p prm = QueryPartParam $ fmap qParamToQueryPart prm
203+ paramPair mp = (T.pack pname, p mp)
204+ reqs' = (\param req -> req {qParams = paramPair param : qParams req})
205+ <$> mparams <*> reqs
206+
207+
208+instance (KnownSymbol sym,
209+ ToHttpApiData a,
210+ HasClientMulti t m sublayout f,
211+ Reflex t,
212+ Traversable f,
213+ Applicative f)
214+ => HasClientMulti t m (QueryParams sym a :> sublayout) f where
215+
216+ type ClientMulti t m (QueryParams sym a :> sublayout) f =
217+ f (Dynamic t [a]) -> ClientMulti t m sublayout f
218+
219+ clientWithRouteMulti Proxy q f reqs baseurl paramlists =
220+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f reqs' baseurl
221+
222+ where req' l r = r { qParams = (T.pack pname, params' l) : qParams r }
223+ pname = symbolVal (Proxy :: Proxy sym)
224+ params' l = QueryPartParams $ (fmap . fmap) (toQueryParam)
225+ l
226+ reqs' = req' <$> paramlists <*> reqs
227+
228+
229+instance (KnownSymbol sym,
230+ HasClientMulti t m sublayout f,
231+ Reflex t,
232+ Traversable f,
233+ Applicative f)
234+ => HasClientMulti t m (QueryFlag sym :> sublayout) f where
235+
236+ type ClientMulti t m (QueryFlag sym :> sublayout) f =
237+ f (Dynamic t Bool) -> ClientMulti t m sublayout f
238+
239+ clientWithRouteMulti Proxy q f reqs baseurl flags =
240+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f reqs' baseurl
241+
242+ where req' f req = req { qParams = thisPair f : qParams req }
243+ thisPair f = (T.pack pName, QueryPartFlag f) :: (Text, QueryPart t)
244+ pName = symbolVal (Proxy :: Proxy sym)
245+ reqs' = req' <$> flags <*> reqs
246+
247+
248+instance (SupportsServantReflex t m,
249+ Traversable f) => HasClientMulti t m Raw f where
250+ type ClientMulti t m Raw f = f (Dynamic t (Either Text (XhrRequest ())))
251+ -> Event t ()
252+ -> m (Event t (f (ReqResult ())))
253+
254+ clientWithRouteMulti Proxy Proxy Proxy oldReqs baseurl (rawReqs) triggers = do
255+ resps <- performSomeRequestsAsync (tagPromptlyDyn (sequence rawReqs) triggers )
256+ return $ (fmap . fmap) aux resps
257+ where
258+ aux (Right r) = ResponseSuccess () r
259+ aux (Left e) = RequestFailure e
260+
261+
262+instance (MimeRender ct a,
263+ HasClientMulti t m sublayout f,
264+ Reflex t,
265+ Traversable f,
266+ Applicative f)
267+ => HasClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f where
268+
269+ type ClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f =
270+ f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f
271+
272+ clientWithRouteMulti Proxy q f reqs baseurl bodies =
273+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f reqs' baseurl
274+ where req' b r = r { reqBody = bodyBytesCT b }
275+ ctProxy = Proxy :: Proxy ct
276+ ctString = T.pack $ show $ contentType ctProxy
277+ bodyBytesCT b = Just $ (fmap . fmap)
278+ (\b' -> (mimeRender ctProxy b', ctString))
279+ b
280+ reqs' = req' <$> bodies <*> reqs
281+
282+
283+instance (KnownSymbol path,
284+ HasClientMulti t m sublayout f,
285+ Reflex t,
286+ Functor f) => HasClientMulti t m (path :> sublayout) f where
287+ type ClientMulti t m (path :> sublayout) f = ClientMulti t m sublayout f
288+
289+ clientWithRouteMulti Proxy q f reqs baseurl =
290+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f
291+ (prependToPathParts (pure (Right $ T.pack p)) <$> reqs)
292+ baseurl
293+
294+ where p = symbolVal (Proxy :: Proxy path)
295+
296+
297+instance HasClientMulti t m api f => HasClientMulti t m (Vault :> api) f where
298+ type ClientMulti t m (Vault :> api) f = ClientMulti t m api f
299+
300+ clientWithRouteMulti Proxy q f reqs baseurl =
301+ clientWithRouteMulti (Proxy :: Proxy api) q f reqs baseurl
302+
303+
304+instance HasClientMulti t m api f => HasClientMulti t m (RemoteHost :> api) f where
305+ type ClientMulti t m (RemoteHost :> api) f = ClientMulti t m api f
306+
307+ clientWithRouteMulti Proxy q f reqs baseurl =
308+ clientWithRouteMulti (Proxy :: Proxy api) q f reqs baseurl
309+
310+
311+instance HasClientMulti t m api f => HasClientMulti t m (IsSecure :> api) f where
312+ type ClientMulti t m (IsSecure :> api) f = ClientMulti t m api f
313+
314+ clientWithRouteMulti Proxy q f reqs baseurl =
315+ clientWithRouteMulti (Proxy :: Proxy api) q f reqs baseurl
316+
317+
318+instance (HasClientMulti t m api f, Reflex t, Traversable f, Applicative f)
319+ => HasClientMulti t m (BasicAuth realm usr :> api) f where
320+
321+ type ClientMulti t m (BasicAuth realm usr :> api) f = f (Dynamic t (Maybe BasicAuthData))
322+ -> ClientMulti t m api f
323+
324+ clientWithRouteMulti Proxy q f reqs baseurl authdatas =
325+ clientWithRouteMulti (Proxy :: Proxy api) q f reqs' baseurl
326+ where
327+ req' a r = r { authData = Just a }
328+ reqs' = req' <$> authdatas <*> reqs