@@ -1,568 +0,0 @@
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