git.iko.soy/typeable/servant-reflex
on master help sign in
WIP
commit630a6ebea017b72191c014c5ca195d938f4c501e authorIsaac Shapira <fresheyeball@gmail.com> dateWed 26 Apr 2017, 13:50 (9 years ago) parentcb7bb12
3 files changed+246−44
compare with master
unifiedsplit
overrides-ghc.nix+18−15 src/Servant/Common/Req.hs+169−10 src/Servant/Reflex.hs+59−19
overrides-ghc.nix+18−15
@@ -2,18 +2,21 @@
22let
33 dc = reflex-platform.lib.dontCheck;
44 c2n = reflex-platform.cabal2nixResult;
5−in reflex-platform.ghc.override {
6− overrides = self: super: {
7− servant-snap = dc (self.callPackage (c2n deps/servant-snap) {});
8− snap = dc (self.callPackage (c2n deps/servant-snap/deps/snap) {});
9− snap-server = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/snap-server) {});
10− io-streams = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/io-streams) {});
11− io-streams-haproxy = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/io-streams-haproxy) {});
12− heist = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/heist) {});
13− xmlhtml = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/xmlhtml) {});
14− snap-core = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/snap-core) {});
15− servant = dc (self.callPackage (c2n deps/servant/servant) {});
16− Glob = dc super.Glob;
17− http-api-data = dc (self.callPackage (c2n deps/http-api-data) {});
18− };
19−}
5+ ghc-mod = (import <nixpkgs> {}).haskellPackages.ghc-mod;
6+in
7+ reflex-platform.ghc.override {
8+ overrides = self: super: {
9+ servant-snap = dc (self.callPackage (c2n deps/servant-snap) {});
10+ snap = dc (self.callPackage (c2n deps/servant-snap/deps/snap) {});
11+ snap-server = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/snap-server) {});
12+ io-streams = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/io-streams) {});
13+ io-streams-haproxy = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/io-streams-haproxy) {});
14+ heist = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/heist) {});
15+ xmlhtml = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/xmlhtml) {});
16+ snap-core = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/snap-core) {});
17+ servant = dc (self.callPackage (c2n deps/servant/servant) {});
18+ Glob = dc super.Glob;
19+ http-api-data = dc (self.callPackage (c2n deps/http-api-data) {});
20+ ghc-mod = ghc-mod;
21+ };
22+ }
src/Servant/Common/Req.hs+169−10
@@ -26,6 +26,7 @@ import qualified Data.Text as T
2626import qualified Data.Text.Encoding as TE
2727import Data.Traversable (forM)
2828import Reflex.Dom hiding (tag)
29+import Reflex.Dom.Xhr (newXMLHttpRequest)
2930import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,
3031 SupportsServantReflex)
3132import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))
@@ -107,6 +108,10 @@ data QueryPart t = QueryPartParam (Dynamic t (Either Text (Maybe Text)))
107108 | QueryPartParams (Dynamic t [Text])
108109 | QueryPartFlag (Dynamic t Bool)
109110
111+data QueryPartIO = QueryPartParamIO (Maybe Text)
112+ | QueryPartParamsIO [Text]
113+ | QueryPartFlagIO Bool
114+
110115
111116-------------------------------------------------------------------------------
112117-- The data structure used to build up request information while traversing
@@ -121,6 +126,16 @@ data Req t = Req
121126 , authData :: Maybe (Dynamic t (Maybe BasicAuthData))
122127 }
123128
129+data ReqIO = ReqIO
130+ { reqMethodIO :: Text
131+ , reqPathPartsIO :: [Text]
132+ , qParamsIO :: [(Text, QueryPartIO)]
133+ , reqBodyIO :: Maybe (BL.ByteString, Text)
134+ , headersIO :: [(Text, Text)]
135+ , respHeadersIO :: XhrResponseHeaders
136+ , authDataIO :: Maybe BasicAuthData
137+ }
138+
124139defReq :: Req t
125140defReq = Req "GET" [] [] Nothing [] def Nothing
126141
@@ -137,7 +152,7 @@ reqToReflexRequest
137152 => Text
138153 -> Dynamic t BaseUrl
139154 -> Req t
140− -> (Dynamic t (Either Text (XhrRequest XhrPayload)))
155+ -> Dynamic t (Either Text (XhrRequest XhrPayload))
141156reqToReflexRequest reqMeth reqHost req =
142157 let t :: Dynamic t [Either Text Text]
143158 t = sequence $ reverse $ reqPathParts req
@@ -168,7 +183,9 @@ reqToReflexRequest reqMeth reqHost req =
168183
169184 queryPartStrings :: [Dynamic t (Maybe (Either Text Text))]
170185 queryPartStrings = map queryPartString (qParams req)
171− queryPartStrings' = fmap (sequence . catMaybes) $ sequence queryPartStrings :: Dynamic t (Either Text [Text])
186+
187+ queryPartStrings' :: Dynamic t (Either Text [Text])
188+ queryPartStrings' = sequence . catMaybes <$> sequence queryPartStrings :: Dynamic t (Either Text [Text])
172189 queryString :: Dynamic t (Either Text Text) =
173190 ffor queryPartStrings' $ \qs -> fmap (T.intercalate "&") qs
174191 xhrUrl = (liftA3 . liftA3) (\a p q -> a </> if T.null q then p else p <> "?" <> q)
@@ -182,17 +199,17 @@ reqToReflexRequest reqMeth reqHost req =
182199 xhrHeaders :: Dynamic t (Either Text [(Text, Text)])
183200 xhrHeaders = (fmap sequence . sequence . fmap f . headers) req
184201 where
185− f = \(headerName, dynam) ->
202+ f (headerName, dynam) =
186203 fmap (fmap (\rightVal -> (headerName, rightVal))) dynam
187204
188205 mkConfigBody :: Either Text [(Text,Text)]
189− -> (Either Text (BL.ByteString, Text))
206+ -> Either Text (BL.ByteString, Text)
190207 -> Either Text (XhrRequestConfig XhrPayload)
191208 mkConfigBody ehs rb = case (ehs, rb) of
192209 (_, Left e) -> Left e
193210 (Left e, _) -> Left e
194211 (Right hs, Right (bBytes, bCT)) ->
195− Right $ XhrRequestConfig
212+ Right XhrRequestConfig
196213 { _xhrRequestConfig_sendData = bytesToPayload bBytes
197214 , _xhrRequestConfig_headers =
198215 Map.insert "Content-Type" bCT (Map.fromList hs)
@@ -229,10 +246,103 @@ reqToReflexRequest reqMeth reqHost req =
229246 Nothing -> xhr
230247 Just auth -> liftA2 mkAuth auth xhr
231248
232− xhrReq = (liftA2 . liftA2) (\p opt -> XhrRequest reqMeth p opt) xhrUrl (addAuth xhrOpts)
249+ xhrReq = (liftA2 . liftA2) (XhrRequest reqMeth) xhrUrl (addAuth xhrOpts)
233250
234251 in xhrReq
235252
253+reqToReflexRequestIO
254+ :: Text
255+ -> BaseUrl
256+ -> ReqIO
257+ -> XhrRequest XhrPayload
258+reqToReflexRequestIO reqMeth reqHost req =
259+ let t :: [Text]
260+ t = reverse $ reqPathPartsIO req
261+
262+ baseUrl :: Text
263+ baseUrl = showBaseUrl reqHost
264+
265+ urlParts :: [Text]
266+ urlParts = t
267+
268+ urlPath :: Text
269+ urlPath = T.intercalate "/" urlParts
270+
271+ queryPartString :: (Text, QueryPartIO) -> Maybe Text
272+ queryPartString (pName, qp) = case qp of
273+ QueryPartParamIO p -> case p of
274+ Just a -> Just (pName <> "=" <> a)
275+ _ -> Nothing
276+ QueryPartParamsIO ps ->
277+ if null ps
278+ then Nothing
279+ else Just (T.intercalate "&" (fmap (\p -> pName <> "=" <> p) ps))
280+ QueryPartFlagIO fl -> if fl
281+ then Just pName
282+ else Nothing
283+
284+
285+ queryPartStrings :: [Maybe Text]
286+ queryPartStrings = map queryPartString (qParamsIO req)
287+
288+ queryPartStrings' :: [Text]
289+ queryPartStrings' = catMaybes queryPartStrings
290+
291+ queryString :: Text = T.intercalate "&" queryPartStrings'
292+
293+ xhrUrl = (\a p q -> a </> if T.null q then p else p <> "?" <> q)
294+ baseUrl urlPath queryString
295+ where
296+ (</>) :: Text -> Text -> Text
297+ x </> y | ("/" `T.isSuffixOf` x) || ("/" `T.isPrefixOf` y) = x <> y
298+ | otherwise = x <> "/" <> y
299+
300+
301+ xhrHeaders :: [(Text, Text)]
302+ xhrHeaders = headersIO req
303+
304+ mkConfigBody :: [(Text,Text)]
305+ -> (BL.ByteString, Text)
306+ -> XhrRequestConfig XhrPayload
307+ mkConfigBody hs (bBytes, bCT) =
308+ XhrRequestConfig
309+ { _xhrRequestConfig_sendData = bytesToPayload bBytes
310+ , _xhrRequestConfig_headers =
311+ Map.insert "Content-Type" bCT (Map.fromList hs)
312+ , _xhrRequestConfig_user = Nothing
313+ , _xhrRequestConfig_password = Nothing
314+ , _xhrRequestConfig_responseType = Nothing
315+ , _xhrRequestConfig_withCredentials = False
316+ , _xhrRequestConfig_responseHeaders = def
317+ }
318+
319+ xhrOpts :: XhrRequestConfig XhrPayload
320+ xhrOpts = case reqBodyIO req of
321+ Nothing -> def { _xhrRequestConfig_headers = Map.fromList xhrHeaders
322+ , _xhrRequestConfig_user = Nothing
323+ , _xhrRequestConfig_password = Nothing
324+ , _xhrRequestConfig_responseType = Nothing
325+ , _xhrRequestConfig_sendData = ""
326+ , _xhrRequestConfig_withCredentials = False
327+ }
328+ Just rBody -> mkConfigBody xhrHeaders rBody
329+
330+ mkAuth :: BasicAuthData -> XhrRequestConfig x -> XhrRequestConfig x
331+ mkAuth (BasicAuthData u p) config = config
332+ { _xhrRequestConfig_user = Just $ TE.decodeUtf8 u
333+ , _xhrRequestConfig_password = Just $ TE.decodeUtf8 p}
334+
335+ addAuth :: XhrRequestConfig x
336+ -> XhrRequestConfig x
337+ addAuth xhr = case authDataIO req of
338+ Nothing -> xhr
339+ Just auth -> mkAuth auth xhr
340+
341+ xhrReq = (XhrRequest reqMeth) xhrUrl (addAuth xhrOpts)
342+
343+ in xhrReq
344+
345+
236346-- * performing requests
237347
238348displayHttpRequest :: Text -> Text
@@ -275,9 +385,8 @@ performSomeRequestsAsync'
275385performSomeRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb -> do
276386 rs <- hrs
277387 resps <- forM rs $ \r -> case r of
278− Left e -> do
279− resp <- liftIO $ newMVar (Left e)
280− return resp
388+ Left e -> liftIO $ newMVar (Left e)
389+
281390 Right r' -> do
282391 resp <- liftIO newEmptyMVar
283392 _ <- newXhr r' $ liftIO . putMVar resp . Right
@@ -290,7 +399,7 @@ performSomeRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb ->
290399-- | This function actually performs the request.
291400performRequest :: forall t m tag .(SupportsServantReflex t m)
292401 => Text
293− -> (Req t)
402+ -> Req t
294403 -> Dynamic t BaseUrl
295404 -> Event t tag
296405 -> m (Event t (tag, XhrResponse), Event t (tag, Text))
@@ -306,6 +415,32 @@ performRequest reqMeth req reqHost trigger = do
306415 return (resps, badReqs)
307416
308417
418+-- | This function actually performs the request.
419+performRequestIO :: forall t m tag. (SupportsServantReflex t m)
420+ => Text
421+ -> ReqIO
422+ -> BaseUrl
423+ -> tag
424+ -> m (Either (tag, XhrResponse) (tag, Text))
425+performRequestIO reqMeth req reqHost trigger = do
426+
427+ let xhrReq = reqToReflexRequestIO reqMeth reqHost req
428+ let reqs = (trigger ,xhrReq )
429+
430+ -- resps <- performRequestsAsync okReqs
431+
432+ -- let x :: _ = newXMLHttpRequestWithError
433+
434+ -- return (resps, badReqs)
435+ undefined
436+
437+doThing :: (IsXhrPayload a, HasWebView IO) => XhrRequest a -> IO XhrResponse
438+doThing req = do
439+ v <- newEmptyMVar
440+ newXMLHttpRequest req $ putMVar v
441+ takeMVar v
442+
443+
309444type XhrPayload = T.Text
310445bytesToPayload :: BL.ByteString -> XhrPayload
311446bytesToPayload = TE.decodeUtf8 . BL.toStrict
@@ -370,6 +505,30 @@ performRequestsCT ct reqMeth reqs reqHost trigger = do
370505 resps
371506
372507
508+performRequestsCTIO
509+ :: (SupportsServantReflex t m,
510+ MimeUnrender ct a, Traversable f)
511+ => Proxy ct
512+ -> Text
513+ -> Dynamic t (f (Req t))
514+ -> Dynamic t BaseUrl
515+ -> Event t tag
516+ -> m (Event t (f (ReqResult tag a)))
517+performRequestsCTIO ct reqMeth reqs reqHost trigger = do
518+ resps <- performRequests reqMeth reqs reqHost trigger
519+ let decodeResp x = first T.pack .
520+ mimeUnrender ct .
521+ BL.fromStrict .
522+ TE.encodeUtf8 =<< note "No body text"
523+ (_xhrResponse_responseText x)
524+ return $ fmap
525+ (\(t,rs) -> ffor rs $ \r -> case r of
526+ Left e -> RequestFailure t e
527+ Right g -> evalResponse decodeResp (t,g)
528+ )
529+ resps
530+
531+
373532performRequestsNoBody
374533 :: (SupportsServantReflex t m,
375534 Traversable f)
src/Servant/Reflex.hs+59−19
@@ -1,17 +1,18 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE CPP #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE InstanceSigs #-}
7−{-# LANGUAGE MultiParamTypeClasses #-}
8−{-# LANGUAGE OverloadedStrings #-}
9−{-# LANGUAGE PolyKinds #-}
10−{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE TupleSections #-}
12−{-# LANGUAGE TypeFamilies #-}
13−{-# LANGUAGE TypeOperators #-}
14−{-# LANGUAGE UndecidableInstances #-}
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE FunctionalDependencies #-}
7+{-# LANGUAGE InstanceSigs #-}
8+{-# LANGUAGE MultiParamTypeClasses #-}
9+{-# LANGUAGE OverloadedStrings #-}
10+{-# LANGUAGE PolyKinds #-}
11+{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE TupleSections #-}
13+{-# LANGUAGE TypeFamilies #-}
14+{-# LANGUAGE TypeOperators #-}
15+{-# LANGUAGE UndecidableInstances #-}
1516
1617-- #include "overlapping-compat.h"
1718-- | This module provides 'client' which can automatically generate
@@ -59,8 +60,8 @@ import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),
5960 SupportsServantReflex, baseUrlWidget,
6061 showBaseUrl)
6162import Servant.Common.Req (QParam (..), QueryPart (..), Req,
62− ReqResult (..), addHeader, authData,
63− defReq, evalResponse,
63+ ReqIO, ReqResult (..), addHeader,
64+ authData, defReq, evalResponse,
6465 performRequestsCT,
6566 performRequestsNoBody,
6667 performSomeRequestsAsync,
@@ -93,18 +94,36 @@ client p q t = clientWithRoute p q t defReq
9394-- | This class lets us define how each API combinator
9495-- influences the creation of an HTTP request. It's mostly
9596-- an internal class, you can just use 'client'.
96−class HasClient t m layout (tag :: *) where
97+class HasClient t m layout (tag :: *) | m -> t where
9798 type Client t m layout tag :: *
98− clientWithRoute :: Proxy layout -> Proxy m -> Proxy tag -> Req t -> Dynamic t BaseUrl -> Client t m layout tag
99−
99+ type ClientIO m layout tag :: *
100+ clientWithRoute
101+ :: Proxy layout
102+ -> Proxy m
103+ -> Proxy tag
104+ -> Req t
105+ -> Dynamic t BaseUrl
106+ -> Client t m layout tag
107+ clientWithRouteIO
108+ :: Proxy layout
109+ -> Proxy m
110+ -> Proxy tag
111+ -> ReqIO
112+ -> BaseUrl
113+ -> ClientIO m layout tag
100114
101115instance (HasClient t m a tag, HasClient t m b tag) => HasClient t m (a :<|> b) tag where
102116 type Client t m (a :<|> b) tag = Client t m a tag :<|> Client t m b tag
117+ type ClientIO m (a :<|> b) tag = ClientIO m a tag :<|> ClientIO m b tag
103118
104119 clientWithRoute Proxy q pTag req baseurl =
105120 clientWithRoute (Proxy :: Proxy a) q pTag req baseurl :<|>
106121 clientWithRoute (Proxy :: Proxy b) q pTag req baseurl
107122
123+ clientWithRouteIO Proxy q pTag req baseurl =
124+ clientWithRouteIO (Proxy :: Proxy a) q pTag req baseurl :<|>
125+ clientWithRouteIO (Proxy :: Proxy b) q pTag req baseurl
126+
108127
109128-- Capture. Example:
110129-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book
@@ -124,6 +143,9 @@ instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout ta
124143 type Client t m (Capture capture a :> sublayout) tag =
125144 Dynamic t (Either Text a) -> Client t m sublayout tag
126145
146+ type ClientIO m (Capture capture a :> sublayout) tag =
147+ a -> ClientIO m sublayout tag
148+
127149 clientWithRoute Proxy q t req baseurl val =
128150 clientWithRoute (Proxy :: Proxy sublayout)
129151 q t
@@ -131,14 +153,26 @@ instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout ta
131153 baseurl
132154 where p = (fmap . fmap) toUrlPiece val
133155
156+ clientWithRouteIO Proxy q t req baseurl val =
157+ clientWithRouteIO (Proxy :: Proxy sublayout)
158+ q t
159+ (prependToPathParts p req)
160+ baseurl
161+ where p = (fmap . fmap) toUrlPiece val
162+
134163
135164-- VERB (Returning content) --
136165instance {-# OVERLAPPABLE #-}
137166 -- Note [Non-Empty Content Types]
138167 (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), SupportsServantReflex t m
139168 ) => HasClient t m (Verb method status cts' a) tag where
169+
140170 type Client t m (Verb method status cts' a) tag =
141171 Event t tag -> m (Event t (ReqResult tag a))
172+
173+ type ClientIO m (Verb method status cts' a) tag =
174+ tag -> m (ReqResult tag a)
175+
142176 -- TODO how to access input types here?
143177 -- ExceptT ServantError IO a
144178 clientWithRoute Proxy _ _ req baseurl trigs =
@@ -147,6 +181,12 @@ instance {-# OVERLAPPABLE #-}
147181 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
148182 req' = req { reqMethod = method }
149183
184+ clientWithRouteIO Proxy _ _ req baseurl tag =
185+ -- performRequestCT (Proxy :: Proxy ct) method req' baseurl trigs
186+ fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl tag
187+ where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
188+ req' = req { reqMethod = method }
189+
150190
151191-- -- VERB (No content) --
152192instance {-# OVERLAPPING #-}