git.iko.soy/typeable/servant-reflex
on master help sign in
inline performAJAX
11e01e7Greg Hale
src/Servant/Common/Req.hs+6−5
compare with master
unifiedsplit
@@ -55,7 +55,7 @@ data ServantError
55 deriving (Show, Typeable)
55 deriving (Show, Typeable)
56
56
57instance Exception ServantError
57instance Exception ServantError
58−
58+
59data Req = Req
59data Req = Req
60 { reqPath :: String
60 { reqPath :: String
61 , qs :: QueryText
61 , qs :: QueryText
@@ -129,18 +129,19 @@ performRequestNoBody = undefined
129-- performRequest :: Method -> Req -> BaseUrl -> Manager
129-- performRequest :: Method -> Req -> BaseUrl -> Manager
130-- -> ExceptT ServantError IO ( Int, ByteString, MediaType
130-- -> ExceptT ServantError IO ( Int, ByteString, MediaType
131-- , [HTTP.Header], Response ByteString)
131-- , [HTTP.Header], Response ByteString)
132+-- performRequest :: MonadWidget t m => Method -> Req -> BaseUrl ->
132-- performRequest reqMethod req reqHost manager = do
133-- performRequest reqMethod req reqHost manager = do
133-- partialRequest <- liftIO $ reqToRequest req reqHost
134-- partialRequest <- liftIO $ reqToRequest req reqHost
134−
135+--
135-- let request = partialRequest { Client.method = reqMethod
136-- let request = partialRequest { Client.method = reqMethod
136-- , checkStatus = \ _status _headers _cookies -> Nothing
137-- , checkStatus = \ _status _headers _cookies -> Nothing
137-- }
138-- }
138−
139+--
139-- eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager
140-- eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager
140-- case eResponse of
141-- case eResponse of
141-- Left err ->
142-- Left err ->
142-- throwE . ConnectionError $ SomeException err
143-- throwE . ConnectionError $ SomeException err
143−
144+--
144-- Right response -> do
145-- Right response -> do
145-- let status = Client.responseStatus response
146-- let status = Client.responseStatus response
146-- body = Client.responseBody response
147-- body = Client.responseBody response
@@ -151,7 +152,7 @@ performRequestNoBody = undefined
151-- Just t -> case parseAccept t of
152-- Just t -> case parseAccept t of
152-- Nothing -> throwE $ InvalidContentTypeHeader (cs t) body
153-- Nothing -> throwE $ InvalidContentTypeHeader (cs t) body
153-- Just t' -> pure t'
154-- Just t' -> pure t'
154−-- unless (status_code >= 200 && status_code < 300) $
155+-- unless (status_code >= 200 && status_code < 300) $
155-- throwE $ FailureResponse status ct body
156-- throwE $ FailureResponse status ct body
156-- return (status_code, body, ct, hrds, response)
157-- return (status_code, body, ct, hrds, response)
157
158
src/Servant/Reflex.hs+30−15
@@ -84,20 +84,36 @@ class HasReflexClient layout where
84 -> Client (Input layout) (Output layout)
84 -> Client (Input layout) (Output layout)
85
85
86
86
87−-- -- | If you have a 'Get' endpoint in your API, the client
87+-- | If you have a 'Get' endpoint in your API, the client
88−-- -- side querying function that is created when calling 'client'
88+-- side querying function that is created when calling 'client'
89−-- -- will just require an argument that specifies the scheme, host
89+-- will just require an argument that specifies the scheme, host
90−-- -- and port to send the request to.
90+-- and port to send the request to.
91−-- instance
91+instance
92−-- #if MIN_VERSION_base(4,8,0)
92+#if MIN_VERSION_base(4,8,0)
93−-- {-# OVERLAPPABLE #-}
93+ {-# OVERLAPPABLE #-}
94−-- #endif
94+#endif
95−-- (MimeUnrender ct result) => HasReflexClient (Get (ct ': cts) result) where
95+ (MimeUnrender ct result) => HasReflexClient (Get (ct ': cts) result) where
96−-- type Input (Get (ct ': cts) result) = ()
96+ type Input (Get (ct ': cts) result) = ()
97−-- -- type Output (Get (ct' : cts) result) = result
97+ type Output (Get (ct' : cts) result) = result
98−-- type Client (Get (ct ': cts) result) = Final result
99−-- clientWithRoute Proxy req baseurl _ =
98+ clientWithRoute Proxy req baseurl trigEvents = performAJAX requestBuilder responseParser
100−-- snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req baseurl
99+ where
100+ requestBuilder _ = XhrRequest "GET" (showBaseUrl baseurl) def
101+ responseParser xhrResp =
102+
103+performAJAX
104+ :: (MonadWidget t m)
105+ => (a -> XhrRequest)
106+ -- ^ Function to build the request
107+ -> (XhrResponse -> b)
108+ -- ^ Function to parse the response
109+ -> Event t a
110+ -> m (Event t (a, b))
111+performAJAX mkRequest parseResponse req =
112+ performEventAsync $ ffor req $ \a cb -> do
113+ _ <- newXMLHttpRequest (mkRequest a) $ \response ->
114+ liftIO $ cb (a, parseResponse response)
115+ return ()
116+
101
117
102instance
118instance
103#if MIN_VERSION_base(4,8,0)
119#if MIN_VERSION_base(4,8,0)
@@ -106,7 +122,6 @@ instance
106 HasReflexClient (Get (ct ': cts) ()) where
122 HasReflexClient (Get (ct ': cts) ()) where
107 type Input (Get (ct ': cts) ()) = ()
123 type Input (Get (ct ': cts) ()) = ()
108 type Output (Get (ct ': cts) ()) = ()
124 type Output (Get (ct ': cts) ()) = ()
109− -- type Client (Get (ct ': cts) ()) = Final ()
110 clientWithRoute Proxy req baseurl trigEvents =
125 clientWithRoute Proxy req baseurl trigEvents =
111 performAJAX requestBuilder responseParser trigEvents
126 performAJAX requestBuilder responseParser trigEvents
112 where
127 where