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