@@ -0,0 +1,567 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE DeriveGeneric #-}
5+{-# LANGUAGE FlexibleContexts #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE GADTs #-}
8+{-# LANGUAGE InstanceSigs #-}
9+{-# LANGUAGE MultiParamTypeClasses #-}
10+{-# LANGUAGE OverloadedStrings #-}
11+{-# LANGUAGE PolyKinds #-}
12+{-# LANGUAGE RankNTypes #-} -- Temporary
13+{-# LANGUAGE ScopedTypeVariables #-}
14+{-# LANGUAGE TupleSections #-}
15+{-# LANGUAGE TypeApplications #-}
16+{-# LANGUAGE TypeFamilies #-}
17+{-# LANGUAGE TypeOperators #-}
18+{-# LANGUAGE UndecidableInstances #-}
19+
20+module Servant.Reflex.RequestAPI where
21+
22+import Control.Arrow (first, second)
23+import Control.Lens
24+import Data.Generics.Product
25+import Data.Proxy
26+import Data.CaseInsensitive (mk)
27+import qualified Data.List as L
28+import qualified Data.Map as M
29+import Data.Maybe (catMaybes)
30+import Data.Semigroup ((<>))
31+import qualified Data.Set as Set
32+import qualified Data.Text.Encoding as E
33+import Data.Text (Text)
34+import qualified Data.Text as T
35+import qualified Data.ByteString.Lazy as BL
36+import GHC.Generics
37+import GHC.TypeLits (KnownSymbol, symbolVal)
38+import Reflex hiding (HList(..))
39+import Language.Javascript.JSaddle (MonadJSM)
40+import Servant.API hiding (HList(..))
41+import Servant.Common.Req hiding (QueryPart(..))
42+import Servant.Common.BaseUrl
43+
44+import Reflex.Dom hiding (HList(..))
45+
46+import Servant.Reflex (BuildHeaderKeysTo (..), toHeaders)
47+
48+{-
49+TODO:
50+ - [x] :<|>
51+ - [x] Verb content
52+ - [x] Verb nocontent
53+ - [x] Verb (Headers content)
54+ - [x] Verb (Headers nocontent)
55+ - [ ] Stream
56+ - [X] Capture :> ...
57+ - [ ] Capture' :> ...
58+ - [x] CaptureAll :> ...
59+ - [x] QueryParam :> ...
60+ - [x] QueryParams :> ...
61+ - [x] QueryFlag :> ...
62+ - [x] ReqBody :> ...
63+ - [ ] Header' :> ...
64+ - [x] Header :> ...
65+ - [x] Summary :> ...
66+ - [x] Description :> ...
67+ - [x] path :> ...
68+ - [ ] RemoteHost :> ...
69+ - [x] IsSecure :> ...
70+ - [x] Vault :> ...
71+ - [ ] WithNamedContext :> ...
72+ - [ ] AuthenticatedRequest :> ...
73+ - [x] BasicAuth :> ...
74+ - [ ] EmptyClient :> ...
75+ - [ ] EmptyClient
76+ - [ ] HttpVersion :> ...
77+-}
78+data HList xs where
79+ HNil :: HList '[]
80+ HCons :: x -> HList xs -> HList (x ': xs)
81+
82+clientR :: forall t m layout f . (HasClientR t m (Seal layout) f, Applicative f, Reflex t)
83+ => Proxy layout -> Proxy (m :: * -> *) -> Proxy t -> Proxy f
84+ -> Dynamic t BaseUrl -> ClientR t m (Seal layout) f
85+clientR _ mP tP fP url =
86+ clientRWithRoute (Proxy :: Proxy (Seal layout)) mP fP undefined url undefined
87+
88+-- | A class for generating top-level the API client function
89+class HasClientR t (m :: * -> *) api (f :: * -> *) where
90+ type ClientR t m api f :: *
91+ clientRWithRoute :: Proxy api -> Proxy m -> Proxy f
92+ -> Dynamic t (f (Req t)) -> Dynamic t BaseUrl
93+ -> ClientOptions -> ClientR t m api f
94+
95+-- instance EndpointR t m Raw f where
96+-- type EInputs t m Raw f = '[XhrRequest T.Text]
97+-- type EOutput t m Raw f = XhrResponse
98+
99+-- mkReq (HCons (XhrRequest method url conf) NHil) =
100+-- ReqR method
101+
102+
103+-- | A class for generating endpoint-level API client functions
104+-- We need two separate type classes because the needs of endpoints
105+-- and top-level clients are incompatible
106+--
107+-- Endpoints need to accumulate a list of their input types from
108+-- the API definition (the @EInputs@ associated type) when building
109+-- up a function from a sequence of @:>@ combinators. But for
110+-- sequences of @:<|>@ combinators, such a listing doesn't make
111+-- sense. So, we use one class for endpoint-level recursion and
112+-- another for collecting endpoints into the top-level API
113+class EndpointR t m api f where
114+
115+ type EInputs t m api f :: [*]
116+ type EOutput t m api f :: *
117+
118+ mkReq :: HList (EInputs t m api f) -> ReqR
119+ getResp :: XhrResponse -> EOutput t m api f
120+
121+
122+------------------------------------------------------------------------------
123+-- | :<|> APIs
124+instance {-# OVERLAPPING #-}
125+ (HasClientR t m (layoutLeft) f,
126+ HasClientR t m (layoutRight) f
127+ ) => HasClientR t m (layoutLeft :<|> layoutRight) f where
128+ type ClientR t m (layoutLeft :<|> layoutRight) f =
129+ ClientR t m layoutLeft f :<|> ClientR t m layoutRight f
130+ clientRWithRoute _ tP mP _ url opts =
131+ clientRWithRoute (Proxy @layoutLeft) tP mP undefined url opts
132+ :<|>
133+ clientRWithRoute (Proxy @layoutRight) tP mP undefined url opts
134+
135+#if MIN_VERSION_servant (0,13,0)
136+-- TODO: Untested
137+instance HasClientR t m EmptyClient f where
138+ type ClientR t m api f = EmptyClient
139+ clientRWithRoute _ _ _ _ _ _ = EmptyClient
140+#endif
141+
142+
143+class ToTuple xs where
144+ type Tuple xs :: *
145+ toTuple :: xs -> Tuple xs
146+ fromTuple :: Tuple xs -> xs
147+
148+data Sealed a
149+data SealedRaw
150+
151+type family Seal a where
152+ Seal (a :<|> b) = Seal a :<|> Seal b
153+ Seal Raw = SealedRaw
154+ Seal a = Sealed a
155+
156+
157+-- | Turn a single Endpoint into a client, by turning the input HList
158+-- into a tuple
159+instance {-# OVERLAPPING #-} forall t m layout f .(EndpointR t m layout f,
160+ ToTuple (HList (EInputs t m layout f)),
161+ Monad m
162+ , Traversable f
163+ , SupportsServantReflex t m
164+ ) => HasClientR t (m :: * -> *) (Sealed layout) (f :: * -> *) where
165+ type ClientR t m (Sealed layout) f =
166+ Event t (f (Tuple (HList (EInputs t m layout f))))
167+ -> m (Event t (f (EOutput t m layout f)))
168+ clientRWithRoute _ mP fP dReq url opts (reqs :: Event t (f (Tuple (HList (EInputs t m layout f ))))) = do
169+ let reqTuples = fmap (fromTuple @(HList (EInputs t m layout f ))) <$> reqs
170+
171+ -- TODO: replace these 2 lines w/ the next 2. The trace is for library debugging
172+ reqRs = traceEventWith (concat . fmap ((<> "\n") . show)) $ fmap (mkReq @t @m @layout @f) <$> reqTuples
173+ reqs' = ffor (attachPromptlyDyn url reqRs) $ \(bUrl, rs) -> mkXhrRequest bUrl <$> rs
174+ -- reqs' = ffor (attachPromptlyDyn url reqTuples) $ \(bUrl, inputs) ->
175+ -- mkXhrRequest bUrl . mkReq @t @m @layout @f <$> inputs
176+ resps <- performRequestsAsync $ reqs'
177+ return (fmap (getResp @t @m @layout @f) <$> resps)
178+
179+
180+instance (SupportsServantReflex t m, Traversable f) => HasClientR t m SealedRaw f where
181+ type ClientR t m SealedRaw f = Event t (f (XhrRequest T.Text)) -> m (Event t (f XhrResponse))
182+ clientRWithRoute _ mP fP dReq url opts reqs = performRequestsAsync reqs
183+
184+
185+instance {-# OVERLAPPING #-}(MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), SupportsServantReflex t m, Applicative f
186+ ) => EndpointR t m (Verb method status cts' a) f where
187+ type EInputs t m (Verb method status cts' a) f = '[]
188+ type EOutput t m (Verb method status cts' a) f = Either String a
189+
190+ mkReq _ = emptyReqR . E.decodeUtf8 $ reflectMethod (Proxy @method)
191+ getResp resp = case _xhrResponse_response resp of
192+ Just (XhrResponseBody_ArrayBuffer x) -> mimeUnrender (Proxy @ct) (BL.fromStrict x)
193+
194+instance {-# OVERLAPPING #-}(ReflectMethod method, SupportsServantReflex t m, Applicative f
195+ ) => EndpointR t m (Verb method status cts' NoContent) f where
196+ type EInputs t m (Verb method status cts' NoContent) f = '[]
197+ type EOutput t m (Verb method status cts' NoContent) f = Either String NoContent
198+
199+ mkReq _ = emptyReqR . E.decodeUtf8 $ reflectMethod (Proxy @method)
200+ getResp resp = Right NoContent -- TODO: Should EOutput be `NoContent` rather than Either... ?
201+
202+
203+instance {-# OVERLAPPING #-}
204+ (MimeUnrender ct a,
205+ BuildHeadersTo hs,
206+ ReflectMethod method, cts' ~ (ct ': cts),
207+ SupportsServantReflex t m,
208+ Applicative f,
209+ BuildHeaderKeysTo hs
210+ ) => EndpointR t m (Verb method status cts' (Headers hs a)) f where
211+ type EInputs t m (Verb method status cts' (Headers hs a)) f = '[]
212+ type EOutput t m (Verb method status cts' (Headers hs a)) f = Either String (Headers hs a)
213+
214+ mkReq _ = set (field @"reqRRespHeaders") (OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy @hs)))) $ emptyReqR $ E.decodeUtf8 $ reflectMethod (Proxy @method)
215+ getResp resp = case _xhrResponse_response resp of
216+ Just (XhrResponseBody_ArrayBuffer x) ->
217+ let hs = buildHeadersTo
218+ . fmap (first (mk . E.encodeUtf8) . second E.encodeUtf8)
219+ . M.toList
220+ $ _xhrResponse_headers resp
221+ in fmap (flip Headers (hs)) $ mimeUnrender (Proxy @ct) (BL.fromStrict x)
222+
223+
224+instance {-# OVERLAPPING #-}(MimeUnrender ct a,
225+ BuildHeadersTo hs,
226+ BuildHeaderKeysTo hs,
227+ ReflectMethod method,
228+ SupportsServantReflex t m,
229+ Applicative f
230+ ) => EndpointR t m (Verb method status cts' (Headers hs NoContent)) f where
231+ type EInputs t m (Verb method status cts' (Headers hs NoContent)) f = '[]
232+ type EOutput t m (Verb method status cts' (Headers hs NoContent)) f = Either String (Headers hs NoContent)
233+
234+ mkReq _ = set (field @"reqRRespHeaders") (OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy @hs)))) $ emptyReqR . E.decodeUtf8 $ reflectMethod (Proxy @method)
235+ getResp resp = case _xhrResponse_response resp of
236+ Just (XhrResponseBody_ArrayBuffer x) ->
237+ let hs = buildHeadersTo
238+ . fmap (first (mk . E.encodeUtf8) . second E.encodeUtf8)
239+ . M.toList
240+ $ _xhrResponse_headers resp
241+ in Right (Headers NoContent hs)
242+
243+
244+instance (SupportsServantReflex t m,
245+ ToHttpApiData a,
246+ EndpointR t m sublayout f,
247+ Applicative f
248+ ) => EndpointR t m (Capture capture a :> sublayout) f where
249+
250+ type EInputs t m (Capture capture a :> sublayout) f = a ': EInputs t m sublayout f
251+ type EOutput t m (Capture capture a :> sublayout) f = EOutput t m sublayout f
252+
253+ mkReq (HCons x xs) = (\a -> over (field @"reqRPathParts") (toUrlPiece a:)) x $
254+ mkReq @t @m @sublayout @f xs
255+
256+ getResp = getResp @t @m @sublayout @f
257+
258+instance (SupportsServantReflex t m,
259+ ToHttpApiData a,
260+ EndpointR t m sublayout f,
261+ Applicative f
262+ ) => EndpointR t m (CaptureAll capture a :> sublayout) f where
263+
264+ type EInputs t m (CaptureAll capture a :> sublayout) f = [a] ': EInputs t m sublayout f
265+ type EOutput t m (CaptureAll capture a :> sublayout) f = EOutput t m sublayout f
266+
267+ mkReq (HCons x xs) = (\a -> over (field @"reqRPathParts") (fmap toUrlPiece a <>)) x $
268+ mkReq @t @m @sublayout @f xs
269+
270+ getResp = getResp @t @m @sublayout @f
271+
272+
273+instance (SupportsServantReflex t m,
274+ KnownSymbol sym,
275+ EndpointR t m sublayout f,
276+ Applicative f
277+ ) => EndpointR t m (sym :> sublayout) f where
278+
279+ type EInputs t m (sym :> sublayout) f = EInputs t m sublayout f
280+ type EOutput t m (sym :> sublayout) f = EOutput t m sublayout f
281+
282+ mkReq r = over (field @"reqRPathParts") (T.pack (symbolVal (Proxy @sym)) :) $ mkReq @t @m @sublayout @f r
283+
284+ getResp = getResp @t @m @sublayout @f
285+
286+instance (SupportsServantReflex t m,
287+ ToHttpApiData a,
288+ EndpointR t m sublayout f,
289+ KnownSymbol sym,
290+ Applicative f
291+ ) => EndpointR t m (QueryParam sym a :> sublayout) f where
292+
293+ type EInputs t m (QueryParam sym a :> sublayout) f = Maybe a ': EInputs t m sublayout f
294+ type EOutput t m (QueryParam sym a :> sublayout) f = EOutput t m sublayout f
295+
296+ mkReq (HCons x xs) = over (field @"reqRParams") ((T.pack $ symbolVal (Proxy @sym),
297+ QueryPartParam $ fmap (toQueryParam) x) : ) $
298+ mkReq @t @m @sublayout @f xs
299+
300+
301+ getResp = getResp @t @m @sublayout @f
302+
303+instance (SupportsServantReflex t m,
304+ ToHttpApiData a,
305+ EndpointR t m sublayout f,
306+ KnownSymbol sym,
307+ Applicative f
308+ ) => EndpointR t m (QueryParams sym a :> sublayout) f where
309+
310+ type EInputs t m (QueryParams sym a :> sublayout) f = [a] ': EInputs t m sublayout f
311+ type EOutput t m (QueryParams sym a :> sublayout) f = EOutput t m sublayout f
312+
313+ mkReq (HCons x xs) =
314+ let newParams = (T.pack (symbolVal (Proxy @sym)), QueryPartParams (toQueryParam <$> x))
315+ in over (field @"reqRParams") (newParams :) $ mkReq @t @m @sublayout @f xs
316+
317+ getResp = getResp @t @m @sublayout @f
318+
319+instance (SupportsServantReflex t m,
320+ EndpointR t m sublayout f,
321+ KnownSymbol sym,
322+ Applicative f
323+ ) => EndpointR t m (QueryFlag sym :> sublayout) f where
324+
325+ type EInputs t m (QueryFlag sym :> sublayout) f = Bool ': EInputs t m sublayout f
326+ type EOutput t m (QueryFlag sym :> sublayout) f = EOutput t m sublayout f
327+
328+ mkReq (HCons x xs) =
329+ let newParam = (T.pack (symbolVal (Proxy @sym)), QueryPartFlag x)
330+ in over (field @"reqRParams") (newParam :) $ mkReq @t @m @sublayout @f xs
331+
332+ getResp = getResp @t @m @sublayout @f
333+
334+instance (SupportsServantReflex t m,
335+ EndpointR t m sublayout f,
336+ MimeRender ct a,
337+ Applicative f
338+ ) => EndpointR t m (ReqBody (ct ': cts) a :> sublayout) f where
339+
340+
341+ type EInputs t m (ReqBody (ct ': cts) a :> sublayout) f = a ': EInputs t m sublayout f
342+ type EOutput t m (ReqBody (ct ': cts) a :> sublayout) f = EOutput t m sublayout f
343+
344+ mkReq (HCons x xs) =
345+ set (field @"reqRBody") (Just (mimeRender (Proxy @ct) x, T.pack (show (contentType (Proxy @ct))))) $ mkReq @t @m @sublayout @f xs
346+
347+ getResp = getResp @t @m @sublayout @f
348+
349+
350+instance (SupportsServantReflex t m,
351+ EndpointR t m sublayout f,
352+ KnownSymbol sym,
353+ ToHttpApiData a,
354+ Applicative f
355+ ) => EndpointR t m (Header sym a :> sublayout) f where
356+
357+
358+ type EInputs t m (Header sym a :> sublayout) f = a ': EInputs t m sublayout f
359+ type EOutput t m (Header sym a :> sublayout) f = EOutput t m sublayout f
360+
361+ mkReq (HCons x xs) =
362+ over (field @"reqRHeaders")
363+ -- ((symbolVal (Proxy @sym), (mimeRender (Proxy @a) x)) :)
364+ ((T.pack $ symbolVal (Proxy @sym), E.decodeUtf8 $ toHeader x) :)
365+ $ mkReq @t @m @sublayout @f xs
366+
367+ getResp = getResp @t @m @sublayout @f
368+
369+#if MIN_VERSION_servant(0,13,0)
370+-- TODO: Untested
371+instance (SupportsServantReflex t m,
372+ EndpointR t m sublayout f,
373+ KnownSymbol sym,
374+ ToHttpApiData a,
375+ Applicative f
376+ ) => EndpointR t m (Summary desc :> sublayout) f where
377+
378+ type EInputs t m (Summary desc :> sublayout) f = EInputs t m sublayout f
379+ type EOutput t m (Summary desc :> sublayout) f = EOutput t m sublayout f
380+
381+ mkReq = mkReq @t @m @sublayout @f
382+
383+ getResp = getResp @t @m @sublayout @f
384+#endif
385+
386+
387+#if MIN_VERSION_servant(0,13,0)
388+-- TODO: Untested
389+instance (SupportsServantReflex t m,
390+ EndpointR t m sublayout f,
391+ KnownSymbol sym,
392+ ToHttpApiData a,
393+ Applicative f
394+ ) => EndpointR t m (Description desc :> sublayout) f where
395+
396+ type EInputs t m (Descriptiok desc :> sublayout) f = EInputs t m sublayout f
397+ type EOutput t m (Description desc :> sublayout) f = EOutput t m sublayout f
398+
399+ mkReq = mkReq @t @m @sublayout @f
400+
401+ getResp = getResp @t @m @sublayout @f
402+#endif
403+
404+instance (SupportsServantReflex t m,
405+ EndpointR t m sublayout f,
406+ KnownSymbol sym,
407+ ToHttpApiData a,
408+ Applicative f
409+ ) => EndpointR t m (IsSecure :> sublayout) f where
410+
411+
412+ type EInputs t m (IsSecure :> sublayout) f = EInputs t m sublayout f
413+ type EOutput t m (IsSecure :> sublayout) f = EOutput t m sublayout f
414+
415+ mkReq = mkReq @t @m @sublayout @f
416+
417+ getResp = getResp @t @m @sublayout @f
418+
419+instance (SupportsServantReflex t m,
420+ EndpointR t m sublayout f,
421+ KnownSymbol sym,
422+ ToHttpApiData a,
423+ Applicative f
424+ ) => EndpointR t m (Vault :> sublayout) f where
425+
426+
427+ type EInputs t m (Vault :> sublayout) f = EInputs t m sublayout f
428+ type EOutput t m (Vault :> sublayout) f = EOutput t m sublayout f
429+
430+ mkReq = mkReq @t @m @sublayout @f
431+
432+ getResp = getResp @t @m @sublayout @f
433+
434+instance (SupportsServantReflex t m,
435+ EndpointR t m sublayout f,
436+ Applicative f
437+ ) => EndpointR t m (BasicAuth realm usr :> sublayout) f where
438+
439+ type EInputs t m (BasicAuth realm usr :> sublayout) f = BasicAuthData ': EInputs t m sublayout f
440+ type EOutput t m (BasicAuth realm usr :> sublayout) f = EOutput t m sublayout f
441+
442+ mkReq (HCons x xs) =
443+ set (field @"reqRAuthData") (Just x) $ mkReq @t @m @sublayout @f xs
444+
445+ getResp = getResp @t @m @sublayout @f
446+
447+
448+instance ToTuple (HList '[]) where
449+ type Tuple (HList '[]) = ()
450+ toTuple _ = ()
451+ fromTuple _ = HNil
452+
453+instance ToTuple (HList '[a]) where
454+ type Tuple (HList '[a]) = a
455+ toTuple (HCons a HNil) = a
456+ fromTuple a = HCons a HNil
457+
458+instance ToTuple (HList '[a,b]) where
459+ type Tuple (HList '[a,b]) = (a,b)
460+ toTuple (HCons a (HCons b HNil)) = (a,b)
461+ fromTuple (a,b) = HCons a (HCons b HNil)
462+
463+instance ToTuple (HList '[a,b,c]) where
464+ type Tuple (HList '[a,b,c]) = (a,b,c)
465+ toTuple (HCons a (HCons b (HCons c HNil))) = (a,b,c)
466+ fromTuple (a,b,c) = HCons a (HCons b (HCons c HNil))
467+
468+type MyAPI = Header "hi" Int :> Capture "hello" Int :> Capture "hello2" Bool :> Get '[JSON] (Headers '[Header "hi" Int] Int)
469+ :<|> Get '[JSON] Bool
470+
471+type MyAPI2 = Raw
472+
473+
474+m :: forall t m.MonadWidget t m => m ()
475+m = do
476+ let (a :<|> b) = clientR (Proxy @MyAPI) (Proxy :: Proxy m) (Proxy :: Proxy t)
477+ (Proxy @[]) undefined
478+ btn <- button "Hello"
479+ resA <- a (fmap (:[]) ((2, 5,True) <$ btn))
480+ resB <- b (fmap (:[]) (() <$ btn))
481+ display =<< holdDyn "waiting" (leftmost [show <$> resB ])
482+ -- [show <$> resA
483+ -- , show <$> resB
484+ -- ])
485+
486+ let rawR = clientR (Proxy @MyAPI2) (Proxy @m) (Proxy @t) (Proxy @[]) undefined
487+ return ()
488+
489+data ReqR = ReqR
490+ { reqRMethod :: T.Text
491+ , reqRPathParts :: [T.Text]
492+ , reqRParams :: [(T.Text, QueryPart)]
493+ , reqRBody :: Maybe (BL.ByteString, T.Text)
494+ , reqRHeaders :: [(T.Text, T.Text)]
495+ , reqRRespHeaders :: XhrResponseHeaders
496+ , reqRAuthData :: Maybe BasicAuthData
497+ } deriving (Generic)
498+
499+instance Show ReqR where
500+ show (ReqR m pp ps b hs hs' a) = concat $ L.intersperse "\n" [
501+ "ReqR {"
502+ , ("reqRMethod = " <> show m)
503+ , ("reqRPathParts = " <> show pp)
504+ , ("reqRParams = " <> show ps)
505+ , ("reqRBody = " <> show b)
506+ , ("reqRHeaders = " <> show hs)
507+ , ("reqRRespHeaders = " <> show hs')
508+ , ("reqRAuthData = " <> maybe "Nothing" (const "Just <<redacted>>") a)
509+ ]
510+
511+emptyReqR :: T.Text -> ReqR
512+emptyReqR method = ReqR method [] [] Nothing [] (OnlyHeaders mempty) Nothing
513+
514+data QueryPart = QueryPartParam (Maybe Text)
515+ | QueryPartParams [Text]
516+ | QueryPartFlag Bool
517+ deriving (Show)
518+
519+mkXhrRequest :: BaseUrl -> ReqR -> XhrRequest T.Text
520+mkXhrRequest reqHost req =
521+ let path = T.intercalate "/" $ reqRPathParts req
522+
523+ queryPartString :: (Text, QueryPart) -> Maybe Text
524+ queryPartString (pName, qp) = case qp of
525+
526+ QueryPartParam Nothing -> Nothing
527+ QueryPartParam (Just a) -> Just (pName <> "=" <> escape a)
528+
529+ QueryPartParams ps -> Just . T.intercalate "&"
530+ $ fmap (\p -> pName <> "=" <> escape p)
531+ ps
532+
533+ QueryPartFlag True -> Just pName
534+ QueryPartFlag False -> Nothing
535+
536+ (</>) :: Text -> Text -> Text
537+ x </> y | ("/" `T.isSuffixOf` x) || ("/" `T.isPrefixOf` y) = x <> y
538+ | otherwise = x <> "/" <> y
539+
540+ queryString = T.intercalate "&" . catMaybes . map queryPartString $ reqRParams req
541+ url = showBaseUrl reqHost </> path <> if T.null queryString then "" else (T.cons '?' queryString)
542+
543+ (headers, body) =
544+ let headers0 = M.fromList $ reqRHeaders req
545+ in case reqRBody req of
546+ Nothing -> (headers0, "")
547+ Just (rb,ct) -> (M.insert "Content-Type" ct headers0,
548+ E.decodeUtf8 $ BL.toStrict rb)
549+
550+ xhrReqConfig = def
551+ { _xhrRequestConfig_headers = headers
552+ , _xhrRequestConfig_user = E.decodeUtf8 . basicAuthUsername <$> reqRAuthData req
553+ , _xhrRequestConfig_password = E.decodeUtf8 . basicAuthPassword <$> reqRAuthData req
554+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
555+ , _xhrRequestConfig_sendData = body
556+ , _xhrRequestConfig_responseHeaders = reqRRespHeaders req
557+ , _xhrRequestConfig_withCredentials = False
558+ }
559+ xhrReq = XhrRequest (reqRMethod req) url xhrReqConfig
560+ in xhrReq
561+
562+transformExample :: MonadWidget t m => ((Int, Char) -> Performable m Bool) -> Event t (Int, Char) -> m (Event t Bool)
563+transformExample f = \triggers -> performEvent (f <$> triggers)
564+-- transformExample = undefined -- let x = performEvent :: _ in undefined
565+
566+transform :: MonadWidget t m => forall a. (inp -> IO outp) -> (Event t inp -> m (Event t outp))
567+transform = undefined