@@ -1,567 +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 #-} -- 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